pax_global_header00006660000000000000000000000064145406145050014516gustar00rootroot0000000000000052 comment=f25f1a24eaac972f5685a65cddedc8147d8e0f67 gcl27-2.7.0/000077500000000000000000000000001454061450500124425ustar00rootroot00000000000000gcl27-2.7.0/.gitignore000066400000000000000000000001561454061450500144340ustar00rootroot00000000000000TAGS config.log config.status gcl.script machine makedefc makedefs makedefsafter cmpinclude.h autom4te.cache/ gcl27-2.7.0/BUGS000066400000000000000000001546101454061450500131340ustar00rootroot00000000000000This is a list of bugs that have been found in gcl. When you fix a bug, add the notation (FIXED) after the bug number, but leave the number in place so it isn't reused. 1 (FIXED). (subtypep s 'structure-object) isn't working properly when s is a structure class name or a structure class object. This is causing 95 ansi-test failures. 2. (FIXED) (sublis x y :test #'fn) is passing the arguments to fn in the wrong order. The problem here is that the :key argument is being applied somewhat unusually, making the usual TEST macro not do quite the right thing. ansi-tests: sublis.9 and sublis.10 3. (FIXED) (nsublis x y :test #'fn) is passing the arguments to fn in the wrong order. Similar to bug #2. ansi-tests: nsublis.10 and nsublis.11 4. (FIXED) (last x n) is incorrectly signaling an error when n is a positive bignum. Instead, it should return x. ansi-tests: last.11, last.12 5. (FIXED) The map* functions should signal a type error when given an improper list. They do so, but the slots of the type error object don't satisfy the property that the value in the datum slot is not of the type in the expected-type slot. ansi-tests: mapc.error.8, mapcar.error.8, mapcan.error.8, mapl.error.8, maplist.error.11, mapcon.error.8 6. (FIXED) Similar to #5, but the error is for GET-PROPERTIES. ansi-tests: get-properties.error.[456] 7. (FIXED) (SETF (GETF form1 form2 form3) form4) is evaluating the subforms in the wrong order: form3 is being evaluated before (the subforms of) form1 and form2. ansi-tests: setf-getf.order.2 8. (FIXED) Similar to #5, but the error is for GETF. ansi-tests: getf.error.[45] 9. (FIXED) REMF is violating the requirement that the value of the place be read out after all the other subforms of the REMF form are computed (even the ones to the right of the place form; see section 5.1.3 of CLtS). ansi-tests: remf.order.3 10. Similar to #5, but on ELT when the index is out of range. Should return a type-error with datum == the index and type == `(integer 0 (,(length sequence))) (or NIL if the sequence has length 0). ani-tests: elt.1, elt.1b, elt.2, 11. There's an internal type error somewhere in the code exercised by elt.10 -- the invalid type (integer 0 . 1) is being passed to TYPEP (and similarly for elt.14, elt-v.1, elt-v.10, elt-adj-array.1, elt-adj-array.10, elt-displaced-array.1, elt-fill-pointer.[3468], and elt,error.[45]). 12. (FIXED) Coerce can't coerce a vector of characters into a base-string. ansi-tests: fill.string.10 13. (FIXED) MAKE-SEQUENCE fails on type argument NULL, (CLASS-OF NIL), or (FIND-CLASS LIST). ansi-tests: make-sequence.57 14. (partially FIXED; map.error.11 still fails) The datum and expected type fields of the type errors thrown by MAKE-SEQUENCE, MAP do not satisfy the constraint that the datum is not of type expected-type. ansi-tests: make-sequence.error.1, make-sequence.error.2, make-sequence.error.14, make-sequence.error.16, map.error.1, map.error.1a, map.error.11. 15. (FIXED) MAP fails on type argument NULL, (OR (VECTOR 5) (VECTOR 10)) ansi-tests: map-null.1, map.48 16. NREVERSE is broken on vectors of element type LISP:SIGNED-SHORT (let ((v (make-array '(7) :initial-contents '(1 1 0 1 1 1 0) :element-type 'lisp:signed-short))) (nreverse v)) ==> #(0 1 1 1 1 1 0) (ansi-tests: nreverse-vector.7, nreverse-vector.8) 17. (FIXED) The setf expander for SUBSEQ returns the wrong value (the entire vector is returned rather than the aubsequence being assigned.) ansi-tests: subseq.order.[34] 18. (FIXED) CONCATENATE fails on type argument of NULL, as does MERGE. ansi-tests:. concatenate.24, merge-null.1, merge.error.6 19, (partially FIXED; no-extra-symbols-exported-from-common-lisp still fails) There are 140 symbols exported from the COMMON-LISP package that should not be external in that package. ansi-tests: no-extra-symbols-exported-from-common-lisp all-exported-cl-class-names-are-valid 20. 19 functions are missing: arithmetic-error-operands broadcast-stream-streams cell-error-name concatenated-stream-streams echo-stream-input-stream echo-stream-output-stream function-lambda-expression (FIXED)get-setf-expansion (FIXED) make-load-form-saving-slots pprint-indent pprint-newline pprint-tab print-not-readable-object simple-condition-format-control synonym-stream-symbol two-way-stream-input-stream two-way-stream-output-stream unbound-slot-instance (FIXED)compiler-macro-function readtable-case. ansi-tests: cl-function-symbols.1, dcf-funs and these tests: cell-error-name: symbol-value.error.5 symbol-function.error.5 makunbound.2 eval.error.3 eval.error.4 cell-error-name.[123456] cell-error-name.error.[12] get-setf-expansion (FIXED) get-setf-expansion.error.[12] get-setf-expansion.[123] simple-condition-format-control error.1 error.4 cerror.1 cerror.4 synonym-stream-symbol: synonym-stream-symbol.1 synonym-stream-symbol.error.[12] broadcast-stream-streams: broadcast-stream-streams.[12] broadcast-stream-streams.error.[12] two-way-stream-input-stream: two-way-stream-input-stream.1 two-way-stream-input-stream.error.[12] two-way-stream-output-stream: two-way-stream-output-stream.1 two-way-stream-output-stream.error.[12] echo-stream-input-stream: echo-stream-input-stream.1 echo-stream-input-stream.error.[12] echo-stream-output-stream: echo-stream-output-stream.1 echo-stream-output-stream.error.[12] concatenated-stream-streams: concatenated-stream-streams.[12345] concatenated-stream-streams.error.[12] (FIXED) make-load-form-saving-slots: make-load-form-saving-slots.[123456789] make-load-form-saving-slots.1[012] make-load-form-saving-slots.error.[12] pprint-indent pprint-indent.[123456789] pprint-indent.1[0123456789] pprint-indent.13a pprint-indent.2[0123] pprint-indent.error.[123] pprint-newline pprint-newline.[123] pprint-newline.linear.[123456789] pprint-newline.linear.10 pprint-newline.miser.123456789] pprint-newline.miser.1[0123] pprint-newline.fill.[123456789] pprint-newline.fill.10 pprint-newline.mandatory.[123456] pprint-newline.error.123] pprint-newline.error.1-unsafe pprint-tab pprint-tab.non-pretty.[12345678] pprint-tab.nil.1 pprint-tab.t.1 pprint-tab.line.1 pprint-tab.section.1 pprint-tab.line-relative.1 pprint-tab.section-relative.1 pprint.tab.error.[1234] 21. The following macros are missing: (FIXED)define-compiler-macro (FIXED)define-setf-expander define-symbol-macro in-package. ansi-tests: cl-macro-symbols.1 in-package.error.1 dcf-macros define-setf-expander.error.1 (FIXED) define-setf-expander.[1234567] (partially FIXED; define-setf-expander.7 still fails) define-compiler-macro.error.[123] define-compiler-macro.[12345678] define-symbol-macro.error.[123] documentation.symbol.setf.[12] 22. GENTEMP should take a package designator as its second argument, not just a package object. ansi-tests: gentemp.[345]. 23. (special-operator-p 'symbol-macrolet) should be true. ansi-tests: special-operator-p.1 24. (debatable) special-operator-p should be nil on DECLARE and IN-PACKAGE. ansi-tests: special-operator-p.2 25. (debatable) "USER" should not be a nickname of "COMMON-LISP-USER" (instead, it can name a separate package). ansi-tests: common-lisp-user-package-nicknames 26. FIND-ALL-SYMBOLS should take a string designator, which includes character values. ansi-tests: find-all-symbols.2 27. Free special declarations do not apply to the final value clauses of iteration forms. ansi-tests: do-symbols.16 do-external-symbols.16 28. The scope of the bound variable in DO-ALL-SYMBOLS should include the final value form. ansi-tests: do-all-symbols.4 29. The implicit block in DO-ALL-SYMBOLS should surround the entire loop, including the return value form. ansi-tests: do-all-symbols.6 30. DO-ALL-SYMBOLS should accept declarations. ansi-tests: do-all-symbols.9 do-all-symbols.10 do-all-symbols.11 31. IMPORT should set the home package of any symbol being imported that does not have a home package. ansi-tests: import.5 32. The setf expander for VALUES evaluates the source form before the subforms of the destination places. ansi-tests: setf-values.5 33. Order of evaluation problem in expansion of psetq/psetf, possibly involving symbol macros. ansi-tests: psetq.7 psetf.7 34. Cannot create classes whose names are uninterned symbols. ansi-tests: psetf.35 rotatef.35 defclass.forward-ref.4 35. ROTATEF does not work with no arguments. snsi-tests: rotatef.3 36. DEFSETF (long form) should produce an implicit block with the name of the accessor-fn. ansi-tests: defsetf.5a 37. The expansion function produced by DEFSETF (long form) should be defined in the same lexical environment in which the DEFSETF form appears. ansi-tests: defsetf.6a 38. The control error signaled by (throw (gensym) nil) isn't printable when *print-escape* and *print-readably* are nil. ansi-tests: throw-error 39. DOCUMENTATION should be allowed to be called on function objects, not just function names. ansi-tests: define-modify-macro.documentation.1 define-modify-macro.documentation.2 documentation.function.function.[1235] 40. In DEFUN where the function names is a (SETF ) pair, there is an implicit block with name . ansi-tests: defun.4 41. Free special declarations do not apply to the expressions in &aux, &optional or &key forms of an ordinary lambda list. See also bug #49. ansi-tests: defun.5 defun.6 defun.7 42. &WHOLE causes an error during macroexpansion in destructuring-bind. ansi-tests: destructuring-bind.20 43. destructuring-bind fails to destructure in the &rest parameter ansi-tests: destructuring-bind.21 44. The macro function for destructuring-bind (and, I suspect, many other builtin macros) fails to properly signal a program error when called on an invalid number of arguments. ansi-tests: destructuring-bind.error.[789] 45. (FIXED) No hash table with :key EQUALP. ansi-tests: equalp.21 46. (partially FIXED; equalp.35 still fails) EQUALP fails to properly compare hash tables. ansi-tests: equalp.22 to equalp.35 47. (FIXED) The type error signaled by EVERY and related functions has the datum and expected-type slots switched. ansi-tests: every.error.1 notany.error.1 notevery.error.1 some.error.1 48. flet and labels do not accept SETF function names. ansi-tests: flet.17 labels.17 flet.51 labels.26 49. Free special declarations in flet and labels forms do not affect the expressions in the &aux, &optional and &key fields of the ordinary lambda list. See also bug #41. ansi-tests: flet.62 flet.63 flet.67 labels.41 labels.42 labels.46 50. Funcall should throw an undefined function error when called on a symbol that has a macro function binding but not a function binding. ansi-tests: funcall.error.3 51. function-lambda-expression is not defined. ansi-tests: function-lambda-expression.[123] function-lambda-expression.order.1 function-lambda-expression.error.[12] 52. (FIXED) Lambda forms are no longer of type function. ansi-tests: function.6 function.10 functionp.6 functionp.10 53. (FIXED) Symbols are no longer functions. ansi-tests: functionp.2 54. Free special declarations do not apply to the init forms of a LET or LET*. ansi-tests: let.17 let.17a let*.17 let*.17a let*.18 55. &whole not recognized in macro lambda list anso-tests: macrolet.5 macrolet.36 defmacro.7 56. symbol-macros are not showing up in the macro expansion environment ansi-tests: macrolet.13 macrolet.14 57. :allow-other-keys not being properly handled in macros with &key in their macro lambda lists. ansi-tests: macrolet.32 defmacro.21 58. NIL should match anything in a macro lambda lists. ansi-tests: macrolet.39 59, Ordering problem related to presence of symbol macro with side effects in multiple-value-setq. ansi-tests: multiple-value-setq.[58] 60. Free special declarations should not apply to the initialization forms in PROG, PROG* forms. ansi-tests: prog.11 prog*.11 61. (FIXED, partially) DEFINE-COMPILER-MACRO is undefined ansi-tests: documentation.list.compiler-macro.[12] documentation.symbol.compiler-macro.[12] 62. DEFINE-SYMBOL-MACRO is undefined 63. CONSTANTP should take an optional second argument, an environment or nil (and which may be ignored.) ansi-tests: constantp.6 constantp.8 constantp.order.2 64. Free special declarations in a LAMBDA form should not affect the expressions in key, aux, or optional parameters. ansi-tests: lambda.5[234] 65. The second argument to COMPILE is allowed to be a function; not just a lambda expression. ansi-tests: lambda.5[56] 66. COMPILE-FILE is incorrectly executing the code twice i an EVAL-WHEN form with both the :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL keywords. ansi-tests: eval-when.1 67. DEFMACRO is not defining the macro function in the lexical environment in which the DEFMACRO form appears. ansi-tests: defmacro.3 defmacro.4 defmacro.12 defmacro.13 68. (FIXED) (typep nil (find-class 'null)) ==> nil See also bug #81. ansi-tests: the.9 the.10 69. (VALUES &REST ...) not being understood. ansi-tests: the.14 the.15 the.18 the.21 the.22 70. (THE (VALUES ... &OPTIONAL ...) (EVAL '(VALUES ...))) is signaling a spurious error. ansi-tests: the.20 the.23 71. SYMBOL-MACROLET does not admit DECLARE expressions. ansi-tests: symbol-macrolet.3 symbol-macrolet.8 symbol-macrolet.error.1 72. SYMBOL-MACROLET should signal a program error when the symbol is a constant or special variable, but it does not. ansi-tests: symbol-macrolet.error.1 symbol-macrolet.error.2 73. MACRO-FUNCTION should take an optional second argument (that is an environment or NIL), but it does not. ansi-tests: macro-function.[2379] macro-function.1[135] loop-finish.error.1 74. SUBTYPEP problems (ansi-tests: types.3) a. (FIXED) GENERIC-FUNCTION FUNCTION ==> NIL T b. (FIXED) UNBOUND-SLOT CELL-ERROR ==> NIL T (see also unbound-slot-cpl) c. (FIXED) FLOATING-POINT-INVALID-OPERATION ARITHMETIC-ERROR ==> NIL T (see also floating-point-invalid-operation-cpl type-of.5) d. (FIXED) FLOATING-POINT-INEXACT ARITHMETIC-ERROR ==> NIL T (see also floating-point-inexact-cpl type-of.5) e. (FIXED) LOGICAL-PATHNAME PATHNAME ==> NIL T f. (FIXED) PRINT-NOT-READABLE ERROR ==> NIL T (see also print-not-readable-cpl) g. (FIXED) READER-ERROR PARSE-ERROR ==> NIL T (see also reader-error-cpl) h. (FIXED) READER-ERROR STREAM-ERROR ==> NIL T (see also condition.2 for subtype failures on expected subtype relationships of condition types) 75. More SUBTYPEP problems (ansi-tests: types.9a) a. (FIXED) VECTOR SIMPLE-ARRAY ==> T T b. (FIXED) ARRAY SIMPLE-ARRAY ==> T T c. (FIXED) BIT-VECTOR SIMPLE-ARRAY ==> T T d. (FIXED) BIT-VECTOR SIMPLE-BIT-VECTOR ==> T T (counterexample elements were found for all these supposed subtype relationship.) 76. (FIXED) (subtypep 'function 'atom) ==> T T (which is correct), but there are function objects that are not of type atom. The problem is that cons cells are used to represent functions. The problem is tbat lambda expressions are no longer of type FUNCTION in CLtS. (also from ansi-test types.9a, see also universe-elements-in-at-most-one-disjoint-type) 77. (FIXED) Yet more SUBTYPEP problems: (subtypep 'standard-object (find-class 'standard-object)) ==> nil t ansi-tests: all-classes-are-type-equivalent-to-their-names 78. (FIXED) A number of standardized classes are implemented as structure classes (which is allowed) but subtypep is not recognizing them as subtypes of structure-object: synonym-stream, hash-table, broadcast-stream, echo-stream, pathname, concatenated-stream, readtable, function, file-stream, string-stream, stream, package, two-way-stream. ansi-tests: all-structure-classes-are-subtypes-of-structure-object 79. (FIXED) The standardized generic function DOCUMENTATION should be a member of the class GENERIC-FUNCTION. 80. (FIXED, please check) SUBTYPEP is not correctly determining that if a class X is a subclass of classes Y and Z, then X is a subtype of (AND Y Z) (it is allowed to fail to determine the subtype relationship, but if it does it must determine it correctly). ansi-tests: tac-3.16 81. (let ((x (make-condition 'arithmetic-error))) (typep x (class-of x))) ==> NIL More generally, typep isn't working on class object type specifiers. ansi-tests: coerce.3 class-28.[123] class-0201.1 class-0202.1 class-0301.1 class-0309.1 class-0311.1 allocate-instance.[1234] allocate-instance.order.1 change-class.3.[12] update-instance-for-different-class.4 82. (FIXED) In a DEFTYPE lambda list, the default value for missing key or optional parameters should be the symbol *, not NIL. ansi-tests: deftype.11 deftype.12 deftype.18 83. (FIXED) SUBTYPEP is not correctly handling a DEFTYPE that yields the NIL type: (deftype foo () nil) (subtypep '(foo) nil) ==> nil t ansi-tests: deftype.13 84. (FIXED) The body of a DEFTYPE form should be in an implicit block whose name is the name of the type being defined. ansi-tests: deftype.16 85. (FIXED) DEFTYPE forms are not allowing all DECLARE expressions. ansi-tests: deftype.19 86. (partially FIXED) Free special declarations in a DEFTYPE should not apply to the forms in optional or key arguments in the deftype lambda list. ansi-tests: deftype.15 87. (FIXED) The method parameter specifier (X FUNCTION) is not matching the function value #'CONS. ansi-tests: standard-generic-function.[12] 88. Numerous problems with TYPE-OF (ansi-tests: type-of.1 type-of.4) a. (FIXED) TYPE-OF of a nonnegative integer must be a subtype of UNSIGNED-BYTE. b. (FIXED) #\Rubout, #\Tab, #\Backspace, #\Return, and #\Page are BASE-CHARs, and have TYPE-OF ==> STRING-CHAR, but (SUBTYPEP 'STRING-CHAR 'BASE-CHAR) ==> nil t c. (FIXED) TYPE-OF on condition objects returns PCL::STD-INSTANCE, which is not a subtypep of the condition types to which the objects belong. It also isn't a subtype of the class returned by CLASS-OF. d, (FIXED) TYPE-OF on #(nil nil) is VECTOR, but #(nil nil) is a SIMPLE-VECTOR. e. (FIXED) TYPE-OF on a logical pathname returns PATHNAME, which is not a subtype of LOGICAL-PATHNAME. f. (FIXED) TYPE-OF on standard methods returns PCL::STD-INSTANCE, which is not a subtype of METHOD, STANDARD-METHOD, OR STANDARD-OBJECT. It is also not a subtype of (CLASS-OF ). g. (FIXED) TYPE-OF on a compiled closure for a generic function yields COMPILED-FUNCTION, which is not a subtype of GENERIC-FUNCTION, STANDARD-GENERIC-FUNCTION, or STANDARD-OBJECT. It is also not a subtype of (CLASS-OF ). (Note: in f and g, the STANDARD-OBJECT is there because these entities are elements of this type in gcl, although this is not required by the standard. Given that they are elements, the subtype relationship is required by the standard.) 89. (FIXED) TYPE-OF on an instance of a user-defined standard class is PCL::STD-INSTANCE, but it should be the name of the class (or the class itself if it has no name). ansi-tests: type-of.7 type-of.8 type-of.9 (and type-of.10, indirectly) 90. (FIXED) typep should signal an error if the type is a VALUES type. ansi-tests: typep.error.4 typep.error.5 typep.error.6 91. (FIXED) typep should signal an error if the type is a compound function type. ansi-tests: typep.error.7 92. (FIXED) The CPL (class precedence list) tests are failing due to a bug in PCL that also showed up in SBCL and CMUCL. The function starts returning NIL after a few calls. ansi-tests: *-CPL 93. (partially FIXED; prin1.symbol.3 is still failing, but is a different bug) READTABLE-CASE is undefined (and its SETF form) ansi-tests: read-symbol.1[678] read-symbol.25 readtable-case.* set-syntax-from-char-trait-* print.symbol.[123456789] print.symbol.1[012] prin1.symbol.[123] 93a. PRIN1 is not escape the symbol |1| properly when readtabkle-case is set to :UPCASE. ansi-tests: prin1.symbol.3 94. Binding *READ-SUPPRESS* to true doesn't totally suppress reading; reading a list still returns a list, as does reading a vector or pathname. ansi-tests: read-suppress.9 read-suppress.1[01245] read-suppress.sharp-quote.[1235678] read-suppress.sharp-left-paren.[123456789] read-suppress.sharp-left-paren.1[012] read-suppress.sharp-p.[1234567] read-suppress.sharp-equal.4 95. Binding *READ-SUPPRESS* to true causes the reading of complex numbers to abort with a type error. read-suppress.sharp-c.[123456789] read-suppress.sharp-c.1[12345] 96. In read suppressed mode, #r does not read the full token following it, but stops at the # character. ansi-tests: read-suppress.sharp-r.10 97. In read suppressed mode, ## terms are not read correctly ansi-tests: read-suppress.sharp-sharp.[1234] 98. Reading a token starting with a right paren (an invalid character) should signal a READER-ERROR, but it does not. ansi-tests: read-suppress.error.1 syntax.right-paren-error.1 99. Reading #< should signal a reader error. ansi-tests: read-suppress.error.2 set-syntax-from-char.right-paren syntax.sharp-less-than.1 100. Setting the syntax of a character to that of #\" doesn't work. ansi-tests: set-syntax-from-char.double-quote 101. Initially, for a new dispatching macro character, every following character should have the dispatching macro character function that signals a read-error. This is not happening. ansi-tests: make-dispatch-macro-character.3 102. #\Backspace is an invalid character in the standard syntax, and reading it should signal a reader-error. This is not happening. ansi-tests: syntax.backspace.invalid 103. #\Rubout is an invalid character in the standard syntax, and reading it should signal a reader-error. This is not happening. ansi-tests: syntax.rubout.invalid 104. The string "#0()" should read as the simple vector of length 0, but it causes an error. ansi-tests: syntax.sharp-left-paren.2 105. Various malformations of #* syntax should lead to reader errors, but do not. ansi-tests: syntax.sharp-asterisk.error.[123] 106. Binding *read-eval* to nil should cause #. to throw a reader error, but it does not always. ansi-tests: syntax.sharp-dot.error.3 107. #C should tolerate whitespace before the left paren. ansi-tests: syntax.sharp-c.5 108. #+(:and) #+(:or) #+(:not ...) lead to errors in the reader (which is wrong). The problem seems to be that the feature expression is being read in the current package, not the keyword package. ansi-tests: syntax.sharp-plus.5 syntax.sharp-plus.7 syntax.sharp-plus.8 syntax.sharp-plus.12 109. Reading # followed by whitespace[1] should signal a reader-error, but it is not (it is signaling a simple-error that is not a reader-error). ansi-tests: syntax.sharp-whitespace.1 110. Reading # followed by a right parenthesis should signal a reader-error, but it is not (it is signaling a simple-error that is not a reader-error). ansi-tests: syntax.sharp-right-paren.1 111. Reading a rational with zero denominator should signal a reader error. ansi-tests: syntax.number-token.error.1 112. Tokens containing only dots and not being a single dot in a position where a consing dot is expected should cause a reader-error. ansi-tests: syntax.dot-error.[1234567] 113. Reading a comma while not in a backquoted form should signal a reader-error. ansi-tests: syntax.comma-error.[12] 114. Free special declarations in DO, DO* forms should not affect the init forms. ansi-tests: do.16 do*.16 115. NIL is a destructuring pattern that matches anything (and binds nothing) and should be allowed in for-as-arithmetic clauses. ansi-tests: loop.1.5[013456] 116. A while or until clause in a LOOP should be executed at its location, not earlier. ansi-tests: loop.11.29 loop.11.3[01234] 117. Creating a structure whose name is an uninterned symbol causes the class that is created to be unfindable with FIND-CLASS. ansi-tests: struct-test-31/1[3457] struct-test-31/15a 118. The -P predicate created for a structure of type (vector t) causes an error on the string (string (code-char 0)). ansi-tests: struct-test-41/3 struct-test-43/3 119. There should be an initialization argument :format-control for simple-errors and simple-warnigns. ansi-tests: error.[2389] error.1[02] cerror.[23] cerror.2a warn.8 warn.10 warn.19 120. Error should take a formatter (not just a format string) as its first argument. ansi-tests: error.5 error.1 cerror.4a cerror.5 121. The datum slot of the error signaled by a CHECK-TYPE failure is not the value being checked. ansi-tests: check-type.[23567] 122. invoke-debugger is not signaling a program error in safe code when called with an incorrect number of arguments. 123. The ( ) pairs of HANDLER-BIND should accept literal function values as handlers, but uncompiled function objects (which are improperly implemented as CONSes) cause an error. ansi-tests: handler-bind.9 (This is also a problem with function literals occuring in other expressions, but there isn't a test for that in the eval/compile section of ansi-tests.) 124. HANDLER-BIND is not properly handing off a declined condition to a following handler in some cases. ansi-tests: handler-bind.11 125. HANDLER-BIND is not accepting condition class objects as type designators. ansi-tests: handler-bind.17 126. HANDLER-CASE is not accepting condition class objects as type designators. ansi-tests: handler-case.5 127. HANDLER-CASE did not accept a DECLARE expression (by itself) in the body of a handler clause. ansi-tests: handler-case.28 128. Free special declarations in the handler clauses of a HANDLER-CASE are improperly affecting the expressions in &aux variables. ansi-tests: handler-case.29 129. (typep (find-class 'condition)) ==> NIL (typep (find-class ')) ==> NIL ansi-tests: condition-1/is-a-member-of-class/condition and about 30 similar tests 130. compute-restarts is returning a restarts that are not associated with the condition being tested. ansi-tests: compute-restarts.9 131. restart-case with macro, symbols forms not not properly handled: ansi-tests: restart-case.29 restart-case.30 restart-case.31 132. Free special declarations in restart definitions in restart-case do not have the correct scope. ansi-tests: restart-case.36 133. continue, store-value, and use-value functions are invoking restarts that are applicable to other conditions than the argument condition. (Or, with-condition-restarts may not be behaving properly) ansi-tests: continue.2 store-value.2 use-value.2 134. A safe call (make-condition) should signal a program error. ansi-tests: make-condition.error.1 135. Division by zero should be signaling a divide-by-zero condition, not a generic simple error. ansi-tests /.error.[2345678] 136. (/ -1) is returning three values, not just one. ansi-tests: /.2 137. (expt -1 0.0) should be 1.0 (of the appropriate floating type), but the result being returned is #c(1.0 0.0). ansi-tests: expt.18 expt.19 expt.20 expt.21 138. (lcm) should yield 1, not an error. ansi-tests: lcm.1 139. (FIXED) (typep 1 '(real (0))) ==> error (and similarly for (typep 1 '(integer (0))).) ansi-tests: random.error.3 (and others) 140. (phase 0) ==> error (logarithmic singularity) ansi-tests: phase.1 141. (float x) should eql x when x is a float, but short-floats are being converted to single-floats (eql (float 1.0s0) 1.0s0) ==> NIL ansi-tests: float.5 142. rational and rationalize should signal type errors on arguments that are not of type real in safe code. ansi-tests: rational.error.4 rationalize.error.4 143. Apparent compiler problem in this function: (defun digit-char.1.body.old () (loop for r from 2 to 36 always (loop for i from 0 to 36 always (let* ((c (digit-char i r)) (result (if (>= i r) (null c) (eqlt c (char +extended-digit-chars+ i))))) (unless result (format t "~A ~A ~A~%" r i c)) result)))) When called, it prints 2 2 p and returns nil. However, (digit-char 2 2) ==> nil when called at the REPL. (this is from digit-char.1, but that test has been changed.) 144. digit-char should take at most two arguments, but it is failing to signal a program error in safe code when given more. ansi-tests: digit-char.error.2 145. standard-char-p should signal a type error in safe code when called on a non-character. ansi-tests: standard-char-p.3 146. code-char should signal an error in safe code when called with more than one argument. ansi-tests: code-char.error.2 147. adjust-array does not have the correct semantics when performed on the middle of a chain of three displaced bit vectors. The chain appears to have been improperly short-circuited. ansi-tests: adjust-array.bit-vector.adjustable.13 148. fill-pointer should signal a type error when called with vectors that lack fill pointers. It does, but the expected-type field is wrong. ansi-tests: fill-pointer.error.[36] 149. (FIXED) The value (upgraded-array-element-type 'base-char) should be type-equivalent to base-char. However, it is string-char, and (subtypep 'string-char 'base-char) ==> nil t ansi-tests: upgraded-array-element-type.2 150. (FIXED) upgraded-array-element-type violates the 'preserves subtype' properties for numerous types. For example: (upgraded-array-element-type '(eql 2)) ==> lisp:signed-char but (upgraded-array-element-type '(unsigned-byte 16)) ==> lisp:unsigned-short ansi-tests: upgraded-array-element-type.8 151. (FIXED) (upgraded-array-element-type nil) ==> t, but it should be nil. 152. vector-pop should signal a type-error when passed a vector that lacks a fill pointer. It does, but the expected-type slot is wrong. ansi-tests: vector-pop.error.[15] 153. (make-hash-table :size 0) signals an error, but 0 is a legal value for the size parameter. ansi-tests: make-hash-table.2 154. equalp hash tables are not supported. ansi-tests: make-hash-table.1[01] hash-table-count.[59] hash-table-rehash-threshold.[23] hash-table-test.[234] gethash.zero.4 remhash.4 clrhash.4 maphash.[36] with-hash-table-iterator.7 155. (make-hash-table :rehash-threshold x) errors: a. x == 0 (or 0.0s0, or 0.0) signals an error, but zero is a legal value for this parameter. ansi-tests: make-hash-table.1[6789] make-hash-table.20 b. x == 1/2 signals an error, but this is a legal value for this parameter. ansi-tests: make-hash-table.21 156. The third argument to GETHASH in the SETF form should be allowed, but instead is causing an error. ansi-tests: gethash.5 gethash.order.4 157. The last invocation of the local macro in WITH-HASH-TABLE-ITERATOR should return just a single value, NIL, but it is returning three values. ansi-tests: with-hash-table-iterator.4 158. PATHNAME, when called on a stream, should return the pathname that was used to create the stream. However, for logical pathnames, this is not happening -- the physical pathname corresponding to the logical pathname is returned instead. ansi-tests: logical-pathname.3 159. ensure-directories-exist should signal a file-error if part of the directory is wild, but it does not. ansi-tests: ensure-directories-exist.error.1 160. stream-element-type is returning :default on a stream opened with OPEN. This violates the constraint that this type must be a subtype of integer or character. ansi-tests: stream-element-type.6 161. Cannot write (1- (ash 1 32)) to a stream with :element-type (unsigned-byte 32) using write-byte. ansi-tests: read-byte.3 read-byte.4 file-length.[2345] 162. peek-char advances the file position of echo streams. ansi-tests: peek-char.17 163 Passing NIL to the :start argument of read-sequence or write-sequence is treated as if the parameter were not present. This is incorrect: :start, if provided, must be a nonnegative integer, and should signal a type error in safe calls otherwise.. ansi-tests: read-sequence.error.9 write-sequence.error.15 164. file-string-length is computing the wrong thing. It should compute the change in file position after an object is printed as a sequence of characters, not as printed in readable representation. #\a, for example, should occupy one position, not three. ansi-tests: file-string-length.[12] 165. Free declarations in with-open-file forms should not have the return value form in their scope. ansi-tests: with-open-file.[789] 166. open-stream-p reports that a string-stream (input or output) is still open, even after it has been closed. ansi-tests: with-open-stream.[6789] 167. Free declarations in a with-open-stream form are incorrectly being applied to the return value form. ansi-tests: with-open-stream.10 168. (typep (make-broadcast-stream) 'broadcast-stream) ==> nil (and related). ansi-tests: make-broadcast-stream.[123] 169. file-position should return 0 on null broadcast streams. ansi-tests: make-broadcast-stream.6 170. file-string-length should return 1 on null broadcast streams. ansi-tests: make-broadcast-stream.7 171. make-broadcast-stream should signal a type error in safe calls when an argument is not an output stream. ansi-tests: make-broadcast-stream.error.[12] 172. open-stream-p returns T on a two-way-stream, echo-stream, or concatenated-stream that has been closed. ansi-tests: make-two-way-stream.2 make-echo-stream.10 make-concatenated-stream.27 173. make-two-way-stream should signal a type error if the output stream argument is not an output stream. It does so, but the expected-type slot is wrong. ansi-tests: make-two-way-stream.error.[67] 174. (open-stream-p (make-concatenated-stream)) ==> nil ansi-tests: make-concatenated-stream.7 175. READ-CHAR-NO-HANG is encountering a premature EOF in a concatenated stream. It looks like it is only reading from the first of the input streams. ansi-tests: make-concatenated-stream.16 176. LISTEN fails to look at the second input stream to a concatenated stream. ansi-tests: make-concatenated-stream.30 177. make-string-output-stream should take a keyword argument, :element-type. ansi-tests: make-string-output-stream.[235679] make-string-output-stream.1[01] 178. Free declarations in with-input-from-string should not apply to the return value form, or the start or end arguments. ansi-tests: with-input-from-string.19 with-input-from-string.2[012] 179. The index place argument of with-input-from-string should be updated only if the form terminates normally. ansi-tests: with-input-from-string.22 180. with-output-to-string should take an :element-type argument. ansi-tests: with-output-to-string.[78] with-output-to-string.1[46] 181. Free special declarations in with-output-to-string should not apply to the return value form. ansi-tests: with-output-to-string.15 182. Calling make-instance with an initialization argument for a shared slot does not properly initialize that shared slot. ansi-tests: class-13.1 183. Violations of the rules for default initargs. ansi-tests: class-20.[123] class-21.[1245] 184. documentation doesn't work on class objects. ansi-tests: class-23.[34] documentation.standard-class.t.1 documenation.struct-class.t.1 185. :ALLOW-OTHER-KEYS in the :DEFAULT-INITARGS specifier of a class definition should allow other arguments to be passed in the initializer list to make-instance. However, this is not happening. ansi-tests: class-24.2 186. slot-makunbound should return the instance. It is instead returning nil. ansi-tests: class-0203.[12] slot-missing.3 187. slot-makunbound throws an error incorrectly: > (defclass example-class () ((a :allocation :instance) (b :allocation :class))) # > (let ((c1 (make-instance 'example-class))) (slot-makunbound c1 'a)) Error in LET [or a callee]: What kind of instance is this? ansi-tests: class-0206.1 class-0207.1 class-redefinition.2 update-instance-for-different-class.[123] slot-boundp.5 slot-makunbound.[12] slot-makunbound.error.[12] 188. (FIXED) T is an illegal documentation type. ansi-tests: class-0221.[123] defgeneric.2 documentation.function.t.[123456789] documentation.function.t.[56]a documentation.function.t.1[012] documentation.function.function.[48] documentation.standard-method.t.1 documentation.package.t.1 documentation.new-method.1 189. If the name of a class is changed to NIL, and another class of the same original name is then defined, the original class should not be redefined; instead, there should be two classes. Zee section 4.3.1 for the notion of 'proper name', and see also bug #190 below. ansi-tests: class-0309.1 190. Similar to 189, but if FIND-CLASS for a given name is changed. ansi-tests: class-0310.1 191. defclass should allow forward referencing of superclasses, but doesn't. Attempting to include the name of a class that hasn't yet been defined in the superclass list causes an error. ansi-tests: defclass.forward-ref.[123] 192. ensure-generic-function should take a method class object as its :method-class argument. ansi-tests: ensure-generic-function.9 193. ensure-generic-function should take the :declare keyword argument, but it does not (this was a source of some confusion in other lisps, and may be a spec bug.) ansi-tests: ensure-generic-function.13 194. allocate-instance should work on structure classes. ansi-tests: allocate-instance.5 195. allocate-instance should signal a program-error when called with too few arguments in safe code. ansi-tests: allocate-instance.error.1 196. change-class isn't allowing the :allow-other-keys keyword argument. ansi-tests: change-class.1.7 change-class.7.5 197. When SLOT-MISSING is called when attempting to write to a missing slot, any of its return values should be ignored. However, they are being returned by the setf function. ansi-tests: slot-missing.[267] 198. When slot-boundp is invoked on a missing slot, only a value equivalent (in the boolean sense) to the primary value of slot-missing should be returned, not any other values. ansi-tests: slot-missing.8 199. If slot-value is called on an unbound slot, and the applicable slot-unbound method returns no values, then slot-value should return the primary value, which is NIL. However, it is returning no values at all. Similarly, if the method returns more than one value, slot-value should return only the first ansi-tests: slot-unbound.[3456] 200. The function method-qualifiers should throw a progra-error when called with other than one argument in safe code. ansi-tests: method-qualifiers.error.[12] 201. remove-method must not signal an error if the method does not belong to the generic function. ansi-tests: remove-method.1 202. (FIXED) MAKE-LOAD-FORM should have default methods (that signal errors) when invoked on standard objects, structure objects, or conditions. ansi-tests: make-load-form.[456789] make-load-form.1[012] 203. MAKE-LOAD-FORM should signal a program error when invoked with too many arguments. ansi-tests: make-load-form.error.2 204. WITH-ACCESSORS forms should allow the presence of DECLARE expressions. ansi-tests: with-accessors.1[01] 205. WITH-SLOTS forms should allow the presence of DECLARE expressions. ansi-tests: with-slots.19 with-slots.20 206. DEFGENERIC should signal a program=error if a required argument occurs more than once in the argument-precedence-order list, or if a required argument is missing in the argument-precedence-order list. ansi-tests: defgeneric.error.[48] 207. If a generic function is passed a keyword argument that is not accepted by any applicable method, an error should be signalled. See CLtS 7.6.5. ansi-tests: defgeneric.error.2[01] 208. When an existing generic function is redefined using DEFMETHOD, any preexisting methods that were defined using the :methods option of DEFGENERIC should be removed. See also paragraph 4 of the description of ENSURE-GENERIC-FUNCTION. ansi-tests: defgeneric.3[12] 209. The method declarations in DEFGENERIC forms should admit DECLARE expressions. ansi-tests: defgeneric.35 210. Neither rebinding nor using SETQ (& related operators) should alter the arguments passed by CALL-NEXT-METHOD. ansi-tests: call-next-method.8 211. "When providing arguments to call-next-method, the following rule must be satisfied or an error of type error should be signaled: the ordered set of applicable methods for a changed set of arguments for call-next-method must be the same as the ordered set of applicable methods for the original arguments to the generic function." ansi-tests: call-next-method.error.[12] 212. COMPUTE-APPLICABLE-METHODS should signal a program-error when called with too many or too few arguments in safe code. ansi-tests: compute-applicable-methods.error.1 213. FIND-METHOD should signal a program-error when called with too few or too many arguments. ansi-tests: find-method.error.[1234] 214. FIND-METHOD should signal an error if the length of the specializers list does not equal the number of required arguments to the generic function ansi-tests: find-method.error.[789] find-method.error.10 215. ADD-METHOD should signal a program-error when called with too few or too many arguments in safe code. ansi-tests: add-method.error.[456] 216. ADD-METHOD should return the generic function. ansi-tests: add-method.[12] 217. Computing SLOT-VALUE on a missing slot should throw an UNBOUND-SLOT error. ansi-tests: unbound-slot.[12] 218. A generic function should throw a program-error if called with too few or too many arguments in safe code. ansi-tests: defmethod.error.1[34] 219. A generic function should throw a program-error when called with invalid keyword arguments in safe code. ansi-tests :defmethod.error.15 220. Double floats are not printed readably correctly. Round-off error is apparently occuring, causing the re-read value to differ slightly. ansi-tests: print.double-float.random print.long-float.random 221. #\Space should print (under PRIN1) as #\ , not #\Space. ansi-tests: print.char.4 print.char.10 222. Escaped haracter printing violates therules in 2.4.8.1 ansi-tests: print.char.7 223. (code-char 28) doesn't print or possibly read correctly ansi-tests: print.char.[89] 224. A symbol whose symbol-package is a deleted package should be printed as if it had no home package. ansi-tests: print.symbol.prefix.8 225. Component printing controlled by *print-level* should not print # for an object unless that object 'has components'. I interpret this to mean objects that are printed by recursive calls to the object printer, and that can be targets of #n# syntax, so cons cells, T vectors, structures, etc. have components, but not numbers, symbols. strings, or bit vectors. ansi-tests: print.cons.level.[25] print.vector.level.[34] pprint.1 print-level.[4589] 226. Arrays of dimension > 1 that have total size > 0 and one ore more dimensions of size 0 do not print readably. ansi-tests: print.array.2.2[123] 227. The 'is-similar*' generic function is not dispatching properly. In particular, the correct method is apparently not being invoked on pathnames. ansi-tests: print.pathname.1 228. PPRINT-FILL should signal a program-error when called with the wrong number of arguments in safe code. ansi-tests: pprint-fill.error.[123] 229. PPRINT-LINEAR should signal a program-error when called with the wrong number of arguments in safe code. ansi-tests: ppprint-linear.error.[123] 230. PPRINT-TABULAR should use WRITE to print an object when it is a non-list. ansi-tests: pprint-tabular.[12] 231. The default tabsize for PPRINT-TABULAR is 16, but it is instead using ordinary tab characters. ansi-tests: pprint-tabular.[6789] pprint-tabular.1[0123456789] pprint-tabular.2[01234] 232. PPRINT-TABULAR fails to break the list across lines if it would otherwise exceed *PRINT-RIGHT-MARGIN*. ansi-tests: pprint-tabular.2[12] 233. PPRINT-TABULAR should signal a program-error when called with the incorrect number of arguments in safe code. ansi-tests: pprint-tabular.error.[1234] 234. PPRINT-LOGICAL-BLOCK does not always properly print the #n# notation when *print-circle* is true. ansi-tests: pprint-logical-block.17 235. The local macro PPRINT-EXIT-IF-LIST-EXHAUSTED isn't being defined inside PPRINT-LOGICAL-BLOCK forms. ansi-tests: pprint-exit-if-list-exhausted.[1234] 236. The local macro PPRINT-POP isn't being defined inside PPRINT-LOGICAL-BLOCK forms. ansi-tests: pprint-pop.[123456789] 237. PRINT-UNREADABLE-OBJECT, when :TYPE is T, is specified to print a space after the type even if nothing else is printed before the closing >. This is not happening. (Arguably this is a spec bug.) Similarly, it is specified to print a space before the 'identity' inforamtion. ansi-tests: print-unreadable-object.[23] 238. PRINT-UNREADABLE-OBJECT should signal an error of type PRINT-NOT-READABLE if *PRINT-READABLY* is true, but it is not doing this. ansi-tests: print-unreadable-object.error.1 239. PRINT appears to ignore the *PRINT-READABLY* control variable, as does PRIN1. ansi-tests: print.1 prin1.1 240. *PRINT-LEVEL* can be legally bound to any nonnegative integer, but an error occurs when it is bound to a bignum. ansi-tests: print-level.12 241. *PRINT-LENGTH* can be legally bound to any nonnegative integer, but an error occurs when it is bound to a bignum. ansi-tests: print-length.7 242. Structures should be printed with their slot names given as keyword symbols. ansi-tests: print-length.11 243. The format directive ~c should print #\Newline, #\Space, and many other characters as the single characters, not as their names, ansi-tests: format.c.1 format.c.1a format.r.15 format.d.5 format.d.11 format.b.5 format.b.11 format.o.5 format.o.11 format.x.5 format.x.11 format.justify.10 244. The ~:c format directive should print the name of simple, non-graphic characters. ansi-tests: format.c.4a 245. The ~@c format directive should print characters in a readable format, but this fails on the character with code 28. ansi-tests: format.c.5a 246. The function produced by the FORMATTER macro should return the list of unconsumed arguments. ansi-tests: many formatter tests 247. When the v format parameter of the R format directive gets 'nil', it is to be treated as if it were not there, which means ~r should print an english number. It isn't doing this. ansi-tests: format.r.8 248. Specifying a very large negative format parameter for ~r (and others) causes the error 'Can't extend the string.'. ansi-tests: format.r.38 format.d.28 format.b.28 format.o.28 format.x.28 249. ~d is supposed to do the same thing as ~a when called on a non-integer, but for several kinds of values it doesn't. ansi-tests: format.d.1[89] format.d.2[01] 250. The format directive "~vd" fails when the v parameter is a negative bignum, and similarly for other numeric directives (b, etc.) ansi-tests: format.d.29 format.b.29 format.o.29 format.x.29 251. The ~_ format directive is not implemented. ansi-tests: All format.*_* tests format.logical-block.1[789] format.logical-block.2[14 252. In the ~<...~:> format directive (logical block), 'An error is signaled if either the prefix or suffix fails to be a constant string or if the enclosed portion is divided into more than three segments.' ansi-tests: format.logical-block.error.[123456789] format.logical-block.error.1[0123456789] format.logical-block.error.2[01234] 253. 'An error is signaled if any of these directives[~< ... ~:>] is nested within ~<...~>." ansi-tests: format.logical-block.error.25 254. 'An error is also signaled if the ~<...~:;...~> form of ~<...~> is used in the same format string with [...] ~<...~:> [...].' ansi-tests: format.logical-block.error.2[67] 255. ~< ,,, ~:> should consume the next argument and use it (as a list) to supply the arguments used by the directives inside the form. ansi-tests: format.logical-block.[1679] format.logical-block.1[0345] 256. The : modified to ~<...~:> should cause the prefix and suffix strings, if missing, to be "(" and ")", respectively. ansi-tests: format.logical-block.[45] format.logical-block.2[0236] format.logical-block.escape.[12] 257. If ~:@> terminates a ~< construct, then it should be the case that 'a fill-style conditional newline is automatically inserted after each group of blanks immediately contained in the body (except for blanks after a directive).' This is not happening. ansi-tests: format.logical-block.2[25] 258. ~@; in ~<...~:> construct isn't setting the per-line-prefix properly. ansi-tests: format.logical-block.2[789] 259. The ~i directive hasn't been implemented. ansi-tests: format.i.[123456789] format.i.1[0123456] 260. The ~/.../ directive hasn't been implemented. ansi-tests: format./.[123456789] format./.1[123456789] 261. Various ~T failures, all similar ansi-tests: format.t.[348] 262. ~:T and ~:@T aren't implemented. ansi-tests: format.:t,[123456789] format.:t1[012] format.:@t.[12345] format.:@t1[abcd] 263. Two ~<...~> failures (undiagnosed) ansi-tests: format.justify.8 format.justify.29 264. Condition (~{ ~}) format directive isn't accepting bignums. ansi-tests: format.cond.[46] format.cond:.[46] 265. Conditional format directive with a prefix argument selects the wrong clause if the prefix is a bignum. ansi-tests: format.cond.12 266. A NIL ~v prefix to [ does not work correctly. ansi-tests: format.cond.14 format.cond:.7 267. The format directive ~{~} should take the next argument as a format control to be used in the iteration. This is not happening. ansi-tests: format.{.1a format.{.1b format.{.1[569] format.{.2[0123] format.:{.[3456] format.@{.1[23] format.:@{.[45] 268. The ~{ ... ~} directive should be prepared to signal an error of type type-error if the argument is not a list. ansi-tests: format.{.error.5 format.:@{.error.5 269. ~^ should take format parameters that are bignums, and other format parameter problems with that format directive. ansi-tests: format.^.(.1[89] format.^.{.2[056789] format.^.{.3[0123] format.^.:{.[67] format.^.:{.1[013456] format.^.:{.3[89] format.^.@{.19 format.^.@{.2056789] format.^.@{.3[0123] format.^.:@{.[67] format.^.:@{.1[01456] format.^.:@{.3[89] 270. Large numbers of undiagnosed failures in ~:^ in various forms of the iteration directives. ansi-tests: format.:^.* 271. LOAD should be able to load directly from a stream. ansi-tests: load.[38] load.1[356] load.1[56]a 272. The information printed by LOAD when verbose is true should be on lines starting with semicolons. ansi-tests: load.[56] 273. LOAD should simply return nil if an attempt to load a nonexistent file is made when the :if-does-not-exist keyword argument is nil. ansi-tests: load.14 274. LOAD should bind *LOAD-PATHNAME* to be the pathname of the file being loaded, merged against the defaults. However, this variable is being bound to the pathname's name (a string), not a pathname. ansi-tests: load.18 275. LOAD should signal a FILE-ERROR when trying to load a nonexistent file (unless the if-does-not-exist parameter is false). It is throwing a simple-error instead. ansi-tests: load.error.1 276. The describe tests crash gcl when run with rt::*catch-errors* bound to nil. ansi-tests: describe.[12345] 277. DISASSEMBLE should signal a program-error on safe calls with more than one argument. ansi-tests: disassemble.error.2 278. TRACE ism't working on extended function names like (SETF ...). ansi-tests: trace.[68 279. TRACE isn't working properly on generic functions. An error is being signaled if a method is added to a generic function that is being traced. ansi-tests: trace.1[34] 280. GET-UNIVERSAL-TIME should signal a program-error in safe calls with more than zero arguments. ansi-tests: get-universal-time.error.[12] 281. GET-INTERNAL-REAL-TIME should signal a program-error in safe calls with more than zero arguments. ansi-tests: get-interal-real-time.error.[12] 282. GET-INTERNAL-RUN-TIME should return a single integer, but it is returning two values. ansi-tests: get-internal-run-time.1 283. DOCUMENTATION fails on (SETF ...) function names with documentation type FUNCTION. ansi-tests: documentation.list.function.[12] 284. DOCUMENTATION fails on symbol, 'type arguments. ansi-tests: documentation.symnol.type.1 285. DRIBBLE should signal a program-error if called with more than one argument in safe code. ansi-tests: dribble.error.1 286. Compiling a call to a function whose name is an uninterned symbol doesn't work. (let* ((sym (gensym)) (fun-def `(defun ,sym () nil))) (eval fun-def) (funcall (compile nil `(lambda () (,sym))))) Error in COMPILER::CMP-ANON [or a callee]: FUNCTION is not of type #:G1832. 287. DO-ALL-SYMBOLS should return when a RETURN is executed in its body. However, it is just skipping the package currently being traversed, since the macro is implemented as two nested loops and each has its own implicit NIL block. ansi-tests: do-all-symbols.12 gcl27-2.7.0/COPYING.LIB-2.0000077500000000000000000000612611454061450500144100ustar00rootroot00000000000000 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! gcl27-2.7.0/ChangeLog000077500000000000000000003551521454061450500142320ustar00rootroot000000000000002006-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 absence 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 absence 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. gcl27-2.7.0/ChangeLog.old000077500000000000000000000161141454061450500147770ustar00rootroot000000000000002001-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 absence 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' gcl27-2.7.0/README.macosx000066400000000000000000000004401454061450500146110ustar00rootroot00000000000000On 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. gcl27-2.7.0/README.openbsd000066400000000000000000000022711454061450500147550ustar00rootroot00000000000000Building 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 gcl27-2.7.0/README.wine000066400000000000000000000005331454061450500142640ustar00rootroot00000000000000On 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 gcl27-2.7.0/RELEASE-2.5.1000066400000000000000000000124251454061450500141120ustar00rootroot00000000000000RELEASE 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 gcl27-2.7.0/RELEASE-2.6.2.html000066400000000000000000001632551454061450500150670ustar00rootroot00000000000000 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. 







gcl27-2.7.0/add-defs000077500000000000000000000077741454061450500140560ustar00rootroot00000000000000#!/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 gcl27-2.7.0/add-defs.bat000077500000000000000000000031571454061450500146120ustar00rootroot00000000000000@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 gcl27-2.7.0/add-defs1000077500000000000000000000042301454061450500141170ustar00rootroot00000000000000#!/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 gcl27-2.7.0/ansi-tests/000077500000000000000000000000001454061450500145345ustar00rootroot00000000000000gcl27-2.7.0/ansi-tests/.cvsignore000066400000000000000000000000571454061450500165360ustar00rootroot00000000000000*.fn *.x86f *.fasl *.ufsl *.dfsl *.pfsl binary gcl27-2.7.0/ansi-tests/ISSUES000066400000000000000000000022021454061450500154660ustar00rootroot00000000000000This file contains notes on problems in the ANSI CL spec found during the construction of the tests. 1. When building a composite stream, what happens when the component streams have different element types? 2. Should there be an UPGRADED-STREAM-ELEMENT-TYPE function. 3. The spec requires that arrays specialized to type NIL exist. Was this intended? 4. If NIL specialized arrays exist, then NIL vectors are also strings. Was this intended? 5. The spec requires that (UPGRADED-COMPLEX-PART-TYPE NIL) be (type equivalent to) NIL. 6. The definition of UPGRADED-COMPLEX-PART-TYPE appears to require that it work on arbitrary typespecs, including SATISFIES, which is not possible. 7. Was it intended that values of 'smaller' float types be coercible to values of larger float types? In CLISP, short-float has a larger range of exponents than single-float, so some shorts cannot be coerced to singles without over/underflow. 8. IMAGPART is defined as returning (* 0 number) on reals. If the implementation supports negative zero and number is a negative float, this will be -0.0 (of the appropriate type). Was this intended? gcl27-2.7.0/ansi-tests/README000066400000000000000000000027601454061450500154210ustar00rootroot00000000000000This directory contains a partial Common Lisp standards compliance test suite. To run the tests, load doit.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 '). Tests can be invoked from the makefile setting the enviroment variable LISP to the lisp executable to be tested, then invoking make test Run tests with test bodies EVALed. make test-compiled Run tests with test bodies compiled before being EVALed. Please tell me when you find incorrect test cases. Paul Dietz dietz@dls.net -------------------------------- (30 Jun 2003) I've decided to add metainformation to the tests, in the form of : pairs after DEFTEST. Also, I've added a DEFNOTE form to define note objects whose names can be attached to properties of tests, to enable selective disabling of classes of tests. The file doit.lsp disables some contentious tests under certain implementations using the note mechanism. If any implementor wishes that some of these tests be inhibited in their implementation, please contact me and I will add code to do so. -------------------------------- NOTE!!! This test suite is not intended to rank Common Lisp implementations. The tests have not be selected to reflect the importance or relative frequency of different CL features. Implementations may even have extended the CL standard (arguably a good thing) in a way that causes certain tests to fail. gcl27-2.7.0/ansi-tests/TODO000066400000000000000000000104261454061450500152270ustar00rootroot00000000000000Things to do to the test suite (not a complete list) 1. subtypep and typep on complex types 2. Refactor random type/element-of-type code. There's too much duplication. 3. More type tests on array types 4. Extend random subtypep tester to array types. (complex types already added, but should extend generator of random real types) 5. Add JA's long form define-method-combination tests (from clisp), or write own (partially done) 6. adjust-array (need to add specialized integer arrays other than bit vectors, and float vectors) 7. Address synonym-stream issues (from Duane Rettig) 8. accuracy tests for numeric functions 9. Test that the streams operators that manipulate files do the right things with *default-pathname-defaults*. 10. Two-arg tests of FILE-POSITION on binary streams. 11. Address issues with broadcast streams (C. Rhodes) -- apparent contradictions in the spec. 17. Tests that have an argument that provides a return value for special conditions (like eof) that happens to be the same as a normal value the functions would return (suggested by CR). 18. Add random tests for COERCE (the result either is either typep of the second arg (except for rational stuff) or a type-error is signalled.) 19. Add two missing tests from CLOS (spotted by Bruno Haible): ;; Shared slot remains shared. ;; CLHS 4.3.6.: "The value of a slot that is specified as shared both in the old ;; class and in the new class is retained." (multiple-value-bind (value condition) (ignore-errors (defclass foo74 () ((size :initarg :size :initform 1 :allocation :class))) (setq i (make-instance 'foo74)) (defclass foo74 () ((size :initarg :size :initform 2 :allocation :class) (other))) (slot-value i 'size)) (list value (type-of condition))) Expected: (1 NULL) Got: (2 NULL) (progn (defclass foo92b (foo92a) ((s :initarg :s))) (defclass foo92a () ()) (let ((x (make-instance 'foo92b :s 5)) (update-counter 0)) (defclass foo92b (foo92a) ((s) (s1) (s2))) ; still subclass of foo92a (slot-value x 's) (defmethod update-instance-for-redefined-class ((object foo92b) added-slots discarded-slots property-list &rest initargs) (incf update-counter)) (make-instances-obsolete 'foo92a) (slot-value x 's) update-counter)) Expected: 1 Got: 0 21. The random tester showed (SETF AREF) wasn't being tested enough. Add tests. 22. Add more symbol printing tests. In particular, there doesn't appear to be a test that (princ :foo) >> :FOO (noticed by PG in ABCL) 23. Modify rt so that when failing tests are reported, they are grouped by :notes and the :notes comment is printed out. This will help explain what the failures mean. 28. Add tests for reading/printing with packages with weird names (lower case letters, digits, etc.) 30. Add more pathname equality tests to equal.lsp 34. (from C Rhodes) Test that CERROR allows additional arguments after a condition designating itself to be used in the continue format control. 36. Add tests for bad default-initargs in object constructors. 37. Add tests that methods on initialize-instance and shared-initialize receive defaulted initargs from compiled make-instance 38, Floating point tests must be expanded. -- Add tests for the floating point inspection functions (decode-float, etc.) -- Add tests of -0.0 vs. 0.0 consistency (a bug here affected abcl) -- transcendantal functions 39. There are various constraints that things defined at the top level become available at compile time. Test these constraints. 40, Check that OPEN, etc. do pathname merging. 41. Add tests for MOD, REM 42. Add randomized tests for BIT-* functions (requested by piso on #lisp) (partially done; tests on simple bit vectors going to a new bit vector have been added; should add in-place versions and operations on non-simple bit-vectors and non-vector arrays) 43. Add tests for structs that defining subtypes using :include doesn't change the parent type(s). (This came up in ABCL.) 44. Add tests for SPECIAL declarations in MACROLET (requested by piso on #lisp) (partially done) 45. Sweep files for missing order-of-execution tests 46. Add tests that class objects are valid class specifiers in method definitions. 47. Test that :import-from in DEFPACKAGE can take a package object. gcl27-2.7.0/ansi-tests/abort.lsp000066400000000000000000000021351454061450500163640ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 23 08:25:50 2003 ;;;; Contains: Tests of the ABORT restart and function (in-package :cl-test) (deftest abort.1 (restart-case (progn (abort) 'bad) (abort () 'good)) good) (deftest abort.2 (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 (list (first (compute-restarts))) (abort c2)) (abort () 'bad) (abort () 'good))) good) (deftest abort.3 (restart-case (progn (abort nil) 'bad) (abort () 'good)) good) (deftest abort.4 (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 (list (first (compute-restarts))) (abort nil)) (abort () 'good) (abort () 'bad))) good) (deftest abort.5 (signals-error (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (with-condition-restarts c1 (compute-restarts) ;; All conditions are now associated with c1 (abort c2))) control-error) t) gcl27-2.7.0/ansi-tests/abs.lsp000066400000000000000000000066371454061450500160350ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Sep 1 20:16:42 2003 ;;;; Contains: Tests of ABS (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (deftest abs.error.1 (signals-error (abs) program-error) t) (deftest abs.error.2 (signals-error (abs 0 0) program-error) t) (deftest abs.error.3 (signals-error (abs 0 nil nil) program-error) t) (deftest abs.1 (loop for x in *numbers* for a = (abs x) always (and (realp a) (not (minusp a)))) t) (deftest abs.2 (loop for x = (random-fixnum) for a = (abs x) repeat 10000 unless (if (plusp x) (eql x a) (eql (- x) a)) collect (list x a)) nil) (deftest abs.3 (let ((bound (ash 1 300))) (loop for x = (random-from-interval bound) for a = (abs x) repeat 10000 unless (if (plusp x) (eql x a) (eql (- x) a)) collect (list x a))) nil) (deftest abs.4 (loop for num = (random-fixnum) for den = (random-fixnum) for den2 = (if (zerop den) 1 den) for r = (/ num den) for a = (abs r) repeat 10000 unless (if (>= r 0) (eql r a) (eql (- r) a)) collect (list num den2 r a)) nil) (deftest abs.5 (let ((bound (ash 1 210))) (loop for num = (random-from-interval bound) for den = (random-from-interval bound) for den2 = (if (zerop den) 1 den) for r = (/ num den) for a = (abs r) repeat 10000 unless (if (>= r 0) (eql r a) (eql (- r) a)) collect (list num den2 r a))) nil) (deftest abs.6 (let ((bound (float (ash 1 11) 1.0s0))) (loop for x = (random-from-interval bound) for a = (abs x) repeat 10000 unless (if (minusp x) (eql (- x) a) (eql x a)) collect (list x a))) nil) (deftest abs.7 (let ((bound (float (ash 1 22) 1.0f0))) (loop for x = (random-from-interval bound) for a = (abs x) repeat 10000 unless (if (minusp x) (eql (- x) a) (eql x a)) collect (list x a))) nil) (deftest abs.8 (let ((bound (float (ash 1 48) 1.0d0))) (loop for x = (random-from-interval bound) for a = (abs x) repeat 10000 unless (if (minusp x) (eql (- x) a) (eql x a)) collect (list x a))) nil) (deftest abs.9 (let ((bound (float (ash 1 48) 1.0l0))) (loop for x = (random-from-interval bound) for a = (abs x) repeat 10000 unless (if (minusp x) (eql (- x) a) (eql x a)) collect (list x a))) nil) ;;; The example on the abs page says that (abs -0.0) should be -0,0. ;;; However, FABS on the x86 returns 0.0 for that. Since the examples ;;; in the hyperspec are not normative, the following four tests ;;; have been commented out. ;;; (deftest abs.10 ;;; (abs -0.0s0) ;;; -0.0s0) ;;; ;;; (deftest abs.11 ;;; (abs -0.0f0) ;;; -0.0f0) ;;; ;;; (deftest abs.12 ;;; (abs -0.0d0) ;;; -0.0d0) ;;; ;;; (deftest abs.13 ;;; (abs -0.0l0) ;;; -0.0l0) ;;; Complex numbers (deftest abs.14 (let ((result (abs #c(3 4)))) (=t result 5)) t) (deftest abs.15 (let ((result (abs #c(-3 4)))) (=t result 5)) t) (deftest abs.16 (let ((result (abs #c(3 -4)))) (=t result 5)) t) (deftest abs.17 (let ((result (abs #c(-3 -4)))) (=t result 5)) t) (deftest abs.18 (abs #c(3.0s0 4.0s0)) 5.0s0) (deftest abs.19 (abs #c(3.0f0 -4.0f0)) 5.0f0) (deftest abs.20 (abs #c(-3.0d0 4.0d0)) 5.0d0) (deftest abs.21 (abs #c(-3.0l0 4.0l0)) 5.0l0) (deftest abs.22 (macrolet ((%m (z) z)) (abs (expand-in-current-env (%m -4)))) 4) gcl27-2.7.0/ansi-tests/acons.lsp000066400000000000000000000032671454061450500163670ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:26:48 2003 ;;;; Contains: Tests of ACONS (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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.7 (macrolet ((%m (z) z)) (acons (expand-in-current-env (%m 'a)) 'b '(c))) ((a . b) c)) (deftest acons.8 (macrolet ((%m (z) z)) (acons 'a (expand-in-current-env (%m 'b)) '(c))) ((a . b) c)) (deftest acons.9 (macrolet ((%m (z) z)) (acons 'a 'b (expand-in-current-env (%m '(c))))) ((a . b) c)) (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) (def-fold-test acons.fold.1 (acons 'x 'y nil)) (def-fold-test acons.fold.2 (acons 1 2 '((3 . 4) (5 . 6)))) ;;; Error tests (deftest acons.error.1 (signals-error (acons) program-error) t) (deftest acons.error.2 (signals-error (acons 'a) program-error) t) (deftest acons.error.3 (signals-error (acons 'a 'b) program-error) t) (deftest acons.error.4 (signals-error (acons 'a 'b 'c 'd) program-error) t) gcl27-2.7.0/ansi-tests/acos.lsp000066400000000000000000000045161454061450500162070ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Feb 10 05:39:24 2004 ;;;; Contains: Tess of ACOS (in-package :cl-test) (deftest acos.1 (loop for i from -1000 to 1000 for rlist = (multiple-value-list (acos i)) for y = (car rlist) always (and (null (cdr rlist)) (numberp y))) t) (deftest acos.2 (loop for type in '(short-float single-float double-float long-float) collect (let ((a (coerce 2000 type)) (b (coerce -1000 type))) (loop for x = (- (random a) b) for rlist = (multiple-value-list (acos x)) for y = (car rlist) repeat 1000 always (and (null (cdr rlist)) (numberp y))))) (t t t t)) (deftest acos.3 (loop for type in '(integer short-float single-float double-float long-float) collect (let ((a (coerce 2000 type)) (b (coerce -1000 type))) (loop for x = (- (random a) b) for rlist = (multiple-value-list (acos (complex 0 x))) for y = (car rlist) repeat 1000 always (and (null (cdr rlist)) (numberp y))))) (t t t t t)) (deftest acos.4 (loop for type in '(integer short-float single-float double-float long-float) collect (let ((a (coerce 2000 type)) (b (coerce -1000 type))) (loop for x1 = (- (random a) b) for x2 = (- (random a) b) for rlist = (multiple-value-list (acos (complex x1 x2))) for y = (car rlist) repeat 1000 always (and (null (cdr rlist)) (numberp y))))) (t t t t t)) (deftest acos.5 (approx= (acos 0) (coerce (/ pi 2) 'single-float)) t) (deftest acos.6 (loop for type in '(single-float short-float double-float long-float) unless (approx= (acos (coerce 0 type)) (coerce (/ pi 2) type)) collect type) nil) (deftest acos.7 (loop for type in '(single-float short-float double-float long-float) unless (approx= (acos (coerce 1 type)) (coerce 0 type)) collect type) nil) (deftest acos.8 (loop for type in '(single-float short-float double-float long-float) unless (approx= (acos (coerce -1 type)) (coerce pi type)) collect type) nil) (deftest acos.9 (macrolet ((%m (z) z)) (not (not (> (acos (expand-in-current-env (%m 0))) 0)))) t) ;;; FIXME ;;; Add accuracy tests ;;; Error tests (deftest acos.error.1 (signals-error (acos) program-error) t) (deftest acos.error.2 (signals-error (acos 0.0 0.0) program-error) t) (deftest acos.error.3 (check-type-error #'acos #'numberp) nil) gcl27-2.7.0/ansi-tests/acosh.lsp000066400000000000000000000041141454061450500163510ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Feb 11 19:20:53 2004 ;;;; Contains: Tests of ACOSH (in-package :cl-test) (deftest acosh.1 (let ((result (acosh 1))) (or (eqlt result 0) (eqlt result 0.0))) t) (deftest acosh.2 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 type) for one = (coerce 1 type) unless (equal (multiple-value-list (acosh one)) (list zero)) collect type) nil) (deftest acosh.3 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 `(complex ,type)) for one = (coerce 1 `(complex ,type)) unless (equal (multiple-value-list (acosh one)) (list zero)) collect type) nil) (deftest acosh.4 (loop for den = (1+ (random 10000)) for num = (random (* 10 den)) for x = (/ num den) for rlist = (multiple-value-list (acosh x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (numberp y)) collect (list x rlist)) nil) (deftest acosh.5 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x = (1+ (random (coerce 1000 type))) for rlist = (multiple-value-list (acosh x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y type)) collect (list x rlist))) nil) (deftest acosh.6 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x1 = (- (random (coerce 20 type)) 10) for x2 = (- (random (coerce 20 type)) 10) for rlist = (multiple-value-list (acosh (complex x1 x2))) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y `(complex ,type))) collect (list x1 x2 rlist))) nil) (deftest acosh.7 (macrolet ((%m (z) z)) (not (not (complexp (acosh (expand-in-current-env (%m 0))))))) t) ;;; FIXME ;;; Add accuracy tests here ;;; Error tests (deftest acosh.error.1 (signals-error (acosh) program-error) t) (deftest acosh.error.2 (signals-error (acosh 1.0 1.0) program-error) t) (deftest acosh.error.3 (check-type-error #'acosh #'numberp) nil) gcl27-2.7.0/ansi-tests/add-method.lsp000066400000000000000000000076771454061450500173030ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jun 4 19:12:25 2003 ;;;; Contains: Tests for ADD-METHOD (in-package :cl-test) (defgeneric add-method-gf-01 (x) (:method ((x t)) 'a)) (defgeneric add-method-gf-02 (x)) ;;; Cannot add a method that's already in another method (deftest add-method.error.1 (let ((method (find-method #'add-method-gf-01 nil (list (find-class t))))) (handler-case (add-method #'add-method-gf-02 method) (error () :error))) :error) ;;; The lambda lists must be congruent (deftest add-method.error.2 (let* ((gf (eval '(defgeneric add-method-gf-03 (x) (:method ((x t)) 'a)))) (method (find-method #'add-method-gf-03 nil (list (find-class t)))) (gf2 (eval '(defgeneric add-method-gf-04 (x y))))) (handler-case (add-method gf2 method) (error () :error))) :error) (deftest add-method.error.3 (let* ((gf (eval '(defgeneric add-method-gf-05 (x &optional y) (:method ((x t) &optional y) 'a)))) (method (find-method #'add-method-gf-05 nil (list (find-class t)))) (gf2 (eval '(defgeneric add-method-gf-06 (x y))))) (handler-case (add-method gf2 method) (error () :error))) :error) (deftest add-method.error.4 (signals-error (add-method) program-error) t) (deftest add-method.error.5 (signals-error (add-method #'add-method-gf-01) program-error) t) (deftest add-method.error.6 (signals-error (let* ((gf (eval '(defgeneric add-method-gf-07 (x) (:method ((x t)) 'a)))) (method (find-method #'add-method-gf-07 nil (list (find-class t)))) (gf2 (eval '(defgeneric add-method-gf-08 (x))))) (remove-method gf method) (add-method gf2 method nil)) program-error) t) (deftest add-method.error.7 (let* ((gf (eval '(defgeneric add-method-gf-09 (x y) (:method ((x t) (y t)) 'a)))) (method (find-method #'add-method-gf-09 nil (list (find-class t) (find-class t)))) (gf2 (eval '(defgeneric add-method-gf-10 (x &optional y))))) (remove-method gf method) (handler-case (add-method gf2 method) (error () :error))) :error) (deftest add-method.error.8 (let* ((gf (eval '(defgeneric add-method-gf-11 (x &key y) (:method ((x t) &key y) 'a)))) (method (find-method #'add-method-gf-11 nil (list (find-class t)))) (gf2 (eval '(defgeneric add-method-gf-12 (x))))) (remove-method gf method) (handler-case (add-method gf2 method) (error () :error))) :error) ;;; Non-error tests (deftest add-method.1 (let* ((gf (eval '(defgeneric add-method-gf-13 (x) (:method ((x integer)) 'a) (:method ((x t)) 'b)))) (method (find-method #'add-method-gf-13 nil (list (find-class 'integer)))) (gf2 (eval '(defgeneric add-method-gf-14 (x))))) (declare (type generic-function gf gf2)) (values (funcall gf 0) (funcall gf 'x) (eqt gf (remove-method gf method)) (eqt gf2 (add-method gf2 method)) (funcall gf 0) (funcall gf 'x) (funcall gf2 0))) a b t t b b a) ;;; An existing method is replaced. (deftest add-method.2 (let* ((specializers (list (find-class 'integer))) (gf (eval '(defgeneric add-method-gf-15 (x) (:method ((x integer)) 'a) (:method ((x t)) 'b)))) (method (find-method gf nil specializers)) (gf2 (eval '(defgeneric add-method-gf-16 (x) (:method ((x integer)) 'c) (:method ((x t)) 'd)))) (method2 (find-method gf2 nil specializers))) (declare (type generic-function gf gf2)) (values (funcall gf 0) (funcall gf 'x) (funcall gf2 0) (funcall gf2 'x) (eqt gf (remove-method gf method)) (eqt gf2 (add-method gf2 method)) (eqt method (find-method gf2 nil specializers)) (eqt method2 (find-method gf2 nil specializers)) (funcall gf 0) (funcall gf 'x) (funcall gf2 0) (funcall gf2 'x))) a b c d t t t nil b b a d) ;;; Must add tests for: :around methods, :before methods, :after methods, ;;; nonstandard method combinations gcl27-2.7.0/ansi-tests/adjoin.lsp000066400000000000000000000126421454061450500165250ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:33:20 1998 ;;;; Contains: Tests of ADJOIN (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) ;;; Ordering in comparison function (deftest adjoin.19 (adjoin 10 '(1 2 3) :test #'<) (10 1 2 3)) (deftest adjoin.20 (adjoin 10 '(1 2 3) :test #'>) (1 2 3)) (deftest adjoin.21 (adjoin 10 '(1 2 3) :test-not #'>) (10 1 2 3)) (deftest adjoin.22 (adjoin 10 '(1 2 3) :test-not #'<) (1 2 3)) ;;; Test that :key satisfies the description in 17.2.1 ;;; This contradicts other parts of the spec, particularly ;;; PUSHNEW, so the test is commented out. ;;; (deftest adjoin.23 ;;; (adjoin 1 '(1 2 3) :key '1+) ;;; (1 1 2 3)) (deftest adjoin.24 (macrolet ((%m (z) z)) (values (adjoin (expand-in-current-env (%m 'a)) '(b c)) (adjoin 'a (expand-in-current-env (%m '(b c)))) (adjoin 'a '(b c) (expand-in-current-env (%m :test)) 'eql) (adjoin 'a '(a a) (expand-in-current-env (%m :test-not)) 'eql) (adjoin 'a '(b c) :test (expand-in-current-env (%m 'eql))) (adjoin 'a '(b c) :test (expand-in-current-env (%m #'eql))) (adjoin 1 '(1 2 3) :key (expand-in-current-env (%m 'identity))) )) (a b c) (a b c) (a b c) (a a a) (a b c) (a b c) (1 2 3)) (defharmless adjoin.test-and-test-not.1 (adjoin 'a '(b c) :test #'eql :test-not #'eql)) (defharmless adjoin.test-and-test-not.2 (adjoin 'a '(b c) :test-not #'eql :test #'eql)) (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) (def-fold-test adjoin.fold.1 (adjoin 'x '(a b c nil d))) (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 (signals-error (adjoin) program-error) t) (deftest adjoin.error.2 (signals-error (adjoin 'a) program-error) t) (deftest adjoin.error.3 (signals-error (adjoin 'a '(b c) :bad t) program-error) t) (deftest adjoin.error.4 (signals-error (adjoin 'a '(b c) :allow-other-keys nil :bad t) program-error) t) (deftest adjoin.error.5 (signals-error (adjoin 'a '(b c) 1 2) program-error) t) (deftest adjoin.error.6 (signals-error (adjoin 'a '(b c) :test) program-error) t) (deftest adjoin.error.7 (signals-error (adjoin 'a '(b c) :test #'identity) program-error) t) (deftest adjoin.error.8 (signals-error (adjoin 'a '(b c) :test-not #'identity) program-error) t) (deftest adjoin.error.9 (signals-error (adjoin 'a '(b c) :key #'cons) program-error) t) (deftest adjoin.error.10 (signals-error (adjoin 'a (list* 'b 'c 'd)) type-error) t) gcl27-2.7.0/ansi-tests/adjust-array.lsp000066400000000000000000001012551454061450500176660ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Feb 15 07:27:22 2004 ;;;; Contains: Tests of ADJUST-ARRAY (in-package :cl-test) (defun listify-form (form) (cond ((integerp form) `'(,form)) ((null form) nil) ((and (consp form) (eq (car form) 'quote) (consp (cadr form))) form) (t `(let ((x ,form)) (if (listp x) x (list x)))))) (defmacro def-adjust-array-test (name args1 args2 expected-result) `(deftest ,name (let* ((a1 (make-array ,@args1)) (a2 (adjust-array a1 ,@args2))) (assert (or (not (adjustable-array-p a1)) (eq a1 a2))) (assert (or (adjustable-array-p a1) (equal (array-dimensions a1) ,(listify-form (first args1))))) (assert (equal (array-dimensions a2) ,(listify-form (first args2)))) ,@(unless (or (member :displaced-to args1) (member :displaced-to args2)) (list '(assert (not (array-displacement a2))))) a2) ,expected-result)) (defmacro def-adjust-array-fp-test (name args1 args2 misc &rest expected-results) `(deftest ,name (let* ((a1 (make-array ,@args1)) (a2 (adjust-array a1 ,@args2))) (assert (or (not (adjustable-array-p a1)) (eq a1 a2))) (assert (or (adjustable-array-p a1) (equal (array-dimensions a1) ,(listify-form (first args1))))) (assert (equal (array-dimensions a2) ,(listify-form (first args2)))) ,@(unless (or (member :displaced-to args1) (member :displaced-to args2)) (list '(assert (not (array-displacement a2))))) ,@(when misc (list misc)) (values (fill-pointer a2) a2)) ,@expected-results)) (def-adjust-array-test adjust-array.1 (5 :initial-contents '(a b c d e)) (4) #(a b c d)) (def-adjust-array-test adjust-array.2 (5 :initial-contents '(a b c d e)) (8 :initial-element 'x) #(a b c d e x x x)) (def-adjust-array-test adjust-array.3 (5 :initial-contents '(a b c d e)) (4 :initial-contents '(w x y z)) #(w x y z)) (def-adjust-array-test adjust-array.4 (5 :initial-contents '(a b c d e)) (8 :initial-contents '(8 7 6 5 4 3 2 1)) #(8 7 6 5 4 3 2 1)) (def-adjust-array-fp-test adjust-array.5 (5 :initial-contents '(a b c d e) :fill-pointer 3) (4) (assert (eq (aref a2 3) 'd)) 3 #(a b c)) (def-adjust-array-fp-test adjust-array.6 (5 :initial-contents '(a b c d e) :fill-pointer 3) (4 :fill-pointer nil) (assert (eq (aref a2 3) 'd)) 3 #(a b c)) (def-adjust-array-fp-test adjust-array.7 (5 :initial-contents '(a b c d e) :fill-pointer 3) (4 :fill-pointer t) nil 4 #(a b c d)) (def-adjust-array-fp-test adjust-array.8 (5 :initial-contents '(a b c d e) :fill-pointer 3) (4 :fill-pointer 2) (progn (assert (eq (aref a2 2) 'c)) (assert (eq (aref a2 3) 'd))) 2 #(a b)) (def-adjust-array-fp-test adjust-array.9 (5 :initial-contents '(a b c d e) :fill-pointer 3) (8 :fill-pointer 5 :initial-element 'x) (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) '(x x x))) 5 #(a b c d e)) (deftest adjust-array.10 (let* ((a1 (make-array 5 :initial-contents '(a b c d e))) (a2 (adjust-array a1 4 :displaced-to nil))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (not (array-displacement a2))) a2) #(a b c d)) (deftest adjust-array.11 (let* ((a0 (make-array 7 :initial-contents '(x a b c d e y))) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1)) (a2 (adjust-array a1 4))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (not (array-displacement a2))) a2) #(a b c d)) (deftest adjust-array.12 (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7))) (a1 (make-array 5 :initial-contents '(a b c d e))) (a2 (adjust-array a1 4 :displaced-to a0))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (equal (multiple-value-list (array-displacement a2)) (list a0 0))) a2) #(1 2 3 4)) (deftest adjust-array.13 (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7))) (a1 (make-array 5 :initial-contents '(a b c d e))) (a2 (adjust-array a1 4 :displaced-to a0 :displaced-index-offset 2))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (equal (multiple-value-list (array-displacement a2)) (list a0 2))) a2) #(3 4 5 6)) (deftest adjust-array.14 (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7))) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1)) (a2 (adjust-array a1 4 :displaced-to a0))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (equal (multiple-value-list (array-displacement a2)) (list a0 0))) a2) #(1 2 3 4)) (deftest adjust-array.15 (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7))) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1)) (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1)) (a3 (adjust-array a2 4 :displaced-to a1))) a3) #(2 3 4 5)) (deftest adjust-array.16 (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7))) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1)) (a2 (adjust-array a1 5 :displaced-to a0))) a2) #(1 2 3 4 5)) (def-adjust-array-test adjust-array.17 (nil :initial-element 'x) (nil) #0ax) (def-adjust-array-test adjust-array.18 (nil :initial-element 'x) (nil :initial-contents 'y) #0ay) (def-adjust-array-test adjust-array.19 (nil :initial-element 'x) (nil :initial-element 'y) #0ax) (deftest adjust-array.20 (let* ((a0 (make-array nil :initial-element 'x)) (a1 (make-array nil :displaced-to a0)) (a2 (adjust-array a1 nil))) a2) #0ax) ;; 2-d arrays (def-adjust-array-test adjust-array.21 ('(4 5) :initial-contents '((1 2 3 4 5) (3 4 5 6 7) (5 6 7 8 9) (7 8 9 1 2))) ('(2 3)) #2a((1 2 3)(3 4 5))) (def-adjust-array-test adjust-array.22 ('(4 5) :initial-contents '((1 2 3 4 5) (3 4 5 6 7) (5 6 7 8 9) (7 8 9 1 2))) ('(6 8) :initial-element 0) #2a((1 2 3 4 5 0 0 0) (3 4 5 6 7 0 0 0) (5 6 7 8 9 0 0 0) (7 8 9 1 2 0 0 0) (0 0 0 0 0 0 0 0) (0 0 0 0 0 0 0 0))) (deftest adjust-array.23 (let* ((a1 (make-array '(4 5) :initial-contents '((#\1 #\2 #\3 #\4 #\5) (#\3 #\4 #\5 #\6 #\7) (#\5 #\6 #\7 #\8 #\9) (#\7 #\8 #\9 #\1 #\2)) :element-type 'character)) (a2 (adjust-array a1 '(2 3) :element-type 'character))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a2) '(2 3)))) (assert (not (typep 0 (array-element-type a2)))) a2) #2a((#\1 #\2 #\3)(#\3 #\4 #\5))) ;;; Macro expansion tests (deftest adjust-array.24 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d)))) (adjust-array (expand-in-current-env (%m a)) '(4)))) #(a b c d)) (deftest adjust-array.25 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d)))) (adjust-array a (expand-in-current-env (%m '(4)))))) #(a b c d)) (deftest adjust-array.26 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d)))) (adjust-array a '(4) (expand-in-current-env (%m :element-type)) t))) #(a b c d)) (deftest adjust-array.27 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d)))) (adjust-array a '(4) :element-type (expand-in-current-env (%m t))))) #(a b c d)) (deftest adjust-array.28 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d)))) (adjust-array a '(6) (expand-in-current-env (%m :initial-element)) 17))) #(a b c d 17 17)) (deftest adjust-array.29 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d)))) (adjust-array a '(7) :initial-element (expand-in-current-env (%m 5))))) #(a b c d 5 5 5)) (deftest adjust-array.30 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d)))) (adjust-array a '(6) (expand-in-current-env (%m :initial-contents)) '(1 2 3 4 5 6)))) #(1 2 3 4 5 6)) (deftest adjust-array.31 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d)))) (adjust-array a '(3) :initial-contents (expand-in-current-env (%m "ABC"))))) #(#\A #\B #\C)) (deftest adjust-array.32 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d)))) (adjust-array a '(4) (expand-in-current-env (%m :fill-pointer)) nil))) #(a b c d)) (deftest adjust-array.33 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d)))) (adjust-array a '(4) :fill-pointer (expand-in-current-env (%m nil))))) #(a b c d)) (deftest adjust-array.34 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d)))) (adjust-array a '(4) (expand-in-current-env (%m :displaced-to)) nil))) #(a b c d)) (deftest adjust-array.35 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d)))) (adjust-array a '(4) :displaced-to (expand-in-current-env (%m nil))))) #(a b c d)) (deftest adjust-array.36 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d))) (c (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8)))) (adjust-array a '(3) :displaced-to c (expand-in-current-env (%m :displaced-index-offset)) 2))) #(3 4 5)) (deftest adjust-array.37 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d))) (c (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8)))) (adjust-array a '(5) :displaced-to c :displaced-index-offset (expand-in-current-env (%m 1))))) #(2 3 4 5 6)) ;;; Adjust an adjustable array (def-adjust-array-test adjust-array.adjustable.1 (5 :initial-contents '(a b c d e) :adjustable t) (4) #(a b c d)) (def-adjust-array-test adjust-array.adjustable.2 (5 :initial-contents '(a b c d e) :adjustable t) (8 :initial-element 'x) #(a b c d e x x x)) (def-adjust-array-test adjust-array.adjustable.3 (5 :initial-contents '(a b c d e) :adjustable t) (4 :initial-contents '(w x y z)) #(w x y z)) (def-adjust-array-test adjust-array.adjustable.4 (5 :initial-contents '(a b c d e) :adjustable t) (8 :initial-contents '(8 7 6 5 4 3 2 1)) #(8 7 6 5 4 3 2 1)) (def-adjust-array-fp-test adjust-array.adjustable.5 (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t) (4) (assert (eq (aref a2 3) 'd)) 3 #(a b c)) (def-adjust-array-fp-test adjust-array.adjustable.6 (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t) (4 :fill-pointer nil) (assert (eq (aref a2 3) 'd)) 3 #(a b c)) (def-adjust-array-fp-test adjust-array.adjustable.7 (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t) (4 :fill-pointer t) nil 4 #(a b c d)) (def-adjust-array-fp-test adjust-array.adjustable.8 (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t) (4 :fill-pointer 2) (assert (equal (list (aref a2 2) (aref a2 3)) '(c d))) 2 #(a b)) (def-adjust-array-fp-test adjust-array.adjustable.9 (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t) (8 :fill-pointer 5 :initial-element 'x) (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) '(x x x))) 5 #(a b c d e)) (deftest adjust-array.adjustable.10 (let* ((a1 (make-array 5 :initial-contents '(a b c d e) :adjustable t)) (a2 (adjust-array a1 4 :displaced-to nil))) (assert (eq a1 a2)) (assert (not (array-displacement a2))) a2) #(a b c d)) (deftest adjust-array.adjustable.11 (let* ((a0 (make-array 7 :initial-contents '(x a b c d e y))) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :adjustable t)) (a2 (adjust-array a1 4))) (assert (eq a1 a2)) (assert (not (array-displacement a2))) a2) #(a b c d)) (deftest adjust-array.adjustable.12 (let* ((a0 (make-array 7 :initial-contents '(x a b c d e y))) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :adjustable t)) (a2 (adjust-array a1 4 :displaced-to a0))) (assert (eq a1 a2)) a2) #(x a b c)) (deftest adjust-array.adjustable.13 (let* ((a0 (make-array 7 :initial-contents '(x a b c d e y))) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :adjustable t)) (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1))) (assert (eq a1 (adjust-array a1 5 :displaced-to a0 :displaced-index-offset 2))) a2) #(c d e y)) ;;;; Strings (loop for element-type in '(character base-char) for forms = `( (def-adjust-array-test adjust-array.string.1 (5 :element-type 'character :initial-contents "abcde") (4 :element-type 'character) "abcd") (def-adjust-array-test adjust-array.string.2 (5 :element-type 'character :initial-contents "abcde") (8 :element-type 'character :initial-element #\x) "abcdexxx") (def-adjust-array-test adjust-array.string.3 (5 :element-type 'character :initial-contents "abcde") (4 :element-type 'character :initial-contents "wxyz") "wxyz") (def-adjust-array-test adjust-array.string.4 (5 :element-type 'character :initial-contents "abcde") (8 :element-type 'character :initial-contents "87654321") "87654321") (def-adjust-array-fp-test adjust-array.string.5 (5 :element-type 'character :initial-contents "abcde" :fill-pointer 3) (4 :element-type 'character) (assert (eql (aref a2 3) #\d)) 3 "abc") (def-adjust-array-fp-test adjust-array.string.6 (5 :element-type 'character :initial-contents "abcde" :fill-pointer 3) (4 :element-type 'character :fill-pointer nil) (assert (eql (aref a2 3) #\d)) 3 "abc") (def-adjust-array-fp-test adjust-array.string.7 (5 :element-type 'character :initial-contents "abcde" :fill-pointer 3) (4 :element-type 'character :fill-pointer t) nil 4 "abcd") (def-adjust-array-fp-test adjust-array.string.8 (5 :element-type 'character :initial-contents "abcde" :fill-pointer 3) (4 :element-type 'character :fill-pointer 2) (progn (assert (eql (aref a2 2) #\c)) (assert (eql (aref a2 3) #\d))) 2 "ab") (def-adjust-array-fp-test adjust-array.string.9 (5 :element-type 'character :initial-contents "abcde" :fill-pointer 3) (8 :element-type 'character :fill-pointer 5 :initial-element #\x) (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) '(#\x #\x #\x))) 5 "abcde") (deftest adjust-array.string.10 (let* ((a1 (make-array 5 :element-type 'character :initial-contents "abcde")) (a2 (adjust-array a1 4 :displaced-to nil :element-type 'character))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (not (array-displacement a2))) a2) "abcd") (deftest adjust-array.string.11 (let* ((a0 (make-array 7 :initial-contents "xabcdey" :element-type 'character)) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :element-type 'character)) (a2 (adjust-array a1 4 :element-type 'character))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (not (array-displacement a2))) a2) "abcd") (deftest adjust-array.string.12 (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character)) (a1 (make-array 5 :initial-contents "abcde" :element-type 'character)) (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'character))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (equal (multiple-value-list (array-displacement a2)) (list a0 0))) a2) "1234") (deftest adjust-array.string.13 (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character)) (a1 (make-array 5 :initial-contents "abcde" :element-type 'character)) (a2 (adjust-array a1 4 :displaced-to a0 :displaced-index-offset 2 :element-type 'character))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (equal (multiple-value-list (array-displacement a2)) (list a0 2))) a2) "3456") (deftest adjust-array.string.14 (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character)) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :element-type 'character)) (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'character))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (equal (multiple-value-list (array-displacement a2)) (list a0 0))) a2) "1234") (deftest adjust-array.string.15 (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character)) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :element-type 'character)) (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1 :element-type 'character)) (a3 (adjust-array a2 4 :displaced-to a1 :element-type 'character))) a3) "2345") (deftest adjust-array.string.16 (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character)) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :element-type 'character)) (a2 (adjust-array a1 5 :displaced-to a0 :element-type 'character))) a2) "12345") (def-adjust-array-test adjust-array.string.17 (nil :initial-element #\x :element-type 'character) (nil) #.(make-array nil :initial-element #\x :element-type 'character)) (def-adjust-array-test adjust-array.string.18 (nil :initial-element #\x :element-type 'character) (nil :initial-contents #\y :element-type 'character) #.(make-array nil :initial-element #\y :element-type 'character)) (def-adjust-array-test adjust-array.string.19 (nil :initial-element #\x :element-type 'character) (nil :initial-element #\y :element-type 'character) #.(make-array nil :initial-element #\x :element-type 'character)) (deftest adjust-array.string.20 (let* ((a0 (make-array nil :initial-element #\x :element-type 'character)) (a1 (make-array nil :displaced-to a0 :element-type 'character)) (a2 (adjust-array a1 nil :element-type 'character))) a2) #.(make-array nil :initial-element #\x :element-type 'character)) (def-adjust-array-test adjust-array.string.adjustable.1 (5 :initial-contents "abcde" :adjustable t :element-type 'character) (4 :element-type 'character) "abcd") (def-adjust-array-test adjust-array.string.adjustable.2 (5 :initial-contents "abcde" :adjustable t :element-type 'character) (8 :initial-element #\x :element-type 'character) "abcdexxx") (def-adjust-array-test adjust-array.string.adjustable.3 (5 :initial-contents "abcde" :adjustable t :element-type 'character) (4 :initial-contents "wxyz" :element-type 'character) "wxyz") (def-adjust-array-test adjust-array.string.adjustable.4 (5 :initial-contents "abcde" :adjustable t :element-type 'character) (8 :initial-contents "87654321" :element-type 'character) "87654321") (def-adjust-array-fp-test adjust-array.string.adjustable.5 (5 :initial-contents "abcde" :fill-pointer 3 :adjustable t :element-type 'character) (4 :element-type 'character :initial-element #\Space) (assert (eql (aref a2 3) #\d)) 3 "abc") (def-adjust-array-fp-test adjust-array.string.adjustable.6 (5 :initial-contents "abcde" :fill-pointer 3 :adjustable t :element-type 'character) (4 :fill-pointer nil :element-type 'character :initial-element #\?) (assert (eql (aref a2 3) #\d)) 3 "abc") (def-adjust-array-fp-test adjust-array.string.adjustable.7 (5 :initial-contents "abcde" :fill-pointer 3 :adjustable t :element-type 'character) (4 :fill-pointer t :element-type 'character :initial-element #\!) nil 4 "abcd") (def-adjust-array-fp-test adjust-array.string.adjustable.8 (5 :initial-contents "abcde" :fill-pointer 3 :adjustable t :element-type 'character) (4 :fill-pointer 2 :element-type 'character :initial-element #\X) (assert (equal (list (aref a2 2) (aref a2 3)) '(#\c #\d))) 2 "ab") (def-adjust-array-fp-test adjust-array.string.adjustable.9 (5 :initial-contents "abcde" :fill-pointer 3 :adjustable t :element-type 'character) (8 :fill-pointer 5 :initial-element #\x :element-type 'character) (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) '(#\x #\x #\x))) 5 "abcde") (deftest adjust-array.string.adjustable.10 (let* ((a1 (make-array 5 :initial-contents "abcde" :adjustable t :element-type 'character)) (a2 (adjust-array a1 4 :displaced-to nil :element-type 'character))) (assert (eq a1 a2)) (assert (not (array-displacement a2))) a2) "abcd") (deftest adjust-array.string.adjustable.11 (let* ((a0 (make-array 7 :initial-contents "xabcdey" :element-type 'character)) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :adjustable t :element-type 'character)) (a2 (adjust-array a1 4 :element-type 'character))) (assert (eq a1 a2)) (assert (not (array-displacement a2))) a2) "abcd") (deftest adjust-array.string.adjustable.12 (let* ((a0 (make-array 7 :initial-contents "xabcdey" :element-type 'character)) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :adjustable t :element-type 'character)) (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'character))) (assert (eq a1 a2)) a2) "xabc") (deftest adjust-array.string.adjustable.13 (let* ((a0 (make-array 7 :initial-contents "xabcdey" :element-type 'character)) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :adjustable t :element-type 'character)) (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1 :element-type 'character))) (assert (eq a1 (adjust-array a1 5 :displaced-to a0 :displaced-index-offset 2 :element-type 'character))) a2) "cdey") ) for forms2 = (subst element-type 'character forms) for forms3 = (mapcar #'(lambda (form) (destructuring-bind (dt name . body) form `(,dt ,(if (eql element-type 'character) name (intern (replace (copy-seq (symbol-name name)) "BASEST" :start1 13 :end1 19) (symbol-package name))) ,@ body))) forms2) do (eval `(progn ,@forms3))) ;; 2-d arrays (def-adjust-array-test adjust-array.string.21 ('(4 5) :initial-contents '("12345" "34567" "56789" "78912") :element-type 'character) ('(2 3)) #.(make-array '(2 3) :initial-contents '("123" "345") :element-type 'character)) (def-adjust-array-test adjust-array.string.22 ('(4 5) :initial-contents '("12345" "34567" "56789" "78912") :element-type 'character) ('(6 8) :initial-element #\0 :element-type 'character) #.(make-array '(6 8) :initial-contents '("12345000" "34567000" "56789000" "78912000" "00000000" "00000000") :element-type 'character)) (def-adjust-array-test adjust-array.bit-vector.1 (5 :element-type 'bit :initial-contents #*01100) (4 :element-type 'bit) #*0110) (def-adjust-array-test adjust-array.bit-vector.2 (5 :element-type 'bit :initial-contents #*01100) (8 :element-type 'bit :initial-element 1) #*01100111) (def-adjust-array-test adjust-array.bit-vector.3 (5 :element-type 'bit :initial-contents #*01100) (4 :element-type 'bit :initial-contents #*1011) #*1011) (def-adjust-array-test adjust-array.bit-vector.4 (5 :element-type 'bit :initial-contents #*01100) (8 :element-type 'bit :initial-contents #*11110000) #*11110000) (def-adjust-array-fp-test adjust-array.bit-vector.5 (5 :element-type 'bit :initial-contents #*01100 :fill-pointer 3) (4 :element-type 'bit) (assert (eql (aref a2 3) 0)) 3 #*011) (def-adjust-array-fp-test adjust-array.bit-vector.6 (5 :element-type 'bit :initial-contents #*01100 :fill-pointer 3) (4 :element-type 'bit :fill-pointer nil) (assert (eql (aref a2 3) 0)) 3 #*011) (def-adjust-array-fp-test adjust-array.bit-vector.7 (5 :element-type 'bit :initial-contents #*01100 :fill-pointer 3) (4 :element-type 'bit :fill-pointer t) nil 4 #*0110) (def-adjust-array-fp-test adjust-array.bit-vector.8 (5 :element-type 'bit :initial-contents #*01100 :fill-pointer 3) (4 :element-type 'bit :fill-pointer 2) (progn (assert (eql (aref a2 2) 1)) (assert (eql (aref a2 3) 0))) 2 #*01) (def-adjust-array-fp-test adjust-array.bit-vector.9 (5 :element-type 'bit :initial-contents #*01100 :fill-pointer 3) (8 :element-type 'bit :fill-pointer 5 :initial-element 1) (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) '(1 1 1))) 5 #*01100) (deftest adjust-array.bit-vector.10 (let* ((a1 (make-array 5 :element-type 'bit :initial-contents #*01100)) (a2 (adjust-array a1 4 :displaced-to nil :element-type 'bit))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (not (array-displacement a2))) a2) #*0110) (deftest adjust-array.bit-vector.11 (let* ((a0 (make-array 7 :initial-contents #*0011001 :element-type 'bit)) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :element-type 'bit)) (a2 (adjust-array a1 4 :element-type 'bit))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (not (array-displacement a2))) a2) #*0110) (deftest adjust-array.bit-vector.12 (let* ((a0 (make-array 7 :initial-contents #*1010101 :element-type 'bit)) (a1 (make-array 5 :initial-contents #*01100 :element-type 'bit)) (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'bit))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (equal (multiple-value-list (array-displacement a2)) (list a0 0))) a2) #*1010) (deftest adjust-array.bit-vector.13 (let* ((a0 (make-array 7 :initial-contents #*1011101 :element-type 'bit)) (a1 (make-array 5 :initial-contents #*01100 :element-type 'bit)) (a2 (adjust-array a1 4 :displaced-to a0 :displaced-index-offset 2 :element-type 'bit))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (equal (multiple-value-list (array-displacement a2)) (list a0 2))) a2) #*1110) (deftest adjust-array.bit-vector.14 (let* ((a0 (make-array 7 :initial-contents #*1011001 :element-type 'bit)) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :element-type 'bit)) (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'bit))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (equal (multiple-value-list (array-displacement a2)) (list a0 0))) a2) #*1011) (deftest adjust-array.bit-vector.15 (let* ((a0 (make-array 7 :initial-contents #*1100010 :element-type 'bit)) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :element-type 'bit)) (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1 :element-type 'bit)) (a3 (adjust-array a2 4 :displaced-to a1 :element-type 'bit))) a3) #*1000) (deftest adjust-array.bit-vector.16 (let* ((a0 (make-array 7 :initial-contents #*1011011 :element-type 'bit)) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :element-type 'bit)) (a2 (adjust-array a1 5 :displaced-to a0 :element-type 'bit))) a2) #*10110) (def-adjust-array-test adjust-array.bit-vector.17 (nil :initial-element 0 :element-type 'bit) (nil) #.(make-array nil :initial-element 0 :element-type 'bit)) (def-adjust-array-test adjust-array.bit-vector.18 (nil :initial-element 0 :element-type 'bit) (nil :initial-contents 1 :element-type 'bit) #.(make-array nil :initial-element 1 :element-type 'bit)) (def-adjust-array-test adjust-array.bit-vector.19 (nil :initial-element 1 :element-type 'bit) (nil :initial-element 0 :element-type 'bit) #.(make-array nil :initial-element 1 :element-type 'bit)) (deftest adjust-array.bit-vector.20 (let* ((a0 (make-array nil :initial-element 1 :element-type 'bit)) (a1 (make-array nil :displaced-to a0 :element-type 'bit)) (a2 (adjust-array a1 nil :element-type 'bit))) a2) #.(make-array nil :initial-element 1 :element-type 'bit)) ;; 2-d arrays (def-adjust-array-test adjust-array.bit-vector.21 ('(4 5) :initial-contents '(#*11100 #*00110 #*00001 #*11111) :element-type 'bit) ('(2 3)) #.(make-array '(2 3) :initial-contents '(#*111 #*001) :element-type 'bit)) (def-adjust-array-test adjust-array.bit-vector.22 ('(4 5) :initial-contents '(#*11100 #*00110 #*00001 #*11111) :element-type 'bit) ('(6 8) :initial-element 0 :element-type 'bit) #.(make-array '(6 8) :initial-contents '(#*11100000 #*00110000 #*00001000 #*11111000 #*00000000 #*00000000) :element-type 'bit)) ;;; Adjustable bit vector tests (def-adjust-array-test adjust-array.bit-vector.adjustable.1 (5 :initial-contents '(1 0 1 1 0) :adjustable t :element-type 'bit) (4 :element-type 'bit) #*1011) (def-adjust-array-test adjust-array.bit-vector.adjustable.2 (5 :initial-contents '(1 0 1 0 1) :adjustable t :element-type 'bit) (8 :initial-element '1 :element-type 'bit) #*10101111) (def-adjust-array-test adjust-array.bit-vector.adjustable.3 (5 :initial-contents '(0 1 0 1 0) :adjustable t :element-type 'bit) (4 :initial-contents '(1 1 1 0) :element-type 'bit) #*1110) (def-adjust-array-test adjust-array.bit-vector.adjustable.4 (5 :initial-contents '(1 0 0 1 0) :adjustable t :element-type 'bit) (8 :initial-contents '(0 1 0 1 1 0 1 0) :element-type 'bit) #*01011010) (def-adjust-array-fp-test adjust-array.bit-vector.adjustable.5 (5 :initial-contents '(1 1 1 0 0) :fill-pointer 3 :adjustable t :element-type 'bit) (4 :element-type 'bit :initial-element 0) (assert (eql (aref a2 3) 0)) 3 #*111) (def-adjust-array-fp-test adjust-array.bit-vector.adjustable.6 (5 :initial-contents '(0 0 0 1 1) :fill-pointer 3 :adjustable t :element-type 'bit) (4 :fill-pointer nil :element-type 'bit :initial-element 1) (assert (eql (aref a2 3) 1)) 3 #*000) (def-adjust-array-fp-test adjust-array.bit-vector.adjustable.7 (5 :initial-contents '(1 1 0 1 1) :fill-pointer 3 :adjustable t :element-type 'bit) (4 :fill-pointer t :element-type 'bit :initial-element 1) nil 4 #*1101) (def-adjust-array-fp-test adjust-array.bit-vector.adjustable.8 (5 :initial-contents '(0 1 1 1 0) :fill-pointer 3 :adjustable t :element-type 'bit) (4 :fill-pointer 2 :element-type 'bit :initial-element 0) (assert (equal (list (aref a2 2) (aref a2 3)) '(1 1))) 2 #*01) (def-adjust-array-fp-test adjust-array.bit-vector.adjustable.9 (5 :initial-contents '(1 0 0 0 1) :fill-pointer 3 :adjustable t :element-type 'bit) (8 :fill-pointer 5 :initial-element 1 :element-type 'bit) (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) '(1 1 1))) 5 #*10001) (deftest adjust-array.bit-vector.adjustable.10 (let* ((a1 (make-array 5 :initial-contents '(0 1 1 0 1) :adjustable t :element-type 'bit)) (a2 (adjust-array a1 4 :displaced-to nil :element-type 'bit))) (assert (eq a1 a2)) (assert (not (array-displacement a2))) a2) #*0110) (deftest adjust-array.bit-vector.adjustable.11 (let* ((a0 (make-array 7 :initial-contents '(0 1 0 1 1 1 0) :element-type 'bit)) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :adjustable t :element-type 'bit)) (a2 (adjust-array a1 4 :element-type 'bit))) (assert (eq a1 a2)) (assert (not (array-displacement a2))) a2) #*1011) (deftest adjust-array.bit-vector.adjustable.12 (let* ((a0 (make-array 7 :initial-contents '(0 0 1 1 1 1 1) :element-type 'bit)) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :adjustable t :element-type 'bit)) (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'bit))) (assert (eq a1 a2)) a2) #*0011) (deftest adjust-array.bit-vector.adjustable.13 (let* ((a0 (make-array 7 :initial-contents '(1 0 0 0 0 0 1) :element-type 'bit)) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :adjustable t :element-type 'bit)) (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1 :element-type 'bit))) (assert (eq a1 (adjust-array a1 5 :displaced-to a0 :displaced-index-offset 2 :element-type 'bit))) a2) #*0001) ;;; FIXME. specialized integer array tests ;;; FIXNME float array tests ;;; Error cases (deftest adjust-array.error.1 (signals-error (adjust-array) program-error) t) (deftest adjust-array.error.2 (signals-error (adjust-array (make-array 10 :initial-element nil)) program-error) t) (deftest adjust-array.error.3 (signals-error (adjust-array (make-array 10 :initial-element nil) 8 :bad t) program-error) t) (deftest adjust-array.error.4 (signals-error (adjust-array (make-array 10 :initial-element nil) 8 :initial-element) program-error) t) (deftest adjust-array.error.5 (signals-error (adjust-array (make-array 10 :initial-element nil) 8 :allow-other-keys nil :allow-other-keys t :bad t) program-error) t) (deftest adjust-array.error.6 (signals-error (let ((a (make-array 5 :initial-element 'x))) (adjust-array a :fill-pointer 4)) error) t) gcl27-2.7.0/ansi-tests/adjustable-array-p.lsp000066400000000000000000000032531454061450500207460ustar00rootroot00000000000000;-*- 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.6 (macrolet ((%m (z) z)) (let ((a (make-array '(5) :adjustable t))) (notnot (adjustable-array-p (expand-in-current-env (%m a)))))) 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 (signals-error (adjustable-array-p) program-error) t) (deftest adjustable-array-p.error.2 (signals-error (adjustable-array-p "aaa" nil) program-error) t) (deftest adjustable-array-p.error.3 (signals-type-error x 10 (adjustable-array-p x)) t) (deftest adjustable-array-p.error.4 (check-type-error #'adjustable-array-p #'arrayp) nil) (deftest adjustable-array-p.error.5 (signals-error (locally (adjustable-array-p 10)) type-error) t) (deftest adjustable-array-p.error.6 (signals-error (let ((x 10)) (locally (declare (optimize (safety 3))) (adjustable-array-p x))) type-error) t) gcl27-2.7.0/ansi-tests/allocate-instance.lsp000066400000000000000000000072631454061450500206520ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Apr 28 21:06:58 2003 ;;;; Contains: Tests of ALLOCATE-INSTANCE (in-package :cl-test) ;;; According to the CLHS, the meaning of adding methods to ;;; ALLOCATE-INSTANCE is unspecified, so this will not be tested ;;; here. (defclass allocate-instance-class-01 () ((a :initform 'x) (b :initarg :b) (c :type float) (d :allocation :class) (e :initarg :e) (f :documentation "foo")) (:default-initargs :b 'y)) (deftest allocate-instance.1 (let* ((class (find-class 'allocate-instance-class-01)) (obj (allocate-instance class))) (values (eqt (class-of obj) class) (typep* obj 'allocate-instance-class-01) (typep* obj class) (map-slot-boundp* obj '(a b c d e f)))) t t t (nil nil nil nil nil nil)) (deftest allocate-instance.2 (let* ((class (find-class 'allocate-instance-class-01)) (obj (allocate-instance class :foo t :a 10 :b 12 :c 1.0 :d 'a :e 17 :f nil :bar t))) (values (eqt (class-of obj) class) (typep* obj 'allocate-instance-class-01) (typep* obj class) (map-slot-boundp* obj '(a b c d e f)))) t t t (nil nil nil nil nil nil)) (deftest allocate-instance.3 (let* ((class (find-class 'allocate-instance-class-01)) (obj (allocate-instance class :allow-other-keys nil :xyzzy t))) (values (eqt (class-of obj) class) (typep* obj 'allocate-instance-class-01) (typep* obj class) (map-slot-boundp* obj '(a b c d e f)))) t t t (nil nil nil nil nil nil)) (defclass allocate-instance-class-02 () (a (b :allocation :class))) (deftest allocate-instance.4 (let ((class (find-class 'allocate-instance-class-02))) (setf (slot-value (allocate-instance class) 'b) 'x) (let ((obj (allocate-instance class))) (values (eqt (class-of obj) class) (typep* obj 'allocate-instance-class-02) (typep* obj class) (slot-boundp* obj 'a) (slot-value obj 'b)))) t t t nil x) (defstruct allocate-instance-struct-01 a (b 0 :type integer) (c #\a :type character) (d 'a :type symbol)) (deftest allocate-instance.5 (let* ((class (find-class 'allocate-instance-struct-01)) (obj (allocate-instance class))) (setf (allocate-instance-struct-01-a obj) 'x (allocate-instance-struct-01-b obj) 1234567890 (allocate-instance-struct-01-c obj) #\Z (allocate-instance-struct-01-d obj) 'foo) (values (eqt (class-of obj) class) (typep* obj 'allocate-instance-struct-01) (typep* obj class) (allocate-instance-struct-01-a obj) (allocate-instance-struct-01-b obj) (allocate-instance-struct-01-c obj) (allocate-instance-struct-01-d obj))) t t t x 1234567890 #\Z foo) ;;; Order of evaluation tests (deftest allocate-instance.order.1 (let* ((class (find-class 'allocate-instance-class-01)) (i 0) x y z w (obj (allocate-instance (progn (setf x (incf i)) class) :e (setf y (incf i)) :b (setf z (incf i)) :e (setf w (incf i))))) (values (eqt (class-of obj) class) (typep* obj 'allocate-instance-class-01) (typep* obj class) i x y z w)) t t t 4 1 2 3 4) ;;; Error tests (deftest allocate-instance.error.1 (signals-error (allocate-instance) program-error) t) ;;; Duane Rettig made a convincing argument that the next two ;;; tests are bad, since the caller of allocate-instance ;;; is supposed to have checked that the initargs are valid #| (deftest allocate-instance.error.2 (signals-error (allocate-instance (find-class 'allocate-instance-class-01) :b) program-error) t) (deftest allocate-instance.error.3 (signals-error (allocate-instance (find-class 'allocate-instance-class-01) '(a b c) nil) program-error) t) |# gcl27-2.7.0/ansi-tests/and.lsp000066400000000000000000000025401454061450500160170ustar00rootroot00000000000000;-*- 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) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest and.10 (macrolet ((%m (z) z)) (and (expand-in-current-env (%m :a)) (expand-in-current-env (%m :b)) (expand-in-current-env (%m :c)))) :c) ;;; Error tests (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) (deftest and.error.1 (signals-error (funcall (macro-function 'and)) program-error) t) (deftest and.error.2 (signals-error (funcall (macro-function 'and) '(and)) program-error) t) (deftest and.error.3 (signals-error (funcall (macro-function 'and) '(and) nil nil) program-error) t) gcl27-2.7.0/ansi-tests/ansi-aux-macros.lsp000066400000000000000000000024201454061450500202610ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jul 2 07:05:41 2003 ;;;; Contains: Macros used in ansi-aux and elsewhere. (in-package :cl-test) (declaim (optimize (safety 3))) ;;; Macros to avoid annoying sbcl warning notes (defmacro handler-case (form &rest cases) `(let () (cl:handler-case ,form ,@cases))) (defmacro handler-bind (handlers &rest body) `(let () (cl:handler-bind ,handlers (normally (progn ,@body))))) ;;; Macros for avoiding dead code warnings (defvar *should-always-be-true* t) (declaim (notinline should-never-be-called)) (defun should-never-be-called () nil) (defmacro normally (form &optional (default-form '(should-never-be-called))) `(if *should-always-be-true* ,form ,default-form)) ;;; Macro to ignore errors, but report them anyway (defparameter *report-and-ignore-errors-break* nil "When true, REPORT-AND-IGNORE-ERRORS breaks instead of discarding the error condition.") (defmacro report-and-ignore-errors (&body body) `(eval-when (:load-toplevel :compile-toplevel :execute) (#+sbcl let #+sbcl () #-sbcl progn (handler-case (progn ,@body) (error (condition) (princ condition) (terpri) (when *report-and-ignore-errors-break* (break)) (values nil condition)))))) gcl27-2.7.0/ansi-tests/ansi-aux.lsp000066400000000000000000001067121454061450500170100ustar00rootroot00000000000000;-*- 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)))) (declaim (ftype (function (t) function) to-function)) (defun to-function (fn) (etypecase fn (function fn) (symbol (symbol-function fn)) ((cons (eql setf) (cons symbol null)) (fdefinition fn)))) ;;; 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 equalpt-or-report (x y) "Like EQUALPT, but return either T or a list of the arguments." (or (equalpt x y) (list x y))) (defun string=t (x y) (notnot-mv (string= 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 <=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)) (when (symbolp fn) (assert (fboundp fn)) (setf fn (symbol-function (the symbol fn)))) (let ((a (funcall (the function fn) n))) (declare (type (array * *) a)) (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 (regression-test::my-aref a1) (regression-test::my-aref a2)) (let ((ad (array-dimensions a1))) (and (equal ad (array-dimensions a2)) (locally (declare (type (array * *) a1 a2)) (if (= (array-rank a1) 1) (let ((as (first ad))) (loop for i from 0 below as always (equal (regression-test::my-aref a1 i) (regression-test::my-aref a2 i)))) (let ((as (array-total-size a1))) (and (= as (array-total-size a2)) (loop for i from 0 below as always (equal (regression-test::my-row-major-aref a1 i) (regression-test::my-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)))))) (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." (when (symbolp p) (assert (fboundp p)) (setf p (symbol-function p))) (assert (typep p 'function)) (loop for x in *universe* when (block failed (let ((p1 (handler-case (normally (funcall (the function p) x)) (error () (format t "(FUNCALL ~S ~S) failed~%" P x) (return-from failed t)))) (p2 (handler-case (normally (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))) collect x)) ;;; We have a common idiom where a guarded predicate should be ;;; true everywhere (defun check-predicate (predicate &optional guard (universe *universe*)) "Return all elements of UNIVERSE for which the guard (if present) is false and for which PREDICATE is false." (remove-if #'(lambda (e) (or (and guard (funcall guard e)) (funcall predicate e))) universe)) (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 (normally ,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 (normally ,form) (undefined-function () 'undefined-function) (program-error () 'program-error) (package-error () 'package-error) (type-error () 'type-error) (control-error () 'control-error) (parse-error () 'parse-error) (stream-error () 'stream-error) (reader-error () 'reader-error) (file-error () 'file-error) (cell-error () 'cell-error) (division-by-zero () 'division-by-zero) (floating-point-overflow () 'floating-point-overflow) (floating-point-underflow () 'floating-point-underflow) (arithmetic-error () 'arithmetic-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)) ;;; The above is badly designed, since it fails when some signals ;;; may be in more than one class/ (defmacro signals-error (form error-name &key (safety 3) (name nil name-p) (inline nil)) `(handler-bind ((warning #'(lambda (c) (declare (ignore c)) (muffle-warning)))) (proclaim '(optimize (safety 3))) (handler-case (apply #'values nil (multiple-value-list ,(cond (inline form) (regression-test::*compile-tests* `(funcall (compile nil '(lambda () (declare (optimize (safety ,safety))) ,form)))) (t `(eval ',form))))) (,error-name (c) (cond ,@(case error-name (type-error `(((typep (type-error-datum c) (type-error-expected-type c)) (values nil (list (list 'typep (list 'quote (type-error-datum c)) (list 'quote (type-error-expected-type c))) "==> true"))))) ((undefined-function unbound-variable) (and name-p `(((not (eq (cell-error-name c) ',name)) (values nil (list 'cell-error-name "==>" (cell-error-name c))))))) ((stream-error end-of-file reader-error) `(((not (streamp (stream-error-stream c))) (values nil (list 'stream-error-stream "==>" (stream-error-stream c)))))) (file-error `(((not (pathnamep (pathname (file-error-pathname c)))) (values nil (list 'file-error-pathname "==>" (file-error-pathname c)))))) (t nil)) (t (printable-p c))))))) (defmacro signals-error-always (form error-name) `(values (signals-error ,form ,error-name) (signals-error ,form ,error-name :safety 0))) (defmacro signals-type-error (var datum-form form &key (safety 3) (inline nil)) (let ((lambda-form `(lambda (,var) (declare (optimize (safety ,safety))) ,form))) `(let ((,var ,datum-form)) (declare (optimize safety)) (handler-bind ((warning #'(lambda (c) (declare (ignore c)) (muffle-warning)))) ; (proclaim '(optimize (safety 3))) (handler-case (apply #'values nil (multiple-value-list (funcall ,(cond (inline `(function ,lambda-form)) (regression-test::*compile-tests* `(compile nil ',lambda-form)) (t `(eval ',lambda-form))) ,var))) (type-error (c) (let ((datum (type-error-datum c)) (expected-type (type-error-expected-type c))) (cond ((not (eql ,var datum)) (list :datum-mismatch ,var datum)) ((typep datum expected-type) (list :is-typep datum expected-type)) (t (printable-p c)))))))))) (declaim (special *mini-universe*)) (defun check-type-error* (pred-fn guard-fn &optional (universe *mini-universe*)) "Check that for all elements in some set, either guard-fn is true or pred-fn signals a type error." (let (val) (loop for e in universe unless (or (funcall guard-fn e) (equal (setf val (multiple-value-list (signals-type-error x e (funcall pred-fn x) :inline t))) '(t))) collect (list e val)))) (defmacro check-type-error (&body args) `(locally (declare (optimize safety)) (check-type-error* ,@args))) (defun printable-p (obj) "Returns T iff obj can be printed to a string." (with-standard-io-syntax (let ((*print-readably* nil) (*print-escape* nil)) (declare (optimize safety)) (handler-case (and (stringp (write-to-string obj)) t) (condition (c) (declare (ignore c)) nil))))) ;;; ;;; 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)))))) ;; (declaim (ftype (function (&rest function) (values function &optional)) ;; compose)) (defun compose (&rest fns) (let ((rfns (reverse fns))) #'(lambda (x) (loop for f in rfns do (setf x (funcall (the function 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 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+ (coerce "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789~!@#$%^&*()_+|\\=-`{}[]:\";'<>?,./ " 'simple-base-string)) (defparameter +base-chars+ #.(coerce (concatenate 'string "abcdefghijklmnopqrstuvwxyz" "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "0123456789" "<,>.?/\"':;[{]}~`!@#$%^&*()_-+= \\|") 'simple-base-string)) (declaim (type simple-base-string +base-chars+)) (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+ (coerce "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" 'simple-base-string)) (declaim (type simple-base-string +alpha-chars+ +lower-case-chars+ +upper-case-chars+ +alphanumeric-chars+ +extended-digit-chars+ +standard-chars+)) (defparameter +code-chars+ (coerce (loop for i from 0 below 256 for c = (code-char i) when c collect c) 'simple-string)) (declaim (type simple-string +code-chars+)) (defparameter +rev-code-chars+ (reverse +code-chars+)) ;;; Used in checking for continuable errors (defun has-non-abort-restart (c) (throw 'handled (if (position 'abort (the list (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 even-size-p (a) (some #'evenp (array-dimensions a))) (defun safe-elt (x n) (classify-error* (elt x n))) (defmacro defstruct* (&body args) `(eval-when (:load-toplevel :compile-toplevel :execute) (handler-case (eval '(defstruct ,@args)) (serious-condition () nil)))) (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)))) #-(or allegro openmcl lispworks) (defun delete-all-versions (pathspec) "Replace the versions field of the pathname specified by pathspec with :wild, and delete all the files this refers to." (let* ((wild-pathname (make-pathname :version :wild :defaults (pathname pathspec))) (truenames (directory wild-pathname))) (mapc #'delete-file truenames))) ;;; This is a hack to get around an ACL bug; OpenMCL also apparently ;;; needs it #+(or allegro openmcl lispworks) (defun delete-all-versions (pathspec) (when (probe-file pathspec) (delete-file pathspec))) (defconstant +fail-count-limit+ 20) (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 collect-properties (plist prop) "Collect all the properties in plist for a property prop." (loop for e on plist by #'cddr when (eql (car e) prop) collect (cadr e))) (defmacro def-macro-test (test-name macro-form) (let ((macro-name (car macro-form))) (assert (symbolp macro-name)) `(deftest ,test-name (values (signals-error (funcall (macro-function ',macro-name)) program-error) (signals-error (funcall (macro-function ',macro-name) ',macro-form) program-error) (signals-error (funcall (macro-function ',macro-name) ',macro-form nil nil) program-error)) t t t))) (defun typep* (element type) (not (not (typep element type)))) (defun applyf (fn &rest args) (etypecase fn (symbol #'(lambda (&rest more-args) (apply (the symbol fn) (append args more-args)))) (function #'(lambda (&rest more-args) (apply (the function fn) (append args more-args)))))) (defun slot-boundp* (object slot) (notnot (slot-boundp object slot))) (defun slot-exists-p* (object slot) (notnot (slot-exists-p object slot))) (defun map-slot-boundp* (c slots) (mapcar (applyf #'slot-boundp c) slots)) (defun map-slot-exists-p* (c slots) (mapcar (applyf #'slot-exists-p* c) slots)) (defun map-slot-value (c slots) (mapcar (applyf #'slot-value c) slots)) (defun map-typep* (object types) (mapcar (applyf #'typep* object) types)) (defun slot-value-or-nil (object slot-name) (and (slot-exists-p object slot-name) (slot-boundp object slot-name) (slot-value object slot-name))) (defun is-noncontiguous-sublist-of (list1 list2) (loop for x in list1 do (loop when (null list2) do (return-from is-noncontiguous-sublist-of nil) when (eql x (pop list2)) do (return)) finally (return t))) ;;; This defines a new metaclass to allow us to get around ;;; the restriction in section 11.1.2.1.2, bullet 19 in some ;;; object system tests ;;; (when (typep (find-class 'standard-class) 'standard-class) ;;; (defclass substandard-class (standard-class) ()) ;;; (defparameter *can-define-metaclasses* t)) ;;; Macro for testing that something is undefined but 'harmless' (defmacro defharmless (name form) `(deftest ,name (block done (let ((*debugger-hook* #'(lambda (&rest args) (declare (ignore args)) (return-from done :good)))) (handler-case (unwind-protect (eval ',form) (return-from done :good)) (condition () :good)))) :good)) (defun rational-safely (x) "Rational a floating point number, making sure the rational number isn't 'too big'. This is important in implementations such as clisp where the floating bounds can be very large." (assert (floatp x)) (multiple-value-bind (significand exponent sign) (integer-decode-float x) (let ((limit 1000) (radix (float-radix x))) (cond ((< exponent (- limit)) (* significand (expt radix (- limit)) sign)) ((> exponent limit) (* significand (expt radix limit) sign)) (t (rational x)))))) (declaim (special *similarity-list*)) (defun is-similar (x y) (let ((*similarity-list* nil)) (is-similar* x y))) (defgeneric is-similar* (x y)) (defmethod is-similar* ((x number) (y number)) (and (eq (class-of x) (class-of y)) (= x y) t)) (defmethod is-similar* ((x character) (y character)) (and (char= x y) t)) (defmethod is-similar* ((x symbol) (y symbol)) (if (null (symbol-package x)) (and (null (symbol-package y)) (is-similar* (symbol-name x) (symbol-name y))) ;; I think the requirements for interned symbols in ;; 3.2.4.2.2 boils down to EQ after the symbols are in the lisp (eq x y)) t) (defmethod is-similar* ((x random-state) (y random-state)) (let ((copy-of-x (make-random-state x)) (copy-of-y (make-random-state y)) (bound (1- (ash 1 24)))) (and ;; Try 50 values, and assume the random state are the same ;; if all the values are the same. Assuming the RNG is not ;; very pathological, this should be acceptable. (loop repeat 50 always (eql (random bound copy-of-x) (random bound copy-of-y))) t))) (defmethod is-similar* ((x cons) (y cons)) (or (and (eq x y) t) (and (loop for (x2 . y2) in *similarity-list* thereis (and (eq x x2) (eq y y2))) t) (let ((*similarity-list* (cons (cons x y) *similarity-list*))) (and (is-similar* (car x) (car y)) ;; If this causes stack problems, ;; convert to a loop (is-similar* (cdr x) (cdr y)))))) (defmethod is-similar* ((x vector) (y vector)) (or (and (eq x y) t) (and (or (not (typep x 'simple-array)) (typep x 'simple-array)) (= (length x) (length y)) (is-similar* (array-element-type x) (array-element-type y)) (loop for i below (length x) always (is-similar* (aref x i) (aref y i))) t))) (defmethod is-similar* ((x array) (y array)) (or (and (eq x y) t) (and (or (not (typep x 'simple-array)) (typep x 'simple-array)) (= (array-rank x) (array-rank y)) (equal (array-dimensions x) (array-dimensions y)) (is-similar* (array-element-type x) (array-element-type y)) (let ((*similarity-list* (cons (cons x y) *similarity-list*))) (loop for i below (array-total-size x) always (is-similar* (row-major-aref x i) (row-major-aref y i)))) t))) (defmethod is-similar* ((x hash-table) (y hash-table)) ;; FIXME Add similarity check for hash tables (error "Sorry, we're not computing this yet.")) (defmethod is-similar* ((x pathname) (y pathname)) (and (is-similar* (pathname-host x) (pathname-host y)) (is-similar* (pathname-device x) (pathname-device y)) (is-similar* (pathname-directory x) (pathname-directory y)) (is-similar* (pathname-name x) (pathname-name y)) (is-similar* (pathname-type x) (pathname-type y)) (is-similar* (pathname-version x) (pathname-version y)) t)) (defmethod is-similar* ((x t) (y t)) (and (eql x y) t)) (defparameter *initial-print-pprint-dispatch* (if (boundp '*print-pprint-dispatch*) *print-pprint-dispatch* nil)) (defmacro my-with-standard-io-syntax (&body body) `(let ((*package* (find-package "COMMON-LISP-USER")) (*print-array* t) (*print-base* 10) (*print-case* :upcase) (*print-circle* nil) (*print-escape* t) (*print-gensym* t) (*print-length* nil) (*print-level* nil) (*print-lines* nil) (*print-miser-width* nil) (*print-pprint-dispatch* *initial-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 nil))) ,@body)) ;;; Function to produce a non-simple string (defun make-special-string (string &key fill adjust displace base) (let* ((len (length string)) (len2 (if fill (+ len 4) len)) (etype (if base 'base-char 'character))) (if displace (let ((s0 (make-array (+ len2 5) :initial-contents (concatenate 'string (make-string 2 :initial-element #\X) string (make-string (if fill 7 3) :initial-element #\Y)) :element-type etype))) (make-array len2 :element-type etype :adjustable adjust :fill-pointer (if fill len nil) :displaced-to s0 :displaced-index-offset 2)) (make-array len2 :element-type etype :initial-contents (if fill (concatenate 'string string "ZZZZ") string) :fill-pointer (if fill len nil) :adjustable adjust)))) (defmacro do-special-strings ((var string-form &optional ret-form) &body forms) (let ((string (gensym)) (fill (gensym "FILL")) (adjust (gensym "ADJUST")) (base (gensym "BASE")) (displace (gensym "DISPLACE"))) `(let ((,string ,string-form)) (dolist (,fill '(nil t) ,ret-form) (dolist (,adjust '(nil t)) (dolist (,base '(nil t)) (dolist (,displace '(nil t)) (let ((,var (make-special-string ,string :fill ,fill :adjust ,adjust :base ,base :displace ,displace))) ,@forms)))))))) (defun make-special-integer-vector (contents &key fill adjust displace (etype 'integer)) (let* ((len (length contents)) (min (reduce #'min contents)) (max (reduce #'max contents)) (len2 (if fill (+ len 4) len))) (unless (and (typep min etype) (typep max etype)) (setq etype `(integer ,min ,max))) (if displace (let ((s0 (make-array (+ len2 5) :initial-contents (concatenate 'list (make-list 2 :initial-element (if (typep 0 etype) 0 min)) contents (make-list (if fill 7 3) :initial-element (if (typep 1 etype) 1 max))) :element-type etype))) (make-array len2 :element-type etype :adjustable adjust :fill-pointer (if fill len nil) :displaced-to s0 :displaced-index-offset 2)) (make-array len2 :element-type etype :initial-contents (if fill (concatenate 'list contents (make-list 4 :initial-element (if (typep 2 etype) 2 (floor (+ min max) 2)))) contents) :fill-pointer (if fill len nil) :adjustable adjust)))) (defmacro do-special-integer-vectors ((var vec-form &optional ret-form) &body forms) (let ((vector (gensym)) (fill (gensym "FILL")) (adjust (gensym "ADJUST")) (etype (gensym "ETYPE")) (displace (gensym "DISPLACE"))) `(let ((,vector ,vec-form)) (dolist (,fill '(nil t) ,ret-form) (dolist (,adjust '(nil t)) (dolist (,etype ',(append (loop for i from 1 to 32 collect `(unsigned-byte ,i)) (loop for i from 2 to 32 collect `(signed-byte ,i)) '(integer))) (dolist (,displace '(nil t)) (let ((,var (make-special-integer-vector ,vector :fill ,fill :adjust ,adjust :etype ,etype :displace ,displace))) ,@forms)))))))) ;;; Return T if arg X is a string designator in this implementation (defun string-designator-p (x) (handler-case (progn (string x) t) (error nil))) ;;; Approximate comparison of numbers #| (defun approx= (x y) (let ((eps 1.0d-4)) (<= (abs (- x y)) (* eps (max (abs x) (abs y)))))) |# ;;; Approximate equality function (defun approx= (x y &optional (eps (epsilon x))) (<= (abs (/ (- x y) (max (abs x) 1))) eps)) (defun epsilon (number) (etypecase number (complex (* 2 (epsilon (realpart number)))) ;; crude (short-float short-float-epsilon) (single-float single-float-epsilon) (double-float double-float-epsilon) (long-float long-float-epsilon) (rational 0))) (defun negative-epsilon (number) (etypecase number (complex (* 2 (negative-epsilon (realpart number)))) ;; crude (short-float short-float-negative-epsilon) (single-float single-float-negative-epsilon) (double-float double-float-negative-epsilon) (long-float long-float-negative-epsilon) (rational 0))) (defun sequencep (x) (typep x 'sequence)) (defun typef (type) #'(lambda (x) (typep x type))) (defun package-designator-p (x) "TRUE if x could be a package designator. The package need not actually exist." (or (packagep x) (handler-case (and (locally (declare (optimize safety)) (string x)) t) (type-error () nil)))) (defmacro def-fold-test (name form) "Create a test that FORM, which should produce a fresh value, does not improperly introduce sharing during constant folding." `(deftest ,name (flet ((%f () (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0) (debug 0))) ,form)) (eq (%f) (%f))) nil)) ;;; Macro used in tests of environments in system macros ;;; This was inspired by a bug in ACL 8.0 beta where CONSTANTP ;;; was being called in some system macros without the proper ;;; environment argument (defmacro expand-in-current-env (macro-form &environment env) (macroexpand macro-form env)) gcl27-2.7.0/ansi-tests/append.lsp000066400000000000000000000037171454061450500165330ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:36:46 2003 ;;;; Contains: Tests of APPEND (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) ;;; Test suggested by Peter Graves (deftest append.7 (let ((x (list 'a 'b 'c 'd))) (eq (append x nil) x)) nil) ;;; Compiler macro expansion in correct env (deftest append.8 (macrolet ((%m (z) z)) (append (expand-in-current-env (%m '(a b c))))) (a b c)) (deftest append.9 (macrolet ((%m (z) z)) (append (expand-in-current-env (%m (list 1 2 3))) (list 4 5 6))) (1 2 3 4 5 6)) (deftest append.10 (macrolet ((%m (z) z)) (append (list 1 2 3) (expand-in-current-env (%m (list 4 5 6))))) (1 2 3 4 5 6)) ;;; Order of evaluation tests (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) (def-fold-test append.fold.1 (append '(a b c) nil)) (def-fold-test append.fold.2 (append nil '(x) nil)) ;;; Error tests (deftest append.error.1 (signals-error (append '(a . b) '(z)) type-error) t) (deftest append.error.2 (signals-error (append '(x y z) '(a . b) '(z)) type-error) t) gcl27-2.7.0/ansi-tests/apply.lsp000066400000000000000000000026471454061450500164120ustar00rootroot00000000000000;-*- 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 (signals-error (apply) program-error) t) (deftest apply.error.2 (signals-error (apply #'cons) program-error) t) (deftest apply.error.3 (signals-error (apply #'cons nil) program-error) t) (deftest apply.error.4 (signals-error (apply #'cons (list 1 2 3)) program-error) t) ;;; 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.6 (macrolet ((%m (z) z)) (apply (expand-in-current-env (%m 'cons)) 1 2 nil)) (1 . 2)) (deftest apply.7 (macrolet ((%m (z) z)) (apply #'cons (expand-in-current-env (%m 1)) '(2))) (1 . 2)) (deftest apply.8 (macrolet ((%m (z) z)) (apply #'cons (expand-in-current-env (%m '(1 2))))) (1 . 2)) (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) gcl27-2.7.0/ansi-tests/apropos-list.lsp000066400000000000000000000047161454061450500177200ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Dec 14 06:21:45 2004 ;;;; Contains: Tests of APROPOS-LIST (in-package :cl-test) (deftest apropos-list.1 (let ((pkg "CL-TEST-APROPOS-LIST-PACKAGE")) (safely-delete-package pkg) (unwind-protect (progn (eval `(defpackage ,pkg (:use))) (let* ((sym (intern "FOO" pkg))) (loop for p in (list pkg (find-package pkg) (make-symbol pkg)) nconc (loop for string-designator in '("F" "O" #\F #\O "" "FOO" "FO" "OO" :|F| :|FO| :|FOO| :|O| :|OO|) for result = (apropos-list string-designator p) unless (equal result (list sym)) collect (list string-designator result))))) (safely-delete-package pkg))) nil) (deftest apropos-list.2 (let ((pkg #\A)) (safely-delete-package pkg) (unwind-protect (progn (eval `(defpackage ,pkg (:use))) (let* ((sym (intern "FOO" pkg))) (loop for string-designator in '("F" "O" #\F #\O "" "FOO" "FO" "OO" :|F| :|FO| :|FOO| :|O| :|OO|) for result = (apropos-list string-designator pkg) unless (equal result (list sym)) collect (list string-designator result)))) (safely-delete-package pkg))) nil) (deftest apropos-list.3 (let ((pkg "CL-TEST-APROPOS-LIST-PACKAGE")) (safely-delete-package pkg) (unwind-protect (progn (eval `(defpackage ,pkg (:use))) (intern "FOO" pkg) (apropos-list "X" pkg)) (safely-delete-package pkg))) nil) (deftest apropos-list.4 (let ((sym :|X|) (symbols (apropos-list "X"))) (notnot (member sym symbols))) t) (deftest apropos-list.5 (let ((sym :|X|) (symbols (apropos-list '#:|X|))) (notnot (member sym symbols))) t) (deftest apropos-list.6 (let ((sym :|X|) (symbols (apropos-list #\X))) (notnot (member sym symbols))) t) (deftest apropos-list.7 (let ((sym :|X|) (symbols (apropos-list "X" nil))) (notnot (member sym symbols))) t) (deftest apropos-list.8 (let ((*package* (find-package "COMMON-LISP"))) (macrolet ((%m (z) z)) (intersection '(car) (apropos-list (expand-in-current-env (%m "CAR")))))) (car)) (deftest apropos-list.9 (macrolet ((%m (z) z)) (intersection '(car) (apropos-list "CAR" (expand-in-current-env (%m (find-package "COMMON-LISP")))))) (car)) ;;; Error tests (deftest apropos-list.error.1 (signals-error (apropos-list) program-error) t) (deftest apropos-list.error.2 (signals-error (apropos-list "X" (find-package "CL-TEST") nil) program-error) t) gcl27-2.7.0/ansi-tests/apropos.lsp000066400000000000000000000054011454061450500167370ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Dec 12 16:17:47 2004 ;;;; Contains: Tests for APROPOS (in-package :cl-test) (deftest apropos.1 (loop for n from 10 for x = (coerce (loop repeat n collect (random-from-seq +standard-chars+)) 'string) unless (apropos-list x) return (with-output-to-string (*standard-output*) (assert (null (multiple-value-list (apropos x)))))) "") (deftest apropos.2 (let ((s (with-output-to-string (*standard-output*) (assert (null (multiple-value-list (apropos "CAR"))))))) (notnot (search "CAR" s :test #'string-equal))) t) (deftest apropos.3 (let ((s (with-output-to-string (*standard-output*) (assert (null (multiple-value-list (apropos "CAR" (find-package "CL")))))))) (notnot (search "CAR" s :test #'string-equal))) t) (deftest apropos.4 (let ((result nil)) (do-special-strings (s "CAR" t) (setq result (with-output-to-string (*standard-output*) (assert (null (multiple-value-list (apropos s)))))) (assert (search "CAR" result :test #'string-equal)))) t) (deftest apropos.5 (let ((result nil) (pkg (find-package "COMMON-LISP"))) (do-special-strings (s "APROPOS" t) (setq result (with-output-to-string (*standard-output*) (assert (null (multiple-value-list (apropos s pkg)))))) (assert (search "APROPOS" result :test #'string-equal)))) t) (deftest apropos.6 (let ((s (with-output-to-string (*standard-output*) (assert (null (multiple-value-list (apropos "CAR" "CL"))))))) (notnot (search "CAR" s :test #'string-equal))) t) (deftest apropos.7 (let ((s (with-output-to-string (*standard-output*) (assert (null (multiple-value-list (apropos "CAR" :|CL|))))))) (notnot (search "CAR" s :test #'string-equal))) t) (deftest apropos.8 (let ((s (with-output-to-string (*standard-output*) (assert (null (multiple-value-list (apropos "CAR" nil))))))) (notnot (search "CAR" s :test #'string-equal))) t) (deftest apropos.9 (macrolet ((%m (z) z)) (let ((s (with-output-to-string (*standard-output*) (assert (null (multiple-value-list (apropos (expand-in-current-env (%m "CAR"))))))))) (notnot (search "CAR" s :test #'string-equal)))) t) (deftest apropos.10 (macrolet ((%m (z) z)) (let ((s (with-output-to-string (*standard-output*) (assert (null (multiple-value-list (apropos "CAR" (expand-in-current-env (%m nil))))))))) (notnot (search "CAR" s :test #'string-equal)))) t) ;;; Error tests (deftest apropos.error.1 (signals-error (apropos) program-error) t) (deftest apropos.error.2 (signals-error (apropos "SJLJALKSJDKLJASKLDJKLAJDLKJA" (find-package "CL") nil) program-error) t) gcl27-2.7.0/ansi-tests/aref.lsp000066400000000000000000000065351454061450500162020ustar00rootroot00000000000000;-*- 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.special-integer.1 (do-special-integer-vectors (v #(1 1 0 1 0 1) nil) (assert (= (aref v 0) 1)) (assert (= (aref v 1) 1)) (assert (= (aref v 2) 0)) (assert (= (aref v 3) 1)) (assert (= (aref v 4) 0)) (assert (= (aref v 5) 1))) nil) (deftest aref.special-strings.1 (do-special-strings (s "ABCDE" nil) (assert (eql (aref s 0) #\A)) (assert (eql (aref s 1) #\B)) (assert (eql (aref s 2) #\C)) (assert (eql (aref s 3) #\D)) (assert (eql (aref s 4) #\E))) nil) ;;; Error tests (deftest aref.error.1 (signals-error (aref) program-error) t) (deftest aref.error.2 (signals-error (funcall #'aref) program-error) t) gcl27-2.7.0/ansi-tests/arithmetic-error.lsp000066400000000000000000000037131454061450500205400ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Contains: Tests of ARITHMETIC-ERROR condition and associated accessors (in-package :cl-test) (deftest arithmethic-error.1 (let ((a (make-condition 'arithmetic-error :operation '/ :operands '(0 0)))) (values (notnot (typep a 'arithmetic-error)) (notnot (typep a (find-class 'arithmetic-error))) (multiple-value-list (arithmetic-error-operation a)) (multiple-value-list (arithmetic-error-operands a)))) t t (/) ((0 0))) (deftest arithmethic-error.2 (let ((a (make-condition 'arithmetic-error :operation #'/ :operands '(0 0)))) (values (notnot (typep a 'arithmetic-error)) (notnot (typep a 'error)) (notnot (typep a 'serious-condition)) (notnot (typep a 'condition)) (notnot (typep a (find-class 'arithmetic-error))) (notnot (typep (arithmetic-error-operation a) 'function)) (funcall (arithmetic-error-operation a) 1 2) (multiple-value-list (arithmetic-error-operands a)))) t t t t t t 1/2 ((0 0))) (deftest arithmetic-error.3 (let ((a (make-condition 'arithmetic-error :operation '/ :operands '(0 0)))) (macrolet ((%m (z) z)) (values (arithmetic-error-operation (expand-in-current-env (%m a))) (arithmetic-error-operands (expand-in-current-env (%m a)))))) / (0 0)) ;;; Error tests (deftest arithmetic-error-operation.error.1 (signals-error (arithmetic-error-operation) program-error) t) (deftest arithmetic-error-operation.error.2 (signals-error (arithmetic-error-operation (make-condition 'arithmetic-error :operation '/ :operands '(1 0)) nil) program-error) t) (deftest arithmetic-error-operands.error.1 (signals-error (arithmetic-error-operands) program-error) t) (deftest arithmetic-error-operands.error.2 (signals-error (arithmetic-error-operands (make-condition 'arithmetic-error :operation '/ :operands '(1 0)) nil) program-error) t) gcl27-2.7.0/ansi-tests/array-as-class.lsp000066400000000000000000000025001454061450500200730ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/array-aux.lsp000066400000000000000000000151611454061450500171710ustar00rootroot00000000000000;-*- 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)))) gcl27-2.7.0/ansi-tests/array-dimension.lsp000066400000000000000000000030421454061450500203540ustar00rootroot00000000000000;-*- 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.7 (macrolet ((%m (z) z)) (array-dimension (expand-in-current-env (%m "abc")) 0)) 3) (deftest array-dimension.8 (macrolet ((%m (z) z)) (array-dimension #2a((a b)(c d)(e f)) (expand-in-current-env (%m 0)))) 3) (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 (signals-error (array-dimension) program-error) t) (deftest array-dimension.error.2 (signals-error (array-dimension #(a b c)) program-error) t) (deftest array-dimension.error.3 (signals-error (array-dimension #(a b c) 0 nil) program-error) t) gcl27-2.7.0/ansi-tests/array-dimensions.lsp000066400000000000000000000027341454061450500205460ustar00rootroot00000000000000;-*- 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) (deftest array-dimensions.8 (macrolet ((%m (z) z)) (array-dimensions (expand-in-current-env (%m #2a((a b)(c d)(e f)))))) (3 2)) ;;; Error tests (deftest array-dimensions.error.1 (signals-error (array-dimensions) program-error) t) (deftest array-dimensions.error.2 (signals-error (array-dimensions #(a b c) nil) program-error) t) (deftest array-dimensions.error.3 (check-type-error #'array-dimensions #'arrayp) nil) (deftest array-dimensions.error.4 (signals-type-error x nil (array-dimensions x)) t) (deftest array-dimensions.error.5 (signals-error (locally (array-dimensions nil)) type-error) t) gcl27-2.7.0/ansi-tests/array-displacement.lsp000066400000000000000000000074621454061450500210510ustar00rootroot00000000000000;-*- 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.15 (let* ((a (make-array '(10) :initial-contents '(a b c d e f g h i j))) (b (make-array '(5) :displaced-to a :displaced-index-offset 2))) (macrolet ((%m (z) z)) (multiple-value-bind (x y) (array-displacement (expand-in-current-env (%m b))) (values (eqlt x a) y)))) t 2) ;;; FIXME: Add tests for other kinds of specialized arrays ;;; (character, other integer types, float types, complex types) (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 (signals-error (array-displacement) program-error) t) (deftest array-displacement.error.2 (signals-error (array-displacement #(a b c) nil) program-error) t) (deftest array-displacement.error.3 (check-type-error #'array-displacement #'arrayp) nil) (deftest array-displacement.error.4 (signals-type-error x nil (array-displacement x)) t) gcl27-2.7.0/ansi-tests/array-element-type.lsp000066400000000000000000000015451454061450500210050ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Contains: Tests of the function ARRAY-ELEMENT-TYPE (in-package :cl-test) ;;; Mosts tests are in other files, incidental to testing of ;;; other things (deftest array-element-type.1 (macrolet ((%m (z) z)) (notnot (array-element-type (expand-in-current-env (%m #(a b c)))))) t) (deftest array-element-type.order.1 (let ((i 0)) (array-element-type (progn (incf i) #(a b c))) i) 1) ;;; Error tests (deftest array-element-type.error.1 (signals-error (array-element-type) program-error) t) (deftest array-element-type.error.2 (signals-error (array-element-type #(a b c) nil) program-error) t) (deftest array-element-type.error.3 (check-type-error #'array-element-type #'arrayp) nil) (deftest array-element-type.error.4 (signals-type-error x nil (array-element-type x)) t) gcl27-2.7.0/ansi-tests/array-has-fill-pointer-p.lsp000066400000000000000000000024041454061450500220020ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Contains: Tests of the function ARRAY-HAS-FILL-POINTER-P (in-package :cl-test) ;;; Many tests are in other files, incidental to testing of ;;; other things (deftest array-has-fill-pointer-p.1 (array-has-fill-pointer-p #0a1) nil) (deftest array-has-fill-pointer-p.2 (array-has-fill-pointer-p #2a((a b)(c d))) nil) (deftest array-has-fill-pointer-p.3 (array-has-fill-pointer-p #3a(((a)))) nil) (deftest array-has-fill-pointer-p.4 (array-has-fill-pointer-p #4a((((a))))) nil) (deftest array-has-fill-pointer-p.5 (macrolet ((%m (z) z)) (array-has-fill-pointer-p (expand-in-current-env (%m #2a((a b)(c d)))))) nil) (deftest array-has-fill-pointer-p.order.1 (let ((i 0)) (array-has-fill-pointer-p (progn (incf i) #(a b c))) i) 1) ;;; Error tests (deftest array-has-fill-pointer-p.error.1 (signals-error (array-has-fill-pointer-p) program-error) t) (deftest array-has-fill-pointer-p.error.2 (signals-error (array-has-fill-pointer-p #(a b c) nil) program-error) t) (deftest array-has-fill-pointer-p.error.3 (check-type-error #'array-has-fill-pointer-p #'arrayp) nil) (deftest array-has-fill-pointer-p.error.4 (signals-type-error x nil (array-has-fill-pointer-p x)) t) gcl27-2.7.0/ansi-tests/array-in-bounds-p.lsp000066400000000000000000000105101454061450500205200ustar00rootroot00000000000000;-*- 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) ;;; Macro expansion (deftest array-in-bounds-p.24 (macrolet ((%m (z) z)) (array-in-bounds-p (expand-in-current-env (%m #(a b))) 3)) nil) (deftest array-in-bounds-p.25 (macrolet ((%m (z) z)) (array-in-bounds-p #(a b) (expand-in-current-env (%m 2)))) 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 (signals-error (array-in-bounds-p) program-error) t) gcl27-2.7.0/ansi-tests/array-misc.lsp000066400000000000000000000012031454061450500173170ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/array-rank.lsp000066400000000000000000000020271454061450500173240ustar00rootroot00000000000000;-*- 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 (check-predicate #'(lambda (e) (or (not (typep e 'vector)) (eql (array-rank e) 1)))) nil) (deftest array-rank.3 (macrolet ((%m (z) z)) (array-rank (expand-in-current-env (%m "abc")))) 1) (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 (signals-error (array-rank) program-error) t) (deftest array-rank.error.2 (signals-error (array-rank #(a b c) nil) program-error) t) (deftest array-rank.error.3 (check-type-error #'array-rank #'arrayp) nil) (deftest array-rank.error.4 (signals-error (array-rank nil) type-error) t) (deftest array-rank.error.5 (signals-type-error x nil (locally (array-rank x) t)) t) gcl27-2.7.0/ansi-tests/array-row-major-index.lsp000066400000000000000000000022351454061450500214140ustar00rootroot00000000000000;-*- 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.4 (macrolet ((%m (z) z)) (array-row-major-index (expand-in-current-env (%m #(a b c))) 1)) 1) (deftest array-row-major-index.5 (macrolet ((%m (z) z)) (array-row-major-index #(a b c) (expand-in-current-env (%m 1)))) 1) (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 (signals-error (array-row-major-index) program-error) t) gcl27-2.7.0/ansi-tests/array-t.lsp000066400000000000000000000107611454061450500166400ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/array-total-size.lsp000066400000000000000000000024461454061450500204710ustar00rootroot00000000000000;-*- 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.6 (macrolet ((%m (z) z)) (array-total-size (expand-in-current-env (%m #(a b c))))) 3) (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 (signals-error (array-total-size) program-error) t) (deftest array-total-size.error.2 (signals-error (array-total-size #(a b c) nil) program-error) t) (deftest array-total-size.error.3 (check-type-error #'array-total-size #'arrayp) nil) (deftest array-total-size.error.4 (signals-error (array-total-size 0) type-error) t) (deftest array-total-size.error.5 (signals-type-error x 0 (locally (array-total-size x) t)) t) gcl27-2.7.0/ansi-tests/array.lsp000066400000000000000000000123201454061450500163700ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/arrayp.lsp000066400000000000000000000016301454061450500165520ustar00rootroot00000000000000;-*- 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 (check-type-predicate #'arrayp 'array) nil) (deftest arrayp.7 (macrolet ((%m (z) z)) (arrayp (expand-in-current-env (%m 0)))) 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 (signals-error (arrayp) program-error) t) (deftest arrayp.error.2 (signals-error (arrayp #(a b c) nil) program-error) t) gcl27-2.7.0/ansi-tests/ash.lsp000066400000000000000000000030111454061450500160220ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 7 08:43:03 2003 ;;;; Contains: Tests of ASH (in-package :cl-test) ;;; Error tests (deftest ash.error.1 (signals-error (ash) program-error) t) (deftest ash.error.2 (signals-error (ash 1 1 1) program-error) t) (deftest ash.error.3 (signals-error (ash 1 1 nil) program-error) t) (deftest ash.error.4 (check-type-error #'(lambda (x) (ash x 0)) #'integerp) nil) (deftest ash.error.5 (check-type-error #'(lambda (x) (ash 0 x)) #'integerp) nil) ;;; Non-error tests (deftest ash.1 (loop for x in *integers* always (eql (ash x 0) x)) t) (deftest ash.2 (loop for i = (random-fixnum) for s = (random-from-interval 40) for ishifted = (ash i s) repeat 1000 always (eql (floor (* i (expt 2 s))) ishifted)) t) (deftest ash.3 (let* ((nbits 100) (bound (expt 2 nbits))) (loop for i = (random-from-interval bound) for s = (random-from-interval (+ nbits 20)) for ishifted = (ash i s) repeat 1000 always (eql (floor (* i (expt 2 s))) ishifted))) t) (deftest ash.4 (loop for i from -1 downto -1000 always (eql (ash i i) -1)) t) (deftest ash.5 (loop for i from 1 to 100 for j = (- (ash 1 i)) always (eql (ash j j) -1)) t) (deftest ash.6 (macrolet ((%m (z) z)) (values (ash (expand-in-current-env (%m 3)) 1) (ash 1 (expand-in-current-env (%m 3))))) 6 8) (deftest ash.order.1 (let ((i 0) x y) (values (ash (progn (setf x (incf i)) 1) (progn (setf y (incf i)) 2)) i x y)) 4 2 1 2) gcl27-2.7.0/ansi-tests/asin.lsp000066400000000000000000000045161454061450500162140ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Feb 11 05:59:43 2004 ;;;; Contains: Tests for ASIN (in-package :cl-test) (deftest asin.1 (loop for i from -1000 to 1000 for rlist = (multiple-value-list (asin i)) for y = (car rlist) always (and (null (cdr rlist)) (numberp y))) t) (deftest asin.2 (loop for type in '(short-float single-float double-float long-float) collect (let ((a (coerce 2000 type)) (b (coerce -1000 type))) (loop for x = (- (random a) b) for rlist = (multiple-value-list (asin x)) for y = (car rlist) repeat 1000 always (and (null (cdr rlist)) (numberp y))))) (t t t t)) (deftest asin.3 (loop for type in '(integer short-float single-float double-float long-float) collect (let ((a (coerce 2000 type)) (b (coerce -1000 type))) (loop for x = (- (random a) b) for rlist = (multiple-value-list (asin (complex 0 x))) for y = (car rlist) repeat 1000 always (and (null (cdr rlist)) (numberp y))))) (t t t t t)) (deftest asin.4 (loop for type in '(integer short-float single-float double-float long-float) collect (let ((a (coerce 2000 type)) (b (coerce -1000 type))) (loop for x1 = (- (random a) b) for x2 = (- (random a) b) for rlist = (multiple-value-list (asin (complex x1 x2))) for y = (car rlist) repeat 1000 always (and (null (cdr rlist)) (numberp y))))) (t t t t t)) (deftest asin.5 (approx= (asin 1) (coerce (/ pi 2) 'single-float)) t) (deftest asin.6 (loop for type in '(single-float short-float double-float long-float) unless (approx= (asin (coerce 1 type)) (coerce (/ pi 2) type)) collect type) nil) (deftest asin.7 (loop for type in '(single-float short-float double-float long-float) unless (approx= (asin (coerce 0 type)) (coerce 0 type)) collect type) nil) (deftest asin.8 (loop for type in '(single-float short-float double-float long-float) unless (approx= (asin (coerce -1 type)) (coerce (/ pi -2) type)) collect type) nil) (deftest asin.9 (macrolet ((%m (z) z)) (asin (expand-in-current-env (%m 0.0)))) 0.0) ;;; FIXME ;;; Add accuracy tests ;;; Error tests (deftest asin.error.1 (signals-error (asin) program-error) t) (deftest asin.error.2 (signals-error (asin 0.0 0.0) program-error) t) (deftest asin.error.3 (check-type-error #'asin #'numberp) nil) gcl27-2.7.0/ansi-tests/asinh.lsp000066400000000000000000000037701454061450500163650ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Feb 11 19:19:02 2004 ;;;; Contains: Tests of ASINH (in-package :cl-test) (deftest asinh.1 (let ((result (asinh 0))) (or (eqlt result 0) (eqlt result 0.0))) t) (deftest asinh.2 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 type) unless (equal (multiple-value-list (asinh zero)) (list zero)) collect type) nil) (deftest asinh.3 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 `(complex ,type)) unless (equal (multiple-value-list (asinh zero)) (list zero)) collect type) nil) (deftest asinh.4 (loop for den = (1+ (random 10000)) for num = (random (* 10 den)) for x = (/ num den) for rlist = (multiple-value-list (asinh x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (numberp y)) collect (list x rlist)) nil) (deftest asinh.5 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x = (- (random (coerce 20 type)) 10) for rlist = (multiple-value-list (asinh x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y type)) collect (list x rlist))) nil) (deftest asinh.6 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x1 = (- (random (coerce 20 type)) 10) for x2 = (- (random (coerce 20 type)) 10) for rlist = (multiple-value-list (asinh (complex x1 x2))) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y `(complex ,type))) collect (list x1 x2 rlist))) nil) (deftest asinh.7 (macrolet ((%m (z) z)) (asinh (expand-in-current-env (%m 0.0)))) 0.0) ;;; FIXME ;;; Add accuracy tests here ;;; Error tests (deftest asinh.error.1 (signals-error (asinh) program-error) t) (deftest asinh.error.2 (signals-error (asinh 1.0 1.0) program-error) t) (deftest asinh.error.3 (check-type-error #'asinh #'numberp) nil) gcl27-2.7.0/ansi-tests/assert.lsp000066400000000000000000000036371454061450500165660ustar00rootroot00000000000000;-*- 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) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest assert.10 (macrolet ((%m (z) z)) (assert (expand-in-current-env (%m t)))) nil) (deftest assert.11 (macrolet ((%m (z) z)) (assert (expand-in-current-env (%m t)) () "Foo!")) nil) gcl27-2.7.0/ansi-tests/assoc-if-not.lsp000066400000000000000000000110721454061450500175570ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:28:37 2003 ;;;; Contains: Tests of ASSOC-IF-NOT (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) ;;; Macro env tests (deftest assoc-if-not.env.1 (macrolet ((%m (z) z)) (let ((alist '((1 . a) (3 . b) (4 . c) (6 . d)))) (values (assoc-if-not (expand-in-current-env (%m 'oddp)) alist) (assoc-if-not (expand-in-current-env (%m #'oddp)) alist) (assoc-if-not 'oddp (expand-in-current-env (%m alist)))))) (4 . c) (4 . c) (4 . c)) (deftest assoc-if-not.env.2 (macrolet ((%m (z) z)) (let ((alist '((1 . a) (3 . b) (4 . c) (6 . d)))) (values (assoc-if-not 'evenp alist (expand-in-current-env (%m :key)) #'1+) (assoc-if-not #'evenp alist :key (expand-in-current-env (%m '1+))) ))) (4 . c) (4 . c)) ;;; Error tests (deftest assoc-if-not.error.1 (signals-error (assoc-if-not) program-error) t) (deftest assoc-if-not.error.2 (signals-error (assoc-if-not #'null) program-error) t) (deftest assoc-if-not.error.3 (signals-error (assoc-if-not #'null nil :bad t) program-error) t) (deftest assoc-if-not.error.4 (signals-error (assoc-if-not #'null nil :key) program-error) t) (deftest assoc-if-not.error.5 (signals-error (assoc-if-not #'null nil 1 1) program-error) t) (deftest assoc-if-not.error.6 (signals-error (assoc-if-not #'null nil :bad t :allow-other-keys nil) program-error) t) (deftest assoc-if-not.error.7 (signals-error (assoc-if-not #'cons '((a b)(c d))) program-error) t) (deftest assoc-if-not.error.8 (signals-error (assoc-if-not #'identity '((a b)(c d)) :key #'cons) program-error) t) (deftest assoc-if-not.error.9 (signals-type-error x 'a (assoc-if-not #'car '((a b)(c d)))) t) (deftest assoc-if-not.error.10 (signals-type-error x 'a (assoc-if-not #'identity '((a b)(c d)) :key #'car)) t) (deftest assoc-if-not.error.11 (signals-error (assoc-if-not #'identity '((a . b) . c)) type-error) t) (deftest assoc-if-not.error.12 (signals-error (assoc-if-not #'identity '((a . b) :bad (c . d))) type-error) t) (deftest assoc-if-not.error.13 (signals-type-error x 'y (assoc-if-not #'identity x)) t) gcl27-2.7.0/ansi-tests/assoc-if.lsp000066400000000000000000000104421454061450500167610ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:27:57 2003 ;;;; Contains: Tests of ASSOC-IF (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) (deftest assoc-if.5 (let () (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)) ;;; Macro env tests (deftest assoc-if.env.1 (macrolet ((%m (z) z)) (let ((alist '((1 . a) (3 . b) (6 . c) (8 . d) (-1 . e)))) (values (assoc-if (expand-in-current-env (%m 'evenp)) alist) (assoc-if (expand-in-current-env (%m #'evenp)) alist) (assoc-if #'evenp (expand-in-current-env (%m alist))) (assoc-if 'oddp alist (expand-in-current-env (%m :key)) '1+) (assoc-if 'oddp alist :key (expand-in-current-env (%m #'1+))) ))) (6 . c) (6 . c) (6 . c) (6 . c) (6 . c)) ;;; Error cases (deftest assoc-if.error.1 (signals-error (assoc-if) program-error) t) (deftest assoc-if.error.2 (signals-error (assoc-if #'null) program-error) t) (deftest assoc-if.error.3 (signals-error (assoc-if #'null nil :bad t) program-error) t) (deftest assoc-if.error.4 (signals-error (assoc-if #'null nil :key) program-error) t) (deftest assoc-if.error.5 (signals-error (assoc-if #'null nil 1 1) program-error) t) (deftest assoc-if.error.6 (signals-error (assoc-if #'null nil :bad t :allow-other-keys nil) program-error) t) (deftest assoc-if.error.7 (signals-error (assoc-if #'cons '((a b)(c d))) program-error) t) (deftest assoc-if.error.8 (signals-error (assoc-if #'identity '((a b)(c d)) :key #'cons) program-error) t) (deftest assoc-if.error.9 (signals-type-error x 'a (assoc-if #'car '((a b)(c d)))) t) (deftest assoc-if.error.10 (signals-type-error x 'a (assoc-if #'identity '((a b)(c d)) :key #'car)) t) (deftest assoc-if.error.11 (signals-error (assoc-if #'null '((a . b) . c)) type-error) t) (deftest assoc-if.error.12 (signals-error (assoc-if #'null '((a . b) :bad (c . d))) type-error) t) (deftest assoc-if.error.13 (signals-type-error x 'y (assoc-if #'null x)) t) gcl27-2.7.0/ansi-tests/assoc.lsp000066400000000000000000000152241454061450500163700ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:27:20 2003 ;;;; Contains: Tests of ASSOC (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) (schar 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 test arguments (deftest assoc.26 (assoc 10 '((1 a) (5 b) (8 c) (11 d) (12 e)) :test #'<) (11 d)) (deftest assoc.27 (assoc 10 '((1 a) (5 b) (8 c) (11 d) (12 e)) :test-not #'>=) (11 d)) ;;; Special cases: the nil key does not match the nil pair (deftest assoc.30 (let () (assoc nil '((a . b) nil (c . d) (nil . e) (nil . f) nil (g . h)))) (nil . e)) (deftest assoc.31 (let () (assoc nil '((a . b) nil (c . d) (nil . e) (nil . f) nil (g . h)) :test #'eq)) (nil . e)) ;;; :test & :test-not together are harmless (defharmless assoc.test-and-test-not.1 (assoc 'a '((a . 1) (b . 2)) :test #'eql :test-not #'eql)) (defharmless assoc.test-and-test-not.2 (assoc 'a '((a . 1) (b . 2)) :test-not #'eql :test #'eql)) ;;; 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 (signals-error (assoc) program-error) t) (deftest assoc.error.2 (signals-error (assoc nil) program-error) t) (deftest assoc.error.3 (signals-error (assoc nil nil :bad t) program-error) t) (deftest assoc.error.4 (signals-error (assoc nil nil :key) program-error) t) (deftest assoc.error.5 (signals-error (assoc nil nil 1 1) program-error) t) (deftest assoc.error.6 (signals-error (assoc nil nil :bad t :allow-other-keys nil) program-error) t) (deftest assoc.error.7 (signals-error (assoc 'a '((a . b)) :test #'identity) program-error) t) (deftest assoc.error.8 (signals-error (assoc 'a '((a . b)) :test-not #'identity) program-error) t) (deftest assoc.error.9 (signals-error (assoc 'a '((a . b)) :key #'cons) program-error) t) (deftest assoc.error.10 (signals-error (assoc 'z '((a . b) . c)) type-error) t) (deftest assoc.error.11 (signals-error (assoc 'z '((a . b) :bad (c . d))) type-error) t) (deftest assoc.error.12 (signals-type-error x 'y (assoc 'x x)) t) gcl27-2.7.0/ansi-tests/atan.lsp000066400000000000000000000073071454061450500162060ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Feb 11 06:01:55 2004 ;;;; Contains: Tests of ATAN (in-package :cl-test) (deftest atan.1 (let ((result (atan 0))) (or (eqlt result 0) (eqlt result 0.0))) t) (deftest atan.2 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 type) unless (eql (atan zero) zero) collect type) nil) (deftest atan.3 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 type) unless (eql (atan zero 1) zero) collect type) nil) (deftest atan.4 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 type) for one = (coerce 1 type) unless (eql (atan 0 one) zero) collect type) nil) (deftest atan.5 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 type) for one = (coerce 1 type) unless (eql (atan zero one) zero) collect type) nil) (deftest atan.6 (loop for type in '(short-float single-float double-float long-float) for a = (coerce 2000 type) for b = (coerce -1000 type) collect (loop for x = (- (random a) b) for rlist = (multiple-value-list (atan x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y type)) collect (list x rlist))) (nil nil nil nil)) (deftest atan.7 (loop for type in '(short-float single-float double-float long-float) for a = (coerce 2000 type) for b = (coerce -1000 type) for zero = (coerce 0 type) collect (loop for x = (- (random a) b) for rlist = (multiple-value-list (atan (complex x zero))) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y `(complex ,type))) collect (list x rlist))) (nil nil nil nil)) (deftest atan.8 (loop for type in '(short-float single-float double-float long-float) for a = (coerce 2000 type) for b = (coerce -1000 type) for zero = (coerce 0 type) collect (loop for x = (- (random a) b) for rlist = (multiple-value-list (atan (complex zero x))) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y `(complex ,type))) collect (list x rlist))) (nil nil nil nil)) (deftest atan.9 (loop for type in '(short-float single-float double-float long-float) for a = (coerce 2000 type) for b = (coerce -1000 type) for zero = (coerce 0 type) collect (loop for x1 = (- (random a) b) for x2 = (- (random a) b) for rlist = (multiple-value-list (atan (complex x1 x2))) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y `(complex ,type))) collect (list x1 x2 rlist))) (nil nil nil nil)) (deftest atan.10 (approx= (atan 1) (coerce (/ pi 4) 'single-float)) t) (deftest atan.11 (loop for type in '(short-float single-float double-float long-float) collect (approx= (atan (coerce 1 type)) (coerce (/ pi 4) type))) (t t t t)) (deftest atan.12 (approx= (atan -1) (coerce (/ pi -4) 'single-float)) t) (deftest atan.13 (loop for type in '(short-float single-float double-float long-float) collect (approx= (atan (coerce -1 type)) (coerce (/ pi -4) type))) (t t t t)) (deftest atan.14 (macrolet ((%m (z) z)) (atan (expand-in-current-env (%m 0.0)))) 0.0) ;;; FIXME ;;; More accuracy tests here ;;; Error tests (deftest atan.error.1 (signals-error (atan) program-error) t) (deftest atan.error.2 (signals-error (atan 1 1 1) program-error) t) (deftest atan.error.3 (check-type-error #'atan #'numberp) nil) (deftest atan.error.4 (check-type-error #'(lambda (x) (atan x 1)) #'realp) nil) (deftest atan.error.5 (check-type-error #'(lambda (x) (atan 1 x)) #'realp) nil) gcl27-2.7.0/ansi-tests/atanh.lsp000066400000000000000000000053101454061450500163460ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Feb 11 19:26:25 2004 ;;;; Contains: Tests of ATANH (in-package :cl-test) (deftest atanh.1 (let ((result (atanh 0))) (or (eqlt result 0) (eqlt result 0.0))) t) (deftest atanh.2 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 type) unless (equal (multiple-value-list (atanh zero)) (list zero)) collect type) nil) (deftest atanh.3 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 `(complex ,type)) unless (equal (multiple-value-list (atanh zero)) (list zero)) collect type) nil) (deftest atanh.4 (loop for den = (1+ (random 10000)) for num = (random den) for x = (/ num den) for rlist = (multiple-value-list (atanh x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (numberp y)) collect (list x rlist)) nil) (deftest atanh.5 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x = (if (eql (random 2) 0) (+ 2 (random (coerce 1000 type))) (- -2 (random (coerce 1000 type)))) for rlist = (multiple-value-list (atanh x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y `(complex ,type))) collect (list x rlist))) nil) (deftest atanh.5a (loop for type in '(short-float single-float double-float long-float) nconc (loop for x = (- (random (coerce 1.9998s0 type)) 0.9999s0) for rlist = (multiple-value-list (atanh x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y type)) collect (list x rlist))) nil) (deftest atanh.6 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x1 = (- (random (coerce 1.9998s0 type)) 0.9999s0) for rlist = (multiple-value-list (atanh (complex x1 0.0s0))) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y `(complex ,type))) collect (list x1 rlist))) nil) (deftest atanh.7 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x1 = (- (random (coerce 1.9998s0 type)) 0.9999s0) for rlist = (multiple-value-list (atanh (complex 0.0s0 x1))) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y `(complex ,type))) collect (list x1 rlist))) nil) (deftest atanh.8 (macrolet ((%m (z) z)) (atanh (expand-in-current-env (%m 0.0)))) 0.0) ;;; FIXME ;;; Add accuracy tests here ;;; Error tests (deftest atanh.error.1 (signals-error (atanh) program-error) t) (deftest atanh.error.2 (signals-error (atanh 1.0 1.0) program-error) t) (deftest atanh.error.3 (check-type-error #'atanh #'numberp) nil) gcl27-2.7.0/ansi-tests/atom-errors.lsp000066400000000000000000000012311454061450500175230ustar00rootroot00000000000000(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))))) gcl27-2.7.0/ansi-tests/atom.lsp000066400000000000000000000011431454061450500162130ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:28:09 2003 ;;;; Contains: Tests of ATOM (in-package :cl-test) ; (compile-and-load "cons-aux.lsp") (deftest atom.1 (loop for x in *universe* unless (if (atom x) (not (consp x)) (consp x)) collect x) nil) (deftest atom.2 (macrolet ((%m (z) z)) (atom (expand-in-current-env (%m 0)))) t) (deftest atom.order.1 (let ((i 0)) (values (atom (progn (incf i) '(a b))) i)) nil 1) (deftest atom.error.1 (signals-error (atom) program-error) t) (deftest atom.error.2 (signals-error (atom 'a 'b) program-error) t) gcl27-2.7.0/ansi-tests/backquote-aux.lsp000066400000000000000000000030411454061450500200230ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Jun 11 08:04:23 2004 ;;;; Contains: Aux. functions associated with backquote tests (in-package :cl-test) ;;; Not yet finished ;;; Create random backquoted forms (defun make-random-backquoted-form (size) (my-with-standard-io-syntax (let ((*print-readably* nil) (*package* (find-package "CL-TEST"))) (read-from-string (concatenate 'string "`" (make-random-backquoted-sequence-string size)))))) (defun make-random-backquoted-sequence-string (size) (case size ((0 1) (make-random-backquoted-string size)) (t (let* ((nelements (1+ (min (random (1- size)) (random (1- size)) 9))) (sizes (random-partition (1- size) nelements)) (substrings (mapcar #'make-random-backquoted-string sizes))) (apply #'concatenate 'string "(" (car substrings) (if nil ; (and (> nelements 1) (coin)) (nconc (loop for s in (cddr substrings) collect " " collect s) (list " . " (cadr substrings) ")")) (nconc (loop for s in (cdr substrings) collect " " collect s) (list ")")))))))) ;;; Create a string that is a backquoted form (defun make-random-backquoted-string (size) (if (<= size 1) (rcase (1 "()") (1 (string (random-from-seq #.(coerce *cl-symbol-names* 'vector)))) (1 (write-to-string (- (random 2001) 1000))) (2 (concatenate 'string "," (string (random-from-seq "ABCDEFGHIJKLMNOPQRSTUVWXYZ")))) ) ;; size > 1 (make-random-backquoted-sequence-string size))) gcl27-2.7.0/ansi-tests/base-string.lsp000066400000000000000000000012261454061450500174730ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 29 17:26:57 2004 ;;;; Contains: Tests associated with BASE-STRING (in-package :cl-test) (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) (deftest base-string.5 :notes (:allow-nil-arrays :nil-vectors-are-strings) (subtypep* '(array nil (*)) 'base-string) nil t) (deftest base-string.6 :notes (:nil-vectors-are-strings) (subtypep* 'string 'base-string) nil t) gcl27-2.7.0/ansi-tests/beyond-ansi/000077500000000000000000000000001454061450500167445ustar00rootroot00000000000000gcl27-2.7.0/ansi-tests/beyond-ansi/README000066400000000000000000000002141454061450500176210ustar00rootroot00000000000000This directory contains tests that go beyond the ANSI CL standard. No conforming implementation is required to be able to pass these tests. gcl27-2.7.0/ansi-tests/beyond-ansi/ba-aux.lsp000066400000000000000000000025371454061450500206500ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon May 30 06:45:08 2005 ;;;; Contains: Aux. files for beyond-ansi tests (in-package :ba-test) (defun function-name-p (x) (or (symbolp x) (and (consp x) (eql (car x) 'setf) (consp (cdr x)) (symbolp (cadr x)) (null (cddr x))))) (defun symbol-or-function-p (x) (or (symbolp x) (and (consp x) (eql (car x) 'function) (consp (cdr x)) (null (cddr x)) (function-name-p (cadr x))))) (defun symbol-or-list-p (x) (or (symbolp x) (listp x))) (defun function-designator-p (x) (or (functionp x) (and (symbolp x) (not (macro-function x)) (not (special-operator-p x))))) (defun type-specifier-p (x) (typep x '(or symbol list class))) (defun causes-error-p (pred formf &key (vals *mini-universe*) (var 'x)) (when (symbolp pred) (assert (fboundp pred)) (setf pred (symbol-function pred))) (loop for x in vals for inner-form = (if (functionp formf) (funcall formf x) (subst `',x var formf)) for form = `(signals-error ,inner-form error) unless (or (funcall pred x) (eval form)) collect x)) (defmacro def-all-error-test (name pred form &rest other-args) `(deftest ,name (causes-error-p ,pred ,form ,@other-args) nil)) (defmacro def-error-test (name form) `(deftest ,name (signals-error ,form error) t)) gcl27-2.7.0/ansi-tests/beyond-ansi/ba-test-package.lsp000066400000000000000000000011151454061450500224120ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 28 06:38:29 2005 ;;;; Contains: Definition of BA-TEST package. (in-package :cl-user) (let* ((name :ba-test) (pkg (find-package name))) (unless pkg (setq pkg (make-package name :use '(:cl :regression-test :cl-test)))) (let ((*package* pkg)) (shadow '(#:handler-case #:handler-bind)) (import '(common-lisp-user::compile-and-load) pkg) (import '(cl-test::*universe* cl-test::*mini-universe*) pkg) ) (let ((s (find-symbol "QUIT" "CL-USER"))) (when s (import s :ba-test)))) gcl27-2.7.0/ansi-tests/beyond-ansi/errors-data-and-control-flow-1.lsp000066400000000000000000000120101454061450500252220ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon May 30 15:38:09 2005 ;;;; Contains: Tests of non-ANSI exceptional situations from CLHS section 5, part 1 (in-package :ba-test) (compile-and-load "ba-aux.lsp") ;;; APPLY (def-all-error-test apply.1 'function-designator-p '(apply x nil)) (def-all-error-test apply.2 'function-designator-p '(apply x '(1 2 3))) (def-error-test apply.3 (apply 'cons . 1)) (def-all-error-test apply.4 'listp '(apply 'cons '1 x)) ;;; DEFUN (def-error-test defun.1 (defun)) (def-error-test defun.2 (defun #.(gensym))) (def-error-test defun.3 (defun . foo)) (def-error-test defun.4 (defun #.(gensym) #.(gensym))) (def-error-test defun.5 (defun #.(gensym) () . foo)) (def-error-test defun.6 (defun #.(gensym) () "foo" "bar" (declare))) (def-error-test defun.7 (defun #.(gensym) () nil (declare))) ;;; FIXME Add lambda list tests ;;; FLET (def-error-test flet.1 (flet . foo)) (def-error-test flet.2 (flet foo)) (def-error-test flet.3 (flet (foo))) (def-error-test flet.4 (flet ((foo)))) (def-error-test flet.5 (flet ((foo . bar)))) (def-error-test flet.6 (flet () . foo)) (def-error-test flet.7 (flet ((foo () . bar)))) (def-error-test flet.8 (flet ((foo z)))) (def-error-test flet.9 (flet ((foo ((x y)))))) (def-all-error-test flet.10 'symbolp #'(lambda (x) (subst x 'x '(flet ((foo (&rest x))))))) (def-all-error-test flet.11 (typef '(or symbol cons)) #'(lambda (x) (subst x 'x '(flet ((foo (&optional x))))))) (def-all-error-test flet.12 (typef '(or symbol cons)) #'(lambda (x) (subst x 'x '(flet ((foo (&key x))))))) (def-error-test flet.13 (flet ((foo (&optional (x . bar)) nil)))) (def-error-test flet.14 (flet ((foo (&optional (x nil . bar)) nil)))) (def-error-test flet.15 (flet ((foo (&optional (x nil x-p . bar)) nil)))) (def-error-test flet.16 (flet ((foo (&optional (x nil x-p nil)) nil)))) (def-error-test flet.17 (flet ((foo (&key (x . bar)) nil)))) (def-error-test flet.18 (flet ((foo (&key (x nil . bar)) nil)))) (def-error-test flet.19 (flet ((foo (&key (x nil x-p . bar)) nil)))) (def-error-test flet.20 (flet ((foo (&key (x nil x-p nil)) nil)))) (def-error-test flet.21 (flet ((foo (&key ((x . bar))) nil)))) (def-error-test flet.22 (flet ((foo (&key ((x y . z))) nil)))) (def-error-test flet.23 (flet ((foo (&key ((x y z))) nil)))) (def-all-error-test flet.24 'symbolp #'(lambda (x) `(flet ((foo (&key ((,x y))) nil))))) (def-all-error-test flet.25 'symbolp #'(lambda (x) `(flet ((foo (&key ((y ,x))) nil))))) (def-error-test flet.26 (flet ((foo (&aux . bar))))) (def-error-test flet.27 (flet ((foo (&aux (x . bar)))))) (def-error-test flet.28 (flet ((foo (&aux (x nil . bar)))))) (def-error-test flet.29 (flet ((foo (&aux (x nil nil)))))) (def-error-test flet.30 (flet ((foo () "x" "y" (declare))) (foo))) (def-error-test flet.31 (flet ((foo () :bad1) (foo () :bad2)) (foo))) ;;; FIXME Add tests for disallowed lambda list keywords ;;; LABELS (def-error-test labels.1 (labels . foo)) (def-error-test labels.2 (labels foo)) (def-error-test labels.3 (labels (foo))) (def-error-test labels.4 (labels ((foo)))) (def-error-test labels.5 (labels ((foo . bar)))) (def-error-test labels.6 (labels () . foo)) (def-error-test labels.7 (labels ((foo () . bar)))) (def-error-test labels.8 (labels ((foo z)))) (def-error-test labels.9 (labels ((foo ((x y)))))) (def-all-error-test labels.10 'symbolp #'(lambda (x) (subst x 'x '(labels ((foo (&rest x))))))) (def-all-error-test labels.11 (typef '(or symbol cons)) #'(lambda (x) (subst x 'x '(labels ((foo (&optional x))))))) (def-all-error-test labels.12 (typef '(or symbol cons)) #'(lambda (x) (subst x 'x '(labels ((foo (&key x))))))) (def-error-test labels.13 (labels ((foo (&optional (x . bar)) nil)))) (def-error-test labels.14 (labels ((foo (&optional (x nil . bar)) nil)))) (def-error-test labels.15 (labels ((foo (&optional (x nil x-p . bar)) nil)))) (def-error-test labels.16 (labels ((foo (&optional (x nil x-p nil)) nil)))) (def-error-test labels.17 (labels ((foo (&key (x . bar)) nil)))) (def-error-test labels.18 (labels ((foo (&key (x nil . bar)) nil)))) (def-error-test labels.19 (labels ((foo (&key (x nil x-p . bar)) nil)))) (def-error-test labels.20 (labels ((foo (&key (x nil x-p nil)) nil)))) (def-error-test labels.21 (labels ((foo (&key ((x . bar))) nil)))) (def-error-test labels.22 (labels ((foo (&key ((x y . z))) nil)))) (def-error-test labels.23 (labels ((foo (&key ((x y z))) nil)))) (def-all-error-test labels.24 'symbolp #'(lambda (x) `(labels ((foo (&key ((,x y))) nil))))) (def-all-error-test labels.25 'symbolp #'(lambda (x) `(labels ((foo (&key ((y ,x))) nil))))) (def-error-test labels.26 (labels ((foo (&aux . bar))))) (def-error-test labels.27 (labels ((foo (&aux (x . bar)))))) (def-error-test labels.28 (labels ((foo (&aux (x nil . bar)))))) (def-error-test labels.29 (labels ((foo (&aux (x nil nil)))))) (def-error-test labels.30 (labels ((foo () "x" "y" (declare))) (foo))) (def-error-test labels.31 (labels ((foo () :bad1) (foo () :bad2)) (foo))) ;;; FIXME Add tests for disallowed lambda list keywords ;;; MACROLET ;;; FIXME: add these gcl27-2.7.0/ansi-tests/beyond-ansi/errors-data-and-control-flow-2.lsp000066400000000000000000000234671454061450500252450ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue May 31 08:08:49 2005 ;;;; Contains: Tests of non-ANSI exceptional situations from CLHS section 5, part 2 (in-package :ba-test) (compile-and-load "ba-aux.lsp") ;;; FUNCALL (def-all-error-test funcall.1 'function-designator-p '(funcall x)) (def-error-test funcall.2 (funcall cons 1 . 2)) ;;; FUNCTION (def-error-test function.1 (function)) (def-error-test function.2 (function . cons)) (def-error-test function.3 (function cons . foo)) (def-error-test function.4 (function cons nil)) (def-all-error-test function.5 'function-name-p '(function x)) (def-all-error-test function.6 (constantly nil) #'(lambda (x) `(function ,x)) :vals cl-test::*cl-macro-symbols*) (def-all-error-test function.7 (constantly nil) #'(lambda (x) `(function ,x)) :vals cl-test::*cl-special-operator-symbols*) (def-error-test function.8 (macrolet ((%m () nil)) #'%m)) ;;; FUNCTION-LAMBDA-EXPRESSION (def-all-error-test function-lambda-expression.1 'functionp '(function-lambda-expression x)) ;;; DEFCONSTANT (def-error-test defconstant.1 (defconstant)) (def-error-test defconstant.2 (defconstant . foo)) (def-error-test defconstant.3 (defconstant #.(gensym))) (def-error-test defconstant.4 (defconstant #.(gensym) . foo)) (def-error-test defconstant.5 (defconstant #.(gensym) nil . foo)) (def-error-test defconstant.6 (defconstant #.(gensym) nil "foo" . bar)) (def-all-error-test defconstant.7 'symbolp #'(lambda (x) `(defconstant ,x nil))) (def-all-error-test defconstant.8 'stringp #'(lambda (x) `(defconstant ,(gensym) nil ,x))) ;;; DEFPARAMETER (def-error-test defparameter.1 (defparameter)) (def-error-test defparameter.2 (defparameter . foo)) (def-error-test defparameter.3 (defparameter #.(gensym))) (def-error-test defparameter.4 (defparameter #.(gensym) . foo)) (def-error-test defparameter.5 (defparameter #.(gensym) nil . foo)) (def-error-test defparameter.6 (defparameter #.(gensym) nil "foo" . bar)) (def-all-error-test defparameter.7 'symbolp #'(lambda (x) `(defparameter ,x nil))) (def-all-error-test defparameter.8 'stringp #'(lambda (x) `(defparameter ,(gensym) nil ,x))) ;;; DEFVAR (def-error-test defvar.1 (defvar)) (def-error-test defvar.2 (defvar . foo)) (def-error-test defvar.4 (defvar #.(gensym) . foo)) (def-error-test defvar.5 (defvar #.(gensym) nil . foo)) (def-error-test defvar.6 (defvar #.(gensym) nil "foo" . bar)) (def-all-error-test defvar.7 'symbolp #'(lambda (x) `(defvar ,x nil))) (def-all-error-test defvar.8 'stringp #'(lambda (x) `(defvar ,(gensym) nil ,x))) ;;; DESTRUCTURING-BIND (def-error-test destructuring-bind.1 (destructuring-bind)) (def-error-test destructuring-bind.2 (destructuring-bind x)) (def-all-error-test destructuring-bind.3 (typef '(or symbol cons)) #'(lambda (x) `(destructuring-bind ,x nil))) (def-error-test destructuring-bind.4 (destructuring-bind (x) '(a) nil (declare) x)) ;;; LET (def-error-test let.1 (let)) (def-error-test let.2 (let . x)) (def-all-error-test let.3 'listp #'(lambda (x) `(let ,x nil))) (def-error-test let.4 (let () . x)) (def-error-test let.5 (let (x . 1) nil)) (def-error-test let.6 (let ((x) . y) nil)) (def-error-test let.7 (let ((x 1 . 2)) nil)) (def-error-test let.8 (let ((x 1 2)) nil)) (def-error-test let.9 (let ((x 1) (x 2)) x)) (def-error-test let.10 (let ((t 1)) t)) (def-all-error-test let.11 (typef '(or cons symbol)) #'(lambda (x) `(let (,x) nil))) (def-all-error-test let.12 'symbolp #'(lambda (x) `(let ((,x)) nil))) (def-error-test let.13 (let ((x 0) (x 1)) x)) ;;; LET* (def-error-test let*.1 (let*)) (def-error-test let*.2 (let* . x)) (def-all-error-test let*.3 'listp #'(lambda (x) `(let* ,x nil))) (def-error-test let*.4 (let* () . x)) (def-error-test let*.5 (let* (x . 1) nil)) (def-error-test let*.6 (let* ((x) . y) nil)) (def-error-test let*.7 (let* ((x 1 . 2)) nil)) (def-error-test let*.8 (let* ((x 1 2)) nil)) (def-error-test let*.10 (let* ((t 1)) t)) (def-all-error-test let*.11 (typef '(or cons symbol)) #'(lambda (x) `(let* (,x) nil))) (def-all-error-test let*.12 'symbolp #'(lambda (x) `(let* ((,x)) nil))) ;;; PROGV (def-error-test progv.1 (progv)) (def-error-test progv.2 (progv '(a))) (def-all-error-test progv.3 'listp '(progv x nil nil)) (def-all-error-test progv.4 'listp '(progv '(a) x nil)) ;;; SETQ (def-error-test setq.1 (setq . x)) (def-error-test setq.2 (let ((x t)) (setq x))) (def-error-test setq.3 (let ((x t)) (setq x . foo))) (def-error-test setq.4 (let ((x 1)) (setq x nil . foo))) (def-error-test setq.5 (let ((x 1) (y 2)) (setq x nil y))) (def-all-error-test setq.6 'symbolp #'(lambda (x) `(setq ,x nil))) (def-error-test setq.7 (let ((sym (gensym))) (eval `(defconstant ,sym nil)) (eval `(setq ,sym t)) (eval sym))) ;;; PSETQ (def-error-test psetq.1 (psetq . x)) (def-error-test psetq.2 (let ((x t)) (psetq x))) (def-error-test psetq.3 (let ((x t)) (psetq x . foo))) (def-error-test psetq.4 (let ((x 1)) (psetq x nil . foo))) (def-error-test psetq.5 (let ((x 1) (y 2)) (psetq x nil y))) (def-all-error-test psetq.6 'symbolp #'(lambda (x) `(psetq ,x nil))) (def-error-test psetq.7 (let ((sym (gensym))) (eval `(defconstant ,sym nil)) (eval `(psetq ,sym t)) (eval sym))) ;;; I suggest it would be useful for PSETQ to detect when it is ;;; being asked to assign to the same variable twice, since this ;;; isn't well defined. (def-error-test psetq.8 (let ((x 0)) (psetq x 1 x 2) x)) ;;; BLOCK (def-error-test block.1 (block)) (def-error-test block.2 (block . foo)) (def-all-error-test block.3 'symbolp #'(lambda (x) `(block ,x))) (def-error-test block.4 (block nil . foo)) ;;; CATCH (def-error-test catch.1 (catch)) (def-error-test catch.2 (catch . foo)) (def-error-test catch.3 (catch 'tag . foo)) (def-all-error-test catch.4 (constantly nil) '(catch x (throw x nil)) :vals *cl-symbols*) ;;; GO (def-error-test go.1 (go)) (def-error-test go.2 (go . foo)) (def-all-error-test go.3 (typef '(or symbol integer)) #'(lambda (x) `(go ,x))) (def-error-test go.4 (tagbody (go done . foo) done)) (def-error-test go.5 (tagbody (go done foo) done)) ;;; RETURN-FROM (def-error-test return-from.1 (return-from)) (def-error-test return-from.2 (return-from . foo)) (def-error-test return-from.3 (return-from foo)) (def-error-test return-from.4 (block foo (return-from foo . t))) (def-error-test return-from.5 (block foo (return-from foo nil . 2))) (def-error-test return-from.6 (block foo (return-from foo nil 3))) ;;; RETURN (def-error-test return.1 (return . x)) (def-error-test return.2 (return nil . x)) ;;; TAGBODY (def-error-test tagbody.1 (tagbody . x)) (def-all-error-test tagbody.2 (typef '(or symbol integer cons)) #'(lambda (x) `(tagbody ,x))) ;;; THROW (def-error-test throw.1 (throw)) (def-error-test throw.2 (throw . x)) (def-error-test throw.3 (catch 'a (throw 'a))) (def-error-test throw.4 (catch 'a (throw 'a . x))) (def-error-test throw.5 (catch 'a (throw 'a 1 . x))) (def-error-test throw.6 (catch 'a (throw 'a 1 'x))) ;;; UNWIND-PROTECT (def-error-test unwind-protect.1 (unwind-protect)) (def-error-test unwind-protect.2 (unwind-protect . x)) (def-error-test unwind-protect.3 (unwind-protect nil . x)) ;;; NOT (def-error-test not.1 (not . x)) (def-error-test not.2 (not nil . x)) ;;; EQ (def-error-test eq.1 (eq . 1)) (def-error-test eq.2 (eq 'x . 2)) (def-error-test eq.3 (eq :foo 2 . 17)) ;;; EQL (def-error-test eql.1 (eql . 1)) (def-error-test eql.2 (eql 'x . 2)) (def-error-test eql.3 (eql :foo 2 . 17)) ;;; EQUAL (def-error-test equal.1 (equal . 1)) (def-error-test equal.2 (equal 'x . 2)) (def-error-test equal.3 (equal :foo 2 . 17)) ;;; EQUALP (def-error-test equalp.1 (equalp . 1)) (def-error-test equalp.2 (equalp 'x . 2)) (def-error-test equalp.3 (equalp :foo 2 . 17)) ;;; IDENTITY (def-error-test identity.1 (identity . 0)) (def-error-test identity.2 (identity 0 . "foo")) ;;; COMPLEMENT (def-error-test complement.1 (complement . 1.2)) (def-error-test complement.2 (complement #'plusp . #(1 2))) (def-error-test complement.3 (complement #'zerop #*110101 . #c(1 2))) (def-all-error-test complement.4 'functionp '(complement x)) ;;; CONSTANTLY (def-error-test constantly.1 (constantly . 1/2)) (def-error-test constantly.2 (constantly :foo . 1/2)) ;;; EVERY (def-error-test every.1 (every . :foo)) (def-error-test every.2 (every 'null . (list))) (def-error-test every.3 (every (gensym) '(a b c d))) ;;; SOME (def-error-test some.1 (some . :foo)) (def-error-test some.2 (some 'null . (list))) (def-error-test some.3 (some (gensym) '(a b c d))) ;;; NOTEVERY (def-error-test notevery.1 (notevery . :foo)) (def-error-test notevery.2 (notevery 'null . (list))) (def-error-test notevery.3 (notevery (gensym) '(a b c d))) ;;; NOTANY (def-error-test notany.1 (notany . :foo)) (def-error-test notany.2 (notany 'null . (list))) (def-error-test notany.3 (notany (gensym) '(a b c d))) ;;; AND (def-error-test and.1 (and . #.(make-hash-table))) (def-error-test and.2 (and t . :foo)) ;;; COND (def-error-test cond.1 (cond . 1)) (def-error-test cond.2 (cond (t . 2))) (def-error-test cond.3 (cond nil)) (def-error-test cond.4 (cond (nil) . "foo")) ;;; IF (def-error-test if.1 (if)) (def-error-test if.2 (if . t)) (def-error-test if.3 (if t)) (def-error-test if.4 (if nil)) (def-error-test if.5 (if t . 1)) (def-error-test if.6 (if nil . 2)) (def-error-test if.7 (if t 1 . 2)) (def-error-test if.8 (if nil #\x . #\y)) (def-error-test if.9 (if t 1 2 . 3)) (def-error-test if.10 (if nil #\x #\y . 1.23d4)) (def-error-test if.11 (if t 1 2 3)) (def-error-test if.12 (if nil #\x #\y nil nil nil)) ;;; OR (def-error-test or.1 (or . :foo)) (def-error-test or.2 (or nil . :bar)) ;;; WHEN (def-error-test when.1 (when)) (def-error-test when.2 (when . #\$)) (def-error-test when.3 (when t . x)) (def-error-test when.4 (when t nil . "A")) ;;; UNLESS (def-error-test unless.1 (unless)) (def-error-test unless.2 (unless . #*1011)) (def-error-test unless.3 (unless nil . t)) (def-error-test unless.4 (unless nil nil . #())) gcl27-2.7.0/ansi-tests/beyond-ansi/errors-data-and-control-flow-3.lsp000066400000000000000000000273461454061450500252460ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jun 14 07:00:58 2005 ;;;; Contains: Tests of non-ANSI exceptions sutation from CLHS section 5, part 3 (in-package :ba-test) (compile-and-load "ba-aux.lsp") ;;; CASE (def-error-test case.1 (case . 1)) (def-error-test case.2 (case nil . 1)) (def-error-test case.3 (case nil (nil . 1))) (def-error-test case.4 (case 'x nil)) (def-error-test case.5 (case 'x ((nil . x) 1))) (def-error-test case.6 (case)) ;;; CCASE (def-error-test ccase.1 (ccase . 1)) (def-error-test ccase.2 (let ((x nil)) (ccase x . 1))) (def-error-test ccase.3 (let ((x nil)) (ccase x (nil . 1)))) (def-error-test ccase.4 (let ((x 'x)) (ccase x nil))) (def-error-test ccase.5 (let ((x 'x)) (ccase x ((nil . x) 1)))) (def-error-test ccase.6 (ccase 1 (1 nil))) ;; 1 is not a place! (def-error-test ccase.7 (ccase)) ;;; ECASE (def-error-test ecase.1 (ecase . 1)) (def-error-test ecase.2 (ecase nil . 1)) (def-error-test ecase.3 (ecase nil (nil . 1))) (def-error-test ecase.4 (ecase 'x nil)) (def-error-test ecase.5 (ecase 'x ((nil . x) 1))) (def-error-test ecase.6 (ecase)) ;;; TYPECASE (def-error-test typecase.1 (typecase)) (def-error-test typecase.2 (typecase . :foo)) (def-error-test typecase.3 (typecase 'x . #\X)) (def-error-test typecase.4 (typecase 'x (#.(gensym) t))) (def-error-test typecase.5 (typecase 'x (symbol . :foo))) (def-error-test typecase.6 (typecase 'x . :foo)) (def-error-test typecase.7 (typepcase 'x (t . :foo))) (def-error-test typecase.8 (typepcase 'x (otherwise . :foo))) ;;; CTYPECASE (def-error-test ctypecase.1 (ctypecase)) (def-error-test ctypecase.2 (ctypecase . :foo)) (def-error-test ctypecase.3 (let ((x 'x)) (ctypecase x . #\X))) (def-error-test ctypecase.4 (let ((x 'x)) (ctypecase x (#.(gensym) t)))) (def-error-test ctypecase.5 (let ((x 'x)) (ctypecase x (symbol . :foo)))) (def-error-test ctypecase.6 (let ((x 'x)) (ctypecase x . :foo))) (def-error-test ctypecase.7 (let ((x 'x)) (ctypecase x (t . :foo)))) (def-error-test ctypecase.8 (let ((x 'x)) (ctypecase x (otherwise . :foo)))) (def-error-test ctypecase.9 (ctypecase 1 (integer :bad))) ;;; ETYPECASE (def-error-test etypecase.1 (etypecase)) (def-error-test etypecase.2 (etypecase . :foo)) (def-error-test etypecase.3 (etypecase 'x . #\X)) (def-error-test etypecase.4 (etypecase 'x (#.(gensym) t))) (def-error-test etypecase.5 (etypecase 'x (symbol . :foo))) (def-error-test etypecase.6 (etypecase 'x . :foo)) ;;; MULTIPLE-VALUE-BIND (def-error-test multiple-value-bind.1 (multiple-value-bind)) (def-error-test multiple-value-bind.2 (multiple-value-bind . #.(1+ most-positive-fixnum))) (def-error-test multiple-value-bind.3 (multiple-value-bind (x))) (def-error-test multiple-value-bind.4 (multiple-value-bind (x . y) 1 x)) (def-error-test multiple-value-bind.5 (multiple-value-bind (x) . :foo)) (def-error-test multiple-value-bind.6 (multiple-value-bind (x) nil . :bar)) (def-error-test multiple-value-bind.7 (multiple-value-bind (x) nil "doc string" . 1)) (def-error-test multiple-value-bind.8 (multiple-value-bind (x) nil (declare) . 1)) (def-error-test multiple-value-bind.9 (multiple-value-bind (x) 1 (declare (type symbol x)) x)) (def-error-test multiple-value-bind.10 (multiple-value-bind (x) 1 nil (declare) nil)) (def-error-test multiple-value-bind.11 (multiple-value-bind (x) 1 "foo" "bar" (declare) nil)) ;;; MULTIPLE-VALUE-CALL (def-error-test multiple-value-call.1 (multiple-value-call)) (def-error-test multiple-value-call.2 (multiple-value-call . :x)) (def-error-test multiple-value-call.3 (multiple-value-call 'list . :x)) (def-error-test multiple-value-call.4 (multiple-value-call 'list 1 . :x)) (def-all-error-test multiple-value-call.5 'function-designator-p '(multiple-value-call x nil)) (def-error-test multiple-value-call.6 (multiple-value-call (gensym))) ;;; MULTIPLE-VALUE-LIST (def-error-test multiple-value-list.1 (multiple-value-list)) (def-error-test multiple-value-list.2 (multiple-value-list . 1)) (def-error-test multiple-value-list.3 (multiple-value-list 1 . 2)) (def-error-test multiple-value-list.4 (multiple-value-list 1 2)) ;;; MULTIPLE-VALUE-PROG1 (def-error-test multiple-value-prog1.1 (multiple-value-prog1)) (def-error-test multiple-value-prog1.2 (multiple-value-prog1 . 1)) (def-error-test multiple-value-prog1.3 (multiple-value-prog1 :x . :y)) ;;; MULTIPLE-VALUE-SETQ (def-error-test multiple-value-setq.1 (multiple-value-setq)) (def-error-test multiple-value-setq.2 (let (x) (multiple-value-setq (x)) x)) (def-error-test multiple-value-setq.3 (let (x y) (multiple-value-setq (x . y) nil (list x y)))) (def-all-error-test multiple-value-setq.4 'symbolp #'(lambda (x) `(multiple-value-setq (,x) nil))) (def-all-error-test multiple-value-setq.5 (constantly nil) #'(lambda (x) `(multiple-value-setq (,x) nil)) :vals cl-test::*cl-constant-symbols*) ;;; VALUES (def-all-error-test values.1 'listp #'(lambda (x) (cons 'values x))) (def-all-error-test values.2 'listp #'(lambda (x) (list* 'values 1 x))) ;;; NTH-VALUE (def-error-test nth-value.1 (nth-value)) (def-error-test nth-value.2 (nth-value 0)) (def-error-test nth-value.3 (nth-value 1 '(a b c) 2)) (def-all-error-test nth-value.4 (constantly nil) #'(lambda (x) `(nth-value ',x))) (def-all-error-test nth-value.5 (constantly nil) #'(lambda (x) `(nth-value . ,x))) (def-all-error-test nth-value.6 (constantly nil) #'(lambda (x) `(nth-value 0 . ,x))) (def-all-error-test nth-value.7 'integerp #'(lambda (x) `(nth-value ',x nil))) (def-error-test nth-value.8 (nth-value -1 'x)) (def-all-error-test nth-value.9 'null #'(lambda (x) `(nth-value 0 'a . ,x))) ;;; PROG (def-error-test prog.1 (prog)) (def-all-error-test prog.2 'listp #'(lambda (x) `(prog . ,x))) (def-all-error-test prog.3 'listp #'(lambda (x) `(prog ,x))) (def-all-error-test prog.4 'listp #'(lambda (x) `(prog () . ,x))) (def-all-error-test prog.5 (typef '(or symbol cons)) #'(lambda (x) `(prog (,x)))) (def-all-error-test prog.6 'listp #'(lambda (x) `(prog (v . ,x)))) (def-all-error-test prog.7 'listp #'(lambda (x) `(prog ((v . ,x))))) (def-error-test prog.8 (prog ((x nil nil)))) (def-all-error-test prog.9 'null #'(lambda (x) `(prog ((v nil . ,x))))) ;;; PROG* (def-error-test prog*.1 (prog*)) (def-all-error-test prog*.2 'listp #'(lambda (x) `(prog* . ,x))) (def-all-error-test prog*.3 'listp #'(lambda (x) `(prog* ,x))) (def-all-error-test prog*.4 'listp #'(lambda (x) `(prog* () . ,x))) (def-all-error-test prog*.5 (typef '(or symbol cons)) #'(lambda (x) `(prog* (,x)))) (def-all-error-test prog*.6 'listp #'(lambda (x) `(prog* (v . ,x)))) (def-all-error-test prog*.7 'listp #'(lambda (x) `(prog* ((v . ,x))))) (def-error-test prog*.8 (prog* ((x nil nil)))) (def-all-error-test prog*.9 'null #'(lambda (x) `(prog* ((v nil . ,x))))) ;;; PROG1 (def-error-test prog1.1 (prog1)) (def-all-error-test prog1.2 #'listp #'(lambda (x) `(prog1 . ,x))) (def-all-error-test prog1.3 #'listp #'(lambda (x) `(prog1 nil . ,x))) ;;; PROG2 (def-error-test prog2.1 (prog2)) (def-all-error-test prog2.2 #'listp #'(lambda (x) `(prog2 . ,x))) (def-error-test prog2.3 (prog2 t)) (def-all-error-test prog2.4 #'listp #'(lambda (x) `(prog2 nil . ,x))) (def-all-error-test prog2.5 #'listp #'(lambda (x) `(prog2 'a 'b . ,x))) (def-all-error-test prog2.6 #'listp #'(lambda (x) `(prog2 'a 'b nil . ,x))) ;;; PROGN (def-all-error-test progn.1 'listp #'(lambda (x) `(progn . ,x))) (def-all-error-test progn.2 'listp #'(lambda (x) `(progn nil . ,x))) (def-all-error-test progn.3 'listp #'(lambda (x) `(progn 'a 'b . ,x))) ;;; DEFINE-MODIFY-MACRO (def-error-test define-modify-macro.1 (define-modify-macro)) (def-error-test define-modify-macro.2 (define-modify-macro #.(gensym))) (def-all-error-test define-modify-macro.3 'symbolp #'(lambda (x) `(define-modify-macro ,x ()))) (def-all-error-test define-modify-macro.4 'listp #'(lambda (x) `(define-modify-macro #.(gensym) ,x))) (def-all-error-test define-modify-macro.5 'listp #'(lambda (x) `(define-modify-macro #.(gensym) () . ,x))) (def-all-error-test define-modify-macro.6 'symbolp #'(lambda (x) `(define-modify-macro #.(gensym) () ,x))) (def-all-error-test define-modify-macro.7 'stringp #'(lambda (x) `(define-modify-macro #.(gensym) () #.(gensym) ,x))) (def-all-error-test define-modify-macro.8 'listp #'(lambda (x) `(define-modify-macro #.(gensym) () #.(gensym) . ,x))) (def-all-error-test define-modify-macro.9 'listp #'(lambda (x) `(define-modify-macro #.(gensym) () #.(gensym) "foo" . ,x))) (def-all-error-test define-modify-macro.10 (constantly nil) #'(lambda (x) `(define-modify-macro #.(gensym) () #.(gensym) "foo" ,x))) ;;; DEFSETF (def-error-test defsetf.1 (defsetf)) (def-error-test defsetf.2 (defsetf #.(gensym))) (def-all-error-test defsetf.3 'listp #'(lambda (x) `(defsetf ,x))) (def-all-error-test defsetf.4 'listp #'(lambda (x) `(defsetf #.(gensym) . ,x))) (def-all-error-test defsetf.5 'listp #'(lambda (x) `(defsetf #.(gensym) #.(gensym) . ,x))) (def-all-error-test defsetf.6 'stringp #'(lambda (x) `(defsetf #.(gensym) #.(gensym) ,x))) (def-all-error-test defsetf.7 'null #'(lambda (x) `(defsetf #.(gensym) #.(gensym) "foo" . ,x))) (def-all-error-test defsetf.8 (constantly nil) #'(lambda (x) `(defsetf #.(gensym) #.(gensym) "foo" ,x))) (def-all-error-test defsetf.9 (typef '(or list symbol)) #'(lambda (x) `(defsetf #.(gensym) ,x))) ;;; Need long form defsetf error tests ;;; FIXME: add tests for defsetf-lambda-lists (def-all-error-test defsetf.10 'symbolp #'(lambda (x) `(defsetf #.(gensym) (#1=#.(gensym)) (,x) #1#))) (def-all-error-test defsetf.11 'listp #'(lambda (x) `(defsetf #.(gensym) (#.(gensym)) ., x))) (def-all-error-test defsetf.12 'listp #'(lambda (x) `(defsetf #.(gensym) (#.(gensym)) , x))) (def-all-error-test defsetf.13 'listp #'(lambda (x) `(defsetf #.(gensym) (#.(gensym)) (a . ,x)))) (def-error-test defsetf.14 (defsetf #.(gensym) () () nil (declare (optimize)) nil)) (def-error-test defsetf.15 (defsetf #.(gensym) () () "foo" "bar" (declare (optimize)) nil)) ;;; FIXME -- Add tests for DEFINE-SETF-EXPANDER (def-error-test get-setf-expansion.1 (get-setf-expansion)) (def-all-error-test get-setf-expansion.2 'listp #'(lambda (x) `(get-setf-expansion . ,x))) (def-all-error-test get-setf-expansion.3 (typef '(or list symbol)) #'(lambda (x) `(get-setf-expansion ,x))) ;;; FIXME -- figure out how to test for invalid environment objects ;;; Must make an assumption about what can be an environment ;;; SETF tests (def-all-error-test setf.1 (constantly nil) #'(lambda (x) `(setf ,x))) (def-all-error-test setf.2 'listp #'(lambda (x) `(setf . ,x))) (def-all-error-test setf.3 'listp #'(lambda (x) `(setf ,x nil))) (def-all-error-test setf.4 'listp #'(lambda (x) `(let (a) (setf a . ,x)))) ;;; PSETF tests (def-all-error-test psetf.1 (constantly nil) #'(lambda (x) `(psetf ,x))) (def-all-error-test psetf.2 'listp #'(lambda (x) `(psetf . ,x))) (def-all-error-test psetf.3 'listp #'(lambda (x) `(psetf ,x nil))) (def-all-error-test psetf.4 'listp #'(lambda (x) `(let (a) (psetf a . ,x)))) ;;; SHIFTF tests (def-error-test shiftf.1 (shiftf)) (def-all-error-test shiftf.2 'listp #'(lambda (x) `(shiftf . ,x))) (def-all-error-test shiftf.3 (constantly nil) #'(lambda (x) `(shiftf ,x))) (def-all-error-test shiftf.4 'listp #'(lambda (x) `(let (a) (shiftf a . ,x)))) (def-all-error-test shiftf.5 'listp #'(lambda (x) `(shiftf ,x nil))) (def-all-error-test shiftf.6 'listp #'(lambda (x) `(let (a b) (shiftf a b . ,x)))) (def-all-error-test shiftf.7 'listp #'(lambda (x) `(let (a) (shiftf ,x a nil)))) (def-all-error-test shiftf.8 'listp #'(lambda (x) `(let (a) (shiftf a ,x nil)))) ;;; ROTATEF tests (def-all-error-test rotatef.1 'listp #'(lambda (x) `(rotatef . ,x))) (def-all-error-test rotatef.2 'listp #'(lambda (x) `(rotatef ,x))) (def-all-error-test rotatef.3 'listp #'(lambda (x) `(let (a) (rotatef a ,x)))) (def-all-error-test rotatef.4 'listp #'(lambda (x) `(let (a) (rotatef a . ,x)))) (def-all-error-test rotatef.5 'listp #'(lambda (x) `(let (a) (rotatef ,x a)))) gcl27-2.7.0/ansi-tests/beyond-ansi/errors-eval-compile.lsp000066400000000000000000000203741454061450500233610ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 28 06:37:41 2005 ;;;; Contains: Tests for nonstandard exceptional conditions in section 3 (in-package :ba-test) (declaim (notinline compile-fails?)) (compile-and-load "ba-aux.lsp") ;;; Utility functions (defun compile-fails? (&rest args) (cl:handler-case (let ((vals (multiple-value-list (apply #'compile args)))) (if (and (= (length vals) 3) (cadr vals) (caadr vals)) t (apply #'values nil vals))) (error () t))) ;;; Tests of COMPILE (deftest compile.1 (loop for x in *mini-universe* unless (or (function-name-p x) (compile-fails? x)) collect x) nil) (deftest compile.2 (compile-fails? nil) t) (deftest compile.3 (let ((sym (gensym))) (eval `(defun ,sym () nil)) (loop for x in *mini-universe* unless (or (functionp x) (and (consp x) (eql (car x) 'lambda)) (compile-fails? sym x)) collect x)) nil) (deftest compile.4 (compile-fails? nil '(lambda)) t) (deftest compile.5 (compile-fails? nil '(lambda x)) t) ;;; EVAL-WHEN tests (def-all-error-test eval-when.1 'listp '(eval-when x nil)) ;;; LOAD-TIME-VALUE (def-error-test load-time-value.1 (load-time-value)) (def-error-test load-time-value.2 (load-time-value nil nil nil)) ;;; QUOTE (def-error-test quote.1 (quote)) (def-error-test quote.2 (quote . x)) (def-error-test quote.3 (quote t . x)) (def-error-test quote.4 (quote t x)) ;;; COMPILER-MACRO-FUNCTION (def-all-error-test compiler-macro-function.1 'function-name-p '(compiler-macro-function x)) (def-all-error-test compiler-macro-function.2 'function-name-p '(setf (compiler-macro-function x) #'rplacd)) ;;; DEFINE-COMPILER-MACRO (def-error-test define-compiler-macro.1 (define-compiler-macro)) (deftest define-compiler-macro.2 (let ((sym (gensym))) (eval `(signals-error (define-compiler-macro ,sym) error))) t) (def-error-test define-compiler-macro.3 (define-compiler-macro . foo)) (deftest define-compiler-macro.4 (let ((sym (gensym))) (eval `(signals-error (define-compiler-macro ,sym () . foo) error))) t) ;;; DEFMACRO (def-error-test defmacro.1 (defmacro)) (deftest defmacro.2 (let ((sym (gensym))) (eval `(signals-error (defmacro ,sym) error))) t) (def-error-test defmacro.3 (defmacro . foo)) (deftest defmacro.4 (let ((sym (gensym))) (eval `(signals-error (defmacro ,sym () . foo) error))) t) ;;; MACRO-FUNCTION (def-all-error-test macro-funtion.1 'symbolp '(macro-function x)) (def-all-error-test macro-funtion.2 'symbolp '(setf (macro-function x) (macro-function 'pop))) ;;; DEFINE-SYMBOL-MACRO (deftest define-symbol-macro.1 (let ((sym (gensym))) (eval `(signals-error (define-symbol-macro ,sym) error))) t) (deftest define-symbol-macro.2 (let ((sym (gensym))) (eval `(signals-error (define-symbol-macro ,sym t nil) error))) t) (def-all-error-test define-symbol-macro.3 'symbolp '(define-symbol-macro x)) ;;; IGNORE (def-all-error-test ignore.1 'symbol-or-function-p '(locally (declare (ignore x)) nil)) (def-error-test ignore.2 (locally (declare (ignore . foo)) nil)) ;;; IGNORABLE (def-all-error-test ignorable.1 'symbol-or-function-p '(locally (declare (ignorable x)) nil)) (def-error-test ignorable.2 (locally (declare (ignorable . foo)) nil)) ;;; DYNAMIC-EXTENT (def-all-error-test dynamic-extent.1 'symbol-or-function-p '(locally (declare (dynamic-extent x)) nil)) (def-error-test dynamic-extent.2 (locally (declare (dynamic-extent . foo)) nil)) ;;; TYPE declarations ;;; Test that violation of the type declarations is detected, and ;;; leads to an error in safe code. #-sbcl (deftest type.1 (loop for x in *mini-universe* for tp = (type-of x) for lambda-form = `(lambda (y) (declare (optimize safety) (type (not ,tp) y)) y) for fn = (progn (print lambda-form) (eval `(function ,lambda-form))) unless (eval `(signals-error (funcall ',fn ',x) error)) collect x) nil) (deftest type.2 (let* ((utypes (coerce (mapcar #'type-of *universe*) 'vector)) (n (length utypes))) (flet ((%rtype () (elt utypes (random n)))) (loop for x in *mini-universe* for tp = (loop for tp = (%rtype) while (typep x tp) finally (return tp)) for lambda-form = `(lambda (y) (declare (optimize safety) (type ,tp y)) y) for fn = (progn ;; (print lambda-form) (eval `(function ,lambda-form))) unless (eval `(signals-error (funcall ',fn ',x) error)) collect x))) nil) (deftest type.2c (let* ((utypes (coerce (mapcar #'type-of *universe*) 'vector)) (n (length utypes))) (flet ((%rtype () (elt utypes (random n)))) (loop for x in *mini-universe* for tp = (loop for tp = (%rtype) while (typep x tp) finally (return tp)) for lambda-form = `(lambda (y) (declare (optimize safety) (type ,tp y)) y) for fn = (progn ;; (print lambda-form) (compile nil lambda-form)) unless (eval `(signals-error (funcall ',fn ',x) error)) collect x))) nil) (deftest type.3 (loop for x in *mini-universe* for tp = (type-of x) for lambda-form = `(lambda (z) (declare (optimize safety)) (let ((y z)) (declare (type ,tp y)) y)) for fn = (progn ;; (print lambda-form) (eval `(function ,lambda-form))) unless (or (typep nil tp) (eval `(signals-error (funcall ',fn nil) error))) collect x) nil) (deftest type.3c (loop for x in *mini-universe* for tp = (type-of x) for lambda-form = `(lambda (z) (declare (optimize safety)) (let ((y z)) (declare (type ,tp y)) y)) for fn = (progn ;; (print lambda-form) (compile nil lambda-form)) unless (or (typep nil tp) (eval `(signals-error (funcall ',fn nil) error))) collect x) nil) (deftest type.4 (loop for x in *mini-universe* for tp = (type-of x) for lambda-form = `(lambda (z) (declare (optimize safety)) (the ,tp z)) for fn = (progn ;; (print lambda-form) (eval `(function ,lambda-form))) unless (or (typep nil tp) (eval `(signals-error (funcall ',fn nil) error))) collect x) nil) (deftest type.5 (signals-error (let () (declare (type . foo)) nil) error) t) (deftest type.6 (signals-error (let () (declare (type integer . foo)) nil) error) t) (deftest type.7 (signals-error (let () (declare (integer . foo)) nil) error) t) (deftest type.8 (signals-error (let ((x (make-array 3 :initial-element 0 :element-type '(integer 0 2)))) (declare (optimize safety) (type (array (integer 0 2) (3)) x)) (setf (aref x 0) 3) (aref x 0)) error) t) ;; Move the type tests off to another file, eventually. ;;; INLINE (def-all-error-test inline.1 'function-name-p '(locally (declare (inline x)) nil)) (def-error-test inline.2 (locally (declare (inline . x)) nil)) ;;; NOTINLINE (def-all-error-test notinline.1 'function-name-p '(locally (declare (notinline x)) nil)) (def-error-test notinline.2 (locally (declare (notinline . x)) nil)) ;;; FTYPE (def-error-test ftype.1 (macrolet ((%m () :foo)) (declare (ftype (function (&rest t) t) %m)) (%m))) (def-error-test ftype.2 (flet ((%f () :foo)) (declare (ftype (function () (eql :bar)) %f)) (%f))) (def-error-test ftype.3 (locally (declare (ftype)) nil)) (def-error-test ftype.4 (locally (declare (ftype symbol)) nil)) (def-error-test ftype.5 (locally (declare (ftype (function () t) . foo)) nil)) (def-all-error-test ftype.6 'function-name-p '(locally (declare (ftype (function () t) x)) nil)) ;;; DECLARATIONS (def-error-test declaration.1 (proclaim '(declaration . foo))) (def-all-error-test declaration.2 'symbolp '(proclaim (declaration x))) ;;; OPTIMIZE (def-error-test optimize.1 (locally (declare (optimize .foo)) nil)) (def-all-error-test optimize.2 'symbolp '(locally (declare (optimize (x 0))) nil)) (def-all-error-test optimize.3 (typef '(mod 4)) '(locally (declare (optimize (speed x))))) ;;; SPECIAL (def-error-test special.1 (locally (declare (special . x)) nil)) (def-all-error-test special.2 'symbolp '(locally (declare (special x)) nil)) ;;; LOCALLY (def-error-test locally.1 (locally . x)) ;;; THE (def-error-test the.1 (the)) (def-error-test the.2 (the t)) (def-error-test the.3 (the t :a :b)) (def-error-test the.4 (setf (the) nil)) (def-error-test the.5 (setf (the t) nil)) (def-error-test the.6 (let (x y) (setf (the t x y) nil))) ;;; gcl27-2.7.0/ansi-tests/beyond-ansi/errors-iteration.lsp000066400000000000000000000060121454061450500227730ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Contains: Tests of non-ANSI exceptions sutation from CLHS section 6 (Iteration) (in-package :ba-test) (compile-and-load "ba-aux.lsp") ;;; DO tests (def-all-error-test do.1 'listp #'(lambda (x) `(do . ,x))) (def-all-error-test do.2 'listp #'(lambda (x) `(do () . ,x))) (def-all-error-test do.3 #'(lambda (x) (or (symbolp x) (listp x))) #'(lambda (x) `(do (,x)))) (def-all-error-test do.4 'listp #'(lambda (x) `(do ((a 1 (1+ a)) . ,x)))) (def-all-error-test do.5 'listp #'(lambda (x) `(do () ,x))) (def-all-error-test do.6 'listp #'(lambda (x) `(do () (t . ,x)))) (def-all-error-test do.7 'listp #'(lambda (x) `(do () (t) . ,x))) (def-all-error-test do.8 'listp #'(lambda (x) `(do ((a . ,x)) (t)))) (def-all-error-test do.9 'listp #'(lambda (x) `(do ((a 1 . ,x)) (t)))) (def-all-error-test do.10 'listp #'(lambda (x) `(do ((a 1 (1+ a) . ,x)) (t)))) (def-error-test do.11 (do)) ;;; DO* tests (def-all-error-test do*.1 'listp #'(lambda (x) `(do* . ,x))) (def-all-error-test do*.2 'listp #'(lambda (x) `(do* () . ,x))) (def-all-error-test do*.3 #'(lambda (x) (or (symbolp x) (listp x))) #'(lambda (x) `(do* (,x)))) (def-all-error-test do*.4 'listp #'(lambda (x) `(do* ((a 1 (1+ a)) . ,x)))) (def-all-error-test do*.5 'listp #'(lambda (x) `(do* () ,x))) (def-all-error-test do*.6 'listp #'(lambda (x) `(do* () (t . ,x)))) (def-all-error-test do*.7 'listp #'(lambda (x) `(do* () (t) . ,x))) (def-all-error-test do*.8 'listp #'(lambda (x) `(do* ((a . ,x)) (t)))) (def-all-error-test do*.9 'listp #'(lambda (x) `(do* ((a 1 . ,x)) (t)))) (def-all-error-test do*.10 'listp #'(lambda (x) `(do* ((a 1 (1+ a) . ,x)) (t)))) (def-error-test do*.11 (do*)) ;;; DOTIMES tests (def-error-test dotimes.1 (dotimes)) (def-all-error-test dotimes.2 'listp #'(lambda (x) `(dotimes . ,x))) (def-all-error-test dotimes.3 'symbolp #'(lambda (x) `(dotimes (,x 1)))) (def-all-error-test dotimes.4 (constantly nil) #'(lambda (x) `(dotimes (,x)))) (def-all-error-test dotimes.5 'integerp #'(lambda (x) `(dotimes (i ',x)))) (def-all-error-test dotimes.6 'listp #'(lambda (x) `(dotimes (i . ,x)))) (def-all-error-test dotimes.7 'listp #'(lambda (x) `(dotimes (i 1 . ,x)))) (def-all-error-test dotimes.8 'listp #'(lambda (x) `(dotimes (i 1) . ,x))) (def-all-error-test dotimes.9 'listp #'(lambda (x) `(dotimes (i 1 nil . ,x)))) (def-all-error-test dotimes.10 'listp #'(lambda (x) `(dotimes (i 1 nil ,x)))) ;;; DOLIST tests (def-error-test dolist.1 (dolist)) (def-all-error-test dolist.2 'listp #'(lambda (x) `(dolist . ,x))) (def-all-error-test dolist.3 'symbolp #'(lambda (x) `(dolist (,x nil)))) (def-all-error-test dolist.4 'listp #'(lambda (x) `(dolist (e . ,x)))) (def-all-error-test dolist.5 'listp #'(lambda (x) `(dolist (e nil . ,x)))) (def-all-error-test dolist.6 'listp #'(lambda (x) `(dolist (e nil nil . ,x)))) (def-all-error-test dolist.7 'listp #'(lambda (x) `(dolist (e nil nil ,x)))) (def-all-error-test dolist.8 'listp #'(lambda (x) `(dolist (e ',x nil)))) (def-all-error-test dolist.9 'listp #'(lambda (x) `(dolist (e nil nil) . ,x))) gcl27-2.7.0/ansi-tests/beyond-ansi/errors-loop.lsp000066400000000000000000000050211454061450500217450ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Contains: Tests of non-ANSI exceptions sutation from CLHS for the LOOP macro (in-package :ba-test) (compile-and-load "ba-aux.lsp") ;;; LOOP tests (def-all-error-test loop.1 'listp #'(lambda (x) `(loop . ,x))) (def-all-error-test loop.named.1 'symbolp #'(lambda (x) `(loop named ,x return nil))) (def-all-error-test loop.named.2 'listp #'(lambda (x) `(loop named . ,x))) (def-error-test loop.with.1 (loop with)) (def-all-error-test loop.with.2 #'(lambda (x) (or (symbolp x) (listp x))) #'(lambda (x) `(loop with ,x))) (def-all-error-test loop.with.3 'listp #'(lambda (x) `(loop with . ,x))) (def-all-error-test loop.with.4 'listp #'(lambda (x) `(loop with x . ,x))) (def-all-error-test loop.with.5 'listp #'(lambda (x) `(loop with x = . ,x))) (def-all-error-test loop.with.6 'listp #'(lambda (x) `(loop with x t = . ,x))) (def-error-test loop.initially.1 (loop initially)) (def-all-error-test loop.initially.2 'listp #'(lambda (x) `(loop initially . ,x))) (def-all-error-test loop.initially.3 'listp #'(lambda (x) `(loop initially (progn) . ,x))) (def-error-test loop.finally.1 (loop finally)) (def-all-error-test loop.finally.2 'listp #'(lambda (x) `(loop finally . ,x))) (def-all-error-test loop.finally.3 'listp #'(lambda (x) `(loop finally (progn) . ,x))) ;;; LOOP FOR clauses (def-error-test loop.for.1 (loop for)) (def-all-error-test loop.for.2 'listp #'(lambda (x) `(loop for . ,x))) (def-all-error-test loop.for.3 'symbol-or-list-p #'(lambda (x) `(loop for ,x))) (def-all-error-test loop.for.4 'symbol-or-list-p #'(lambda (x) `(loop for ,x = nil))) (def-error-test loop.for.5 (loop for x from)) (def-error-test loop.for.6 (loop for x upfrom)) (def-error-test loop.for.7 (loop for x downfrom)) (def-error-test loop.for.8 (loop for x upto)) (def-error-test loop.for.9 (loop for x to)) (def-error-test loop.for.10 (loop for x below)) (def-all-error-test loop.for.11 (typef '(or symbol list class)) #'(lambda (x) `(loop for e ,x = nil return e))) (def-all-error-test loop.for.12 'listp #'(lambda (x) `(loop for x . ,x))) (def-all-error-test loop.for.13 'listp #'(lambda (x) `(loop for x from . ,x))) (def-all-error-test loop.for.14 'listp #'(lambda (x) `(loop for x downfrom . ,x))) (def-all-error-test loop.for.15 'listp #'(lambda (x) `(loop for x upfrom . ,x))) (def-all-error-test loop.for.16 'listp #'(lambda (x) `(loop for x upto . ,x))) (def-all-error-test loop.for.17 'listp #'(lambda (x) `(loop for x to . ,x))) (def-all-error-test loop.for.18 'listp #'(lambda (x) `(loop for x downto . ,x))) gcl27-2.7.0/ansi-tests/beyond-ansi/errors-types-and-class.lsp000066400000000000000000000073631454061450500240160ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon May 30 07:49:10 2005 ;;;; Contains: Tests for non-ansi exceptional situations in Section 4 of CLHS (in-package :ba-test) (compile-and-load "ba-aux.lsp") ;;; COERCE (def-all-error-test coerce.1 'listp '(coerce t x)) ;;; DEFTYPE (def-error-test deftype.1 (deftype)) (def-error-test deftype.2 (deftype #.(gensym))) (def-error-test deftype.3 (deftype . foo)) (def-all-error-test deftype.4 'symbolp '(deftype x () t)) ;;; SUBTYPEP (def-all-error-test subtypep.1 'type-specifier-p '(subtypep x t)) (def-all-error-test subtypep.2 'type-specifier-p '(subtypep nil x)) ;;; TYPEP (def-all-error-test typep.1 'type-specifier-p '(typep nil x)) ;;; SATISFIES (def-error-test satisfies.1 (typep nil '(satifies))) (def-error-test satisfies.2 (typep nil '(satifies null nil))) (def-all-error-test satisfies.3 'symbolp '(typep nil (satisfies x))) ;;; MEMBER (type specifier) (def-error-test member.type.1 (typep nil 'member)) (def-error-test member.type.2 (typep nil '(member . foo))) (def-error-test member.type.3 (typep nil '(member bar . foo))) ;;; NOT (type specifier) (def-error-test not.type.1 (typep nil 'not)) (def-error-test not.type.2 (typep nil '(not))) (def-error-test not.type.3 (typep nil '(not *))) (def-error-test not.type.4 (typep nil '(not nil nil))) (def-all-error-test not.type.5 'type-specifier-p '(typep nil '(not x))) (def-error-test not.type.6 (typep nil '(not . foo))) ;;; AND (type specifier) (def-error-test and.type.1 (typep nil 'and)) (def-error-test and.type.2 (typep nil '(and *))) (def-error-test and.type.3 (typep nil '(and t * t))) (def-error-test and.type.4 (typep nil '(and . foo))) (def-all-error-test and.type.5 'type-specifier-p '(typep t '(and t t x t))) ;;; OR (type specifier) (def-error-test or.type.1 (typep nil 'or)) (def-error-test or.type.2 (typep nil '(or *))) (def-error-test or.type.3 (typep nil '(or nil * nil))) (def-error-test or.type.4 (typep nil '(or . foo))) (def-all-error-test or.type.5 'type-specifier-p '(typep t '(or nil x nil))) ;;; VALUES (type specifier) (def-error-test values.type.1 (typep nil 'values)) (def-error-test values.type.2 (the values (values))) (def-error-test values.type.3 (the (values . foo) (values))) (def-error-test values.type.4 (the (values *) t)) (def-all-error-test values.type.5 'type-specifier-p '(the (values x) t)) ;;; EQL (type specifier) (def-error-test eql.type.1 (typep nil 'eql)) (def-error-test eql.type.2 (typep nil '(eql))) (def-error-test eql.type.3 (typep nil '(eql nil nil))) (def-error-test eql.type.4 (typep nil '(eql . foo))) ;;; TYPE-ERROR-DATUM (def-all-error-test type-error-datum.1 (typef 'type-error) '(type-error-datum x)) ;;; TYPE-ERROR-EXPECTED-TYPE (def-all-error-test type-error-expected-type.1 (typef 'type-error) '(type-error-expected-type x)) ;;; FUNCTION (type specifier) (def-error-test function.type.1 (locally (declare (type (function . foo) f)) nil)) (def-error-test function.type.2 (locally (declare (type (function () . foo) f)) nil)) (def-error-test function.type.3 (locally (declare (type (function (t . t) t) f)) nil)) (def-error-test function.type.4 (locally (declare (type (function (&optional . foo) t) f)) nil)) (def-error-test function.type.5 (locally (declare (type (function (&rest . foo) t) f)) nil)) (def-error-test function.type.6 (locally (declare (type (function (&key . foo) t) f)) nil)) (def-error-test function.type.7 (locally (declare (type (function (&key :foo) t) f)) nil)) (def-error-test function.type.8 (locally (declare (type (function (&key (:foo . bar)) t) f)) nil)) (def-error-test function.type.9 (locally (declare (type (function (&key (:foo t . bar)) t) f)) nil)) (def-error-test function.type.10 (locally (declare (type (function (&key (:foo t nil)) t) f)) nil)) gcl27-2.7.0/ansi-tests/beyond-ansi/load-ba.lsp000066400000000000000000000011741454061450500207660ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jun 8 06:52:59 2005 ;;;; Contains: Load beyond-ansi tests (let ((*default-pathname-defaults* (pathname *load-pathname*))) (let ((*default-pathname-defaults* (merge-pathnames (make-pathname :directory '(:relative :up))))) (load "gclload1.lsp")) (load "ba-test-package.lsp") (eval '(compile-and-load "ba-aux.lsp")) (load "errors-eval-compile.lsp") (load "errors-types-and-class.lsp") (load "errors-data-and-control-flow-1.lsp") (load "errors-data-and-control-flow-2.lsp") (load "errors-data-and-control-flow-3.lsp") (in-package :ba-test) ) gcl27-2.7.0/ansi-tests/beyond-ansi/makefile000066400000000000000000000003611454061450500204440ustar00rootroot00000000000000test: echo "(load \"load-ba.lsp\") (in-package :ba-test) (rt:do-tests)" | $(LISP) | tee test.out clean: @rm -f test.out *.cls *.fasl *.o *.so *~ *.fn *.x86f *.fasl *.ufsl *.abcl *.fas *.lib \#*\# @rm -f gazonk* out.class *.dfsl *.d64fsl gcl27-2.7.0/ansi-tests/bit-and.lsp000066400000000000000000000153251454061450500166000ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 18:18:47 2003 ;;;; Contains: Tests of BIT-AND (in-package :cl-test) (compile-and-load "bit-aux.lsp") (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.20 (macrolet ((%m (z) z)) (bit-and (expand-in-current-env (%m #*0011)) #*0101)) #*0001) (deftest bit-and.21 (macrolet ((%m (z) z)) (bit-and #*1010 (expand-in-current-env (%m #*1100)))) #*1000) (deftest bit-and.22 (macrolet ((%m (z) z)) (bit-and #*10100011 #*01101010 (expand-in-current-env (%m nil)))) #*00100010) (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) (def-fold-test bit-and.fold.1 (bit-and #*01101 #*01011)) ;;; Randomized tests (deftest bit-and.random.1 (bit-random-test-fn #'bit-and #'logand) nil) ;;; Error tests (deftest bit-and.error.1 (signals-error (bit-and) program-error) t) (deftest bit-and.error.2 (signals-error (bit-and #*000) program-error) t) (deftest bit-and.error.3 (signals-error (bit-and #*000 #*0100 nil nil) program-error) t) gcl27-2.7.0/ansi-tests/bit-andc1.lsp000066400000000000000000000154771454061450500170340ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 18:56:39 2003 ;;;; Contains: Tests of BIT-ANDC1 (in-package :cl-test) (compile-and-load "bit-aux.lsp") (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.20 (macrolet ((%m (z) z)) (bit-andc1 (expand-in-current-env (%m #*0011)) #*0101)) #*0100) (deftest bit-andc1.21 (macrolet ((%m (z) z)) (bit-andc1 #*1010 (expand-in-current-env (%m #*1100)))) #*0100) (deftest bit-andc1.22 (macrolet ((%m (z) z)) (bit-andc1 #*10100011 #*01101010 (expand-in-current-env (%m nil)))) #*01001000) (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) (def-fold-test bit-andc1.fold.1 (bit-andc1 #*10010 #*01011)) ;;; Random tests (deftest bit-andc1.random.1 (bit-random-test-fn #'bit-andc1 #'logandc1) nil) ;;; Error tests (deftest bit-andc1.error.1 (signals-error (bit-andc1) program-error) t) (deftest bit-andc1.error.2 (signals-error (bit-andc1 #*000) program-error) t) (deftest bit-andc1.error.3 (signals-error (bit-andc1 #*000 #*0100 nil nil) program-error) t) gcl27-2.7.0/ansi-tests/bit-andc2.lsp000066400000000000000000000155001454061450500170200ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:01:38 2003 ;;;; Contains: Tests of BIT-ANDC2 (in-package :cl-test) (compile-and-load "bit-aux.lsp") (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.20 (macrolet ((%m (z) z)) (bit-andc2 (expand-in-current-env (%m #*0011)) #*0101)) #*0010) (deftest bit-andc2.21 (macrolet ((%m (z) z)) (bit-andc2 #*1010 (expand-in-current-env (%m #*1100)))) #*0010) (deftest bit-andc2.22 (macrolet ((%m (z) z)) (bit-andc2 #*10100011 #*01101010 (expand-in-current-env (%m nil)))) #*10000001) (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) (def-fold-test bit-andc2.fold.1 (bit-andc2 #*01101 #*10100)) ;;; Random tests (deftest bit-andc2.random.1 (bit-random-test-fn #'bit-andc2 #'logandc2) nil) ;;; Error tests (deftest bit-andc2.error.1 (signals-error (bit-andc2) program-error) t) (deftest bit-andc2.error.2 (signals-error (bit-andc2 #*000) program-error) t) (deftest bit-andc2.error.3 (signals-error (bit-andc2 #*000 #*0100 nil nil) program-error) t) gcl27-2.7.0/ansi-tests/bit-aux.lsp000066400000000000000000000052461454061450500166340ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jul 24 19:25:39 2005 ;;;; Contains: Aux file for BIT-* tests (in-package :cl-test) (defun bit-random-test-fn (bit-fn log-fn &key (reps 5000) (maxlen 256)) (assert (typep maxlen '(integer 1))) (assert (typep reps 'unsigned-byte)) (loop for len = (random maxlen) for twos = (make-list len :initial-element 2) for v1 = (map 'bit-vector #'random twos) for v2 = (map 'bit-vector #'random twos) for result = (funcall bit-fn v1 v2) repeat reps unless (and (= (length result) len) (every #'(lambda (result-bit v1-bit v2-bit) (= result-bit (logand 1 (funcall log-fn v1-bit v2-bit)))) result v1 v2)) collect (list len v1 v2 result))) (defun bit-random-test-fn1 (bit-fn log-fn &key (reps 5000) (maxlen 256)) (assert (typep maxlen '(integer 1))) (assert (typep reps 'unsigned-byte)) (loop for len = (random maxlen) for twos = (make-list len :initial-element 2) for vb = (make-array maxlen :element-type 'bit :initial-contents (mapcar 'random twos)) for v1 = (make-array len :element-type 'bit :displaced-to vb :displaced-index-offset (random (- maxlen len))) for v2 = (make-array len :element-type 'bit :displaced-to vb :displaced-index-offset (random (- maxlen len))) for result = (funcall bit-fn v1 v2) repeat reps unless (and (= (length result) len) (every #'(lambda (result-bit v1-bit v2-bit) (= result-bit (logand 1 (funcall log-fn v1-bit v2-bit)))) result v1 v2)) collect (progn (print (setq lll (list len v1 v2 result))) (break)))) (defun bit-random-test-fn2 (bit-fn log-fn &key (reps 5000) (maxlen 256)) (assert (typep maxlen '(integer 1))) (assert (typep reps 'unsigned-byte)) (loop for len = (random maxlen) for twos = (make-list len :initial-element 2) for vb = (make-array maxlen :element-type 'bit :initial-contents (mapcar 'random twos)) for v1 = (make-array len :element-type 'bit :displaced-to vb :displaced-index-offset (random (- maxlen len))) for v2 = (make-array len :element-type 'bit :displaced-to vb :displaced-index-offset (random (- maxlen len))) for vb1 = (make-array maxlen :element-type 'bit) for v3 = (make-array len :element-type 'bit :displaced-to vb1 :displaced-index-offset (random (- maxlen len))) for result = (funcall bit-fn v1 v2 v3) for correct = (map 'bit-vector log-fn v1 v2) for miss = (mismatch result correct) repeat reps when miss return (list v1 v2 result correct miss len (length result)))) (defun bmm (a b c) (let ((i -1)) (map nil (lambda (a b c) (incf i) (unless (eql (logand a b) c) (return-from bmm i))) a b c))) gcl27-2.7.0/ansi-tests/bit-eqv.lsp000066400000000000000000000153211454061450500166250ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:07:23 2003 ;;;; Contains: Tests of BIT-EQV (in-package :cl-test) (compile-and-load "bit-aux.lsp") (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.20 (macrolet ((%m (z) z)) (bit-eqv (expand-in-current-env (%m #*0011)) #*0101)) #*1001) (deftest bit-eqv.21 (macrolet ((%m (z) z)) (bit-eqv #*1010 (expand-in-current-env (%m #*1100)))) #*1001) (deftest bit-eqv.22 (macrolet ((%m (z) z)) (bit-eqv #*10100011 #*01101010 (expand-in-current-env (%m nil)))) #*00110110) (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) (def-fold-test bit-eqv.fold.1 (bit-eqv #*01101 #*10100)) ;;; Random tests (deftest bit-eqv.random.1 (bit-random-test-fn #'bit-eqv #'logeqv) nil) ;;; Error tests (deftest bit-eqv.error.1 (signals-error (bit-eqv) program-error) t) (deftest bit-eqv.error.2 (signals-error (bit-eqv #*000) program-error) t) (deftest bit-eqv.error.3 (signals-error (bit-eqv #*000 #*0100 nil nil) program-error) t) gcl27-2.7.0/ansi-tests/bit-ior.lsp000066400000000000000000000153201454061450500166220ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:13:34 2003 ;;;; Contains: Tests of BIT-IOR (in-package :cl-test) (compile-and-load "bit-aux.lsp") (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.20 (macrolet ((%m (z) z)) (bit-ior (expand-in-current-env (%m #*0011)) #*0101)) #*0111) (deftest bit-ior.21 (macrolet ((%m (z) z)) (bit-ior #*1010 (expand-in-current-env (%m #*1100)))) #*1110) (deftest bit-ior.22 (macrolet ((%m (z) z)) (bit-ior #*10100011 #*01101010 (expand-in-current-env (%m nil)))) #*11101011) (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) (def-fold-test bit-ior.fold.1 (bit-ior #*00101 #*10100)) ;;; Random tests (deftest bit-ior.random.1 (bit-random-test-fn #'bit-ior #'logior) nil) ;;; Error tests (deftest bit-ior.error.1 (signals-error (bit-ior) program-error) t) (deftest bit-ior.error.2 (signals-error (bit-ior #*000) program-error) t) (deftest bit-ior.error.3 (signals-error (bit-ior #*000 #*0100 nil nil) program-error) t) gcl27-2.7.0/ansi-tests/bit-nand.lsp000066400000000000000000000154151454061450500167560ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:16:15 2003 ;;;; Contains: Tests for BIT-NAND (in-package :cl-test) (compile-and-load "bit-aux.lsp") (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.20 (macrolet ((%m (z) z)) (bit-nand (expand-in-current-env (%m #*0011)) #*0101)) #*1110) (deftest bit-nand.21 (macrolet ((%m (z) z)) (bit-nand #*1010 (expand-in-current-env (%m #*1100)))) #*0111) (deftest bit-nand.22 (macrolet ((%m (z) z)) (bit-nand #*10100011 #*01101010 (expand-in-current-env (%m nil)))) #*11011101) (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) (def-fold-test bit-nand.fold.1 (bit-nand #*00101 #*10100)) ;;; Random tests (deftest bit-nand.random.1 (bit-random-test-fn #'bit-nand #'lognand) nil) ;;; Error tests (deftest bit-nand.error.1 (signals-error (bit-nand) program-error) t) (deftest bit-nand.error.2 (signals-error (bit-nand #*000) program-error) t) (deftest bit-nand.error.3 (signals-error (bit-nand #*000 #*0100 nil nil) program-error) t) gcl27-2.7.0/ansi-tests/bit-nor.lsp000066400000000000000000000153211454061450500166300ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:20:40 2003 ;;;; Contains: Tests for BIT-NOR (in-package :cl-test) (compile-and-load "bit-aux.lsp") (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.20 (macrolet ((%m (z) z)) (bit-nor (expand-in-current-env (%m #*0011)) #*0101)) #*1000) (deftest bit-nor.21 (macrolet ((%m (z) z)) (bit-nor #*1010 (expand-in-current-env (%m #*1100)))) #*0001) (deftest bit-nor.22 (macrolet ((%m (z) z)) (bit-nor #*10100011 #*01101010 (expand-in-current-env (%m nil)))) #*00010100) (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) (def-fold-test bit-nor.fold.1 (bit-nor #*00101 #*10100)) ;;; Random tests (deftest bit-nor.random.1 (bit-random-test-fn #'bit-nor #'lognor) nil) ;;; Error tests (deftest bit-nor.error.1 (signals-error (bit-nor) program-error) t) (deftest bit-nor.error.2 (signals-error (bit-nor #*000) program-error) t) (deftest bit-nor.error.3 (signals-error (bit-nor #*000 #*0100 nil nil) program-error) t) gcl27-2.7.0/ansi-tests/bit-not.lsp000066400000000000000000000070341454061450500166340ustar00rootroot00000000000000;-*- 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))) ;;; Macro env tests (deftest bit-not.16 (macrolet ((%m (z) z)) (bit-not (expand-in-current-env (%m #*10010011)))) #*01101100) (deftest bit-not.17 (macrolet ((%m (z) z)) (bit-not #*1101011010 (expand-in-current-env (%m nil)))) #*0010100101) ;;; (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) (def-fold-test bit-not.fold.1 (bit-not #*00101)) ;;; Error tests (deftest bit-not.error.1 (signals-error (bit-not) program-error) t) (deftest bit-not.error.2 (signals-error (bit-not #*000 nil nil) program-error) t) gcl27-2.7.0/ansi-tests/bit-orc1.lsp000066400000000000000000000156541454061450500167070ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:25:28 2003 ;;;; Contains: Tests of BIT-ORC1 (in-package :cl-test) (compile-and-load "bit-aux.lsp") (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.20 (macrolet ((%m (z) z)) (bit-orc1 (expand-in-current-env (%m #*0011)) #*0101)) #*1101) (deftest bit-orc1.21 (macrolet ((%m (z) z)) (bit-orc1 #*1010 (expand-in-current-env (%m #*1100)))) #*1101) (deftest bit-orc1.22 (macrolet ((%m (z) z)) (bit-orc1 #*10100011 #*01101010 (expand-in-current-env (%m nil)))) #*01111110) (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) (deftest bit-orc1.fold.1 (flet ((%f () (declare (optimize speed (safety 0) (space 0))) (bit-orc1 #*11010 #*10100))) (values (%f) (let ((bv (%f))) (setf (elt bv 0) 0) bv) (%f))) #*10101 #*00101 #*10101) ;;; Random tests (deftest bit-orc1.random.1 (bit-random-test-fn #'bit-orc1 #'logorc1) nil) ;;; Error tests (deftest bit-orc1.error.1 (signals-error (bit-orc1) program-error) t) (deftest bit-orc1.error.2 (signals-error (bit-orc1 #*000) program-error) t) (deftest bit-orc1.error.3 (signals-error (bit-orc1 #*000 #*0100 nil nil) program-error) t) gcl27-2.7.0/ansi-tests/bit-orc2.lsp000066400000000000000000000156531454061450500167070ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:31:35 2003 ;;;; Contains: Tests of BIT-ORC2 (in-package :cl-test) (compile-and-load "bit-aux.lsp") (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.20 (macrolet ((%m (z) z)) (bit-orc2 (expand-in-current-env (%m #*0011)) #*0101)) #*1011) (deftest bit-orc2.21 (macrolet ((%m (z) z)) (bit-orc2 #*1010 (expand-in-current-env (%m #*1100)))) #*1011) (deftest bit-orc2.22 (macrolet ((%m (z) z)) (bit-orc2 #*10100011 #*01101010 (expand-in-current-env (%m nil)))) #*10110111) (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) (deftest bit-orc2.fold.1 (flet ((%f () (declare (optimize speed (safety 0) (space 0))) (bit-orc2 #*00101 #*01011))) (values (%f) (let ((bv (%f))) (setf (elt bv 0) 0) bv) (%f))) #*10101 #*00101 #*10101) ;;; Random tests (deftest bit-orc2.random.1 (bit-random-test-fn #'bit-orc2 #'logorc2) nil) ;;; Error tests (deftest bit-orc2.error.1 (signals-error (bit-orc2) program-error) t) (deftest bit-orc2.error.2 (signals-error (bit-orc2 #*000) program-error) t) (deftest bit-orc2.error.3 (signals-error (bit-orc2 #*000 #*0100 nil nil) program-error) t) gcl27-2.7.0/ansi-tests/bit-vector-p.lsp000066400000000000000000000027431454061450500175750ustar00rootroot00000000000000;-*- 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 (check-type-predicate #'bit-vector-p 'bit-vector) nil) (deftest bit-vector-p.13 (macrolet ((%m (z) z)) (values (notnot (bit-vector-p (expand-in-current-env (%m #*110101)))) (bit-vector-p (expand-in-current-env (%m nil))))) t nil) (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 (signals-error (bit-vector-p) program-error) t) (deftest bit-vector-p.error.2 (signals-error (bit-vector-p #* #*) program-error) t) gcl27-2.7.0/ansi-tests/bit-vector.lsp000066400000000000000000000042441454061450500173360ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/bit-xor.lsp000066400000000000000000000153201454061450500166410ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:35:46 2003 ;;;; Contains: Tests of BIT-XOR (in-package :cl-test) (compile-and-load "bit-aux.lsp") (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.20 (macrolet ((%m (z) z)) (bit-xor (expand-in-current-env (%m #*0011)) #*0101)) #*0110) (deftest bit-xor.21 (macrolet ((%m (z) z)) (bit-xor #*1010 (expand-in-current-env (%m #*1100)))) #*0110) (deftest bit-xor.22 (macrolet ((%m (z) z)) (bit-xor #*10100011 #*01101010 (expand-in-current-env (%m nil)))) #*11001001) (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) (def-fold-test bit-xor.fold.1 (bit-xor #*00101 #*10100)) ;;; Random tests (deftest bit-xor.random.1 (bit-random-test-fn #'bit-xor #'logxor) nil) ;;; Error tests (deftest bit-xor.error.1 (signals-error (bit-xor) program-error) t) (deftest bit-xor.error.2 (signals-error (bit-xor #*000) program-error) t) (deftest bit-xor.error.3 (signals-error (bit-xor #*000 #*0100 nil nil) program-error) t) gcl27-2.7.0/ansi-tests/bit.lsp000066400000000000000000000055571454061450500160460ustar00rootroot00000000000000;-*- 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 (signals-error (bit) program-error) t) gcl27-2.7.0/ansi-tests/block.lsp000066400000000000000000000027211454061450500163500ustar00rootroot00000000000000;-*- 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) ;;; Block has no tagbody (deftest block.11 (block done (tagbody (block nil (go 10) 10 (return-from done 'bad)) 10 (return-from done 'good))) good) ;;; Macros are expanded in the appropriate environment (deftest block.12 (macrolet ((%m (z) z)) (block foo (expand-in-current-env (%m :good)))) :good) #| (deftest return.error.1 (signals-error (block nil (return 'a 'b)) program-error) t) |# gcl27-2.7.0/ansi-tests/boole.lsp000066400000000000000000000077351454061450500163700ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Sep 8 20:21:19 2003 ;;;; Contains: Tests of BOOLE and associated constants (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (defparameter *boole-val-names* '(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)) (defparameter *boole-vals* (list 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)) (defparameter *boole-fns* (list #'(lambda (x y) (declare (ignore y)) x) #'(lambda (x y) (declare (ignore x)) y) #'logand #'logandc1 #'logandc2 #'(lambda (x y) (declare (ignore y)) (lognot x)) #'(lambda (x y) (declare (ignore x)) (lognot y)) (constantly 0) #'logeqv #'logior #'lognand #'lognor #'logorc1 #'logorc2 (constantly -1) #'logxor)) (deftest boole.error.1 (signals-error (boole) program-error) t) (deftest boole.error.2 (signals-error (boole boole-1) program-error) t) (deftest boole.error.3 (signals-error (boole boole-1 1) program-error) t) (deftest boole.error.4 (signals-error (boole boole-1 1 2 nil) program-error) t) (deftest boole.error.5 (let ((bad (loop for i from 1 until (not (member i *boole-vals*))))) (eval `(signals-type-error x ',bad (boole x 1 1)))) t) (deftest boole.error.6 (loop for n in *boole-val-names* unless (eval `(signals-type-error x nil (boole ,n nil 1))) collect n) nil) (deftest boole.error.7 (loop for n in *boole-val-names* unless (eval `(signals-type-error x nil (boole ,n 1 nil))) collect n) nil) (deftest boole.1 (loop for v in *boole-vals* for fn of-type function in *boole-fns* for n in *boole-val-names* nconc (loop for x = (random-fixnum) for y = (random-fixnum) for result1 = (funcall (the function fn) x y) for vals = (multiple-value-list (boole v x y)) for result2 = (car vals) repeat 100 unless (and (= (length vals) 1) (eql result1 result2)) collect (list n x y result1 result2))) nil) (deftest boole.2 (loop for v in *boole-vals* for fn of-type function in *boole-fns* for n in *boole-val-names* nconc (loop for x = (random-from-interval 1000000000000000) for y = (random-from-interval 1000000000000000) for result1 = (funcall (the function fn) x y) for vals = (multiple-value-list (boole v x y)) for result2 = (car vals) repeat 100 unless (and (= (length vals) 1) (eql result1 result2)) collect (list n x y result1 result2))) nil) (deftest boole.3 (loop for n in *boole-val-names* for fn of-type function in *boole-fns* for fn2 = (compile nil `(lambda (x y) (declare (type fixnum x y)) (boole ,n x y))) nconc (loop for x = (random-fixnum) for y = (random-fixnum) for result1 = (funcall (the function fn) x y) for vals = (multiple-value-list (funcall fn2 x y)) for result2 = (car vals) repeat 100 unless (and (= (length vals) 1) (eql result1 result2)) collect (list n x y result1 result2))) nil) (deftest boole.4 (macrolet ((%m (z) z)) (values (boole (expand-in-current-env (%m boole-and)) #b11001100 #b01011010) (boole boole-and (expand-in-current-env (%m #b11001100)) #b01011010) (boole boole-and #b11001100 (expand-in-current-env (%m #b01011010))))) #b01001000 #b01001000 #b01001000) ;;; Order of evaluation (deftest boole.order.1 (let ((i 0) a b c) (values (boole (progn (setf a (incf i)) boole-and) (progn (setf b (incf i)) #b1101) (progn (setf c (incf i)) #b11001)) i a b c)) #b1001 3 1 2 3) ;;; Constants are constants (deftest boole.constants.1 (eqlt (length *boole-vals*) (length (remove-duplicates *boole-vals*))) t) (deftest boole.constants.2 (remove-if #'constantp *boole-val-names*) nil) (deftest boole.constants.3 (remove-if #'boundp *boole-val-names*) nil) gcl27-2.7.0/ansi-tests/boundp.lsp000066400000000000000000000022361454061450500165460ustar00rootroot00000000000000;-*- 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 (signals-error (boundp) program-error) t) (deftest boundp.error.2 (signals-error (boundp 'a 'a) program-error) t) (deftest boundp.error.3 (check-type-error #'boundp #'symbolp) nil) (deftest boundp.error.4 (signals-type-error x '(setf car) (boundp x)) t) (deftest boundp.error.5 (signals-type-error x "abc" (boundp x)) t) (deftest boundp.error.6 (signals-type-error x "abc" (locally (boundp x) t)) t) ;;; 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) ;;; See 11.1.2.1.1 (deftest boundp.5 (loop for x in *cl-non-variable-constant-symbols* when (boundp x) collect x) nil) (deftest boundp.6 (macrolet ((%m (z) z)) (boundp (expand-in-current-env (%m '#:foo)))) nil) (deftest boundp.order.1 (let ((i 0) x) (values (boundp (progn (setf x (incf i)) '#:foo)) i x)) nil 1 1) gcl27-2.7.0/ansi-tests/broadcast-stream-streams.lsp000066400000000000000000000012261454061450500221640ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jan 29 22:06:28 2004 ;;;; Contains: Tests of BROADCAST-STREAM-STREAMS (in-package :cl-test) (deftest broadcast-stream-streams.1 (broadcast-stream-streams (make-broadcast-stream)) nil) (deftest broadcast-stream-streams.2 (equalt (broadcast-stream-streams (make-broadcast-stream *standard-output*)) (list *standard-output*)) t) (deftest broadcast-stream-streams.error.1 (signals-error (broadcast-stream-streams) program-error) t) (deftest broadcast-stream-streams.error.2 (signals-error (broadcast-stream-streams (make-broadcast-stream) nil) program-error) t) gcl27-2.7.0/ansi-tests/butlast.lsp000066400000000000000000000045271454061450500167420ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:41:14 2003 ;;;; Contains: Tests of BUTLAST (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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.6 (butlast '(a b c d e) (1+ most-positive-fixnum)) nil) (deftest butlast.7 (butlast '(a b c d e) most-positive-fixnum) nil) (deftest butlast.8 (butlast '(a b c d e) (1- most-positive-fixnum)) nil) (deftest butlast.9 (macrolet ((%m (z) z)) (values (butlast (expand-in-current-env (%m (list 'a 'b 'c)))) (butlast (list 'a 'b 'c 'd 'e) (expand-in-current-env (%m 2))))) (a b) (a b c)) (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) (def-fold-test butlast.fold.1 (butlast '(a b) 1)) (def-fold-test butlast.fold.2 (butlast '(a b c d e f) 3)) (def-fold-test butlast.fold.3 (butlast '(a b c d e f g h i) 7)) ;;; Error tests (deftest butlast.error.1 (signals-error (butlast (copy-tree '(a b c d)) 'a) type-error) t) (deftest butlast.error.2 (signals-error (butlast 'a 0) type-error) t) (deftest butlast.error.3 (signals-error (butlast) program-error) t) (deftest butlast.error.4 (signals-error (butlast '(a b c) 3 3) program-error) t) (deftest butlast.error.5 (signals-error (locally (butlast 'a 0) t) type-error) t) gcl27-2.7.0/ansi-tests/byte.lsp000066400000000000000000000030541454061450500162210ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Sep 11 20:13:22 2003 ;;;; Contains: Tests of BYTE, BYTE-SIZE, and BYTE-POSITION (in-package :cl-test) (deftest byte.error.1 (signals-error (byte) program-error) t) (deftest byte.error.2 (signals-error (byte 1) program-error) t) (deftest byte.error.3 (signals-error (byte 1 1 nil) program-error) t) (deftest byte.1 (progn (byte 0 0) :good) :good) (deftest byte.2 (progn (byte 1 1) :good) :good) (deftest byte.3 (loop for i from 0 to 100 always (loop for j from 0 to 100 always (let ((bspec (byte i j))) (and (eql i (byte-size bspec)) (eql j (byte-position bspec)))))) t) (deftest byte.4 (macrolet ((%m (z) z)) (let ((b (byte (expand-in-current-env (%m 2)) 5))) (values (byte-size b) (byte-position b)))) 2 5) (deftest byte.5 (macrolet ((%m (z) z)) (let ((b (byte 31 (expand-in-current-env (%m 7))))) (values (byte-size b) (byte-position b)))) 31 7) (deftest byte-size.1 (macrolet ((%m (z) z)) (byte-size (expand-in-current-env (%m (byte 3 7))))) 3) (deftest byte-position.1 (macrolet ((%m (z) z)) (byte-position (expand-in-current-env (%m (byte 3 7))))) 7) (deftest byte-position.error.1 (signals-error (byte-position) program-error) t) (deftest byte-position.error.2 (signals-error (byte-position (byte 1 1) nil) program-error) t) (deftest byte-size.error.1 (signals-error (byte-size) program-error) t) (deftest byte-size.error.2 (signals-error (byte-size (byte 1 1) nil) program-error) t) gcl27-2.7.0/ansi-tests/call-arguments-limit.lsp000066400000000000000000000012351454061450500213070ustar00rootroot00000000000000;-*- 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))) (equalt (apply #'list args) args)) t) (deftest call-arguments-limit.5 (< call-arguments-limit lambda-parameters-limit) nil) gcl27-2.7.0/ansi-tests/call-next-method.lsp000066400000000000000000000131341454061450500204230ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 31 11:18:15 2003 ;;;; Contains: Tests of CALL-NEXT-METHOD (in-package :cl-test) ;;; Tests where there is no next method are in no-next-method.lsp (defgeneric cnm-gf-01 (x) (:method ((x integer)) (cons 'a (call-next-method))) (:method ((x rational)) (cons 'b (call-next-method))) (:method ((x real)) (cons 'c (call-next-method))) (:method ((x number)) (cons 'd (call-next-method))) (:method ((x t)) nil)) (deftest call-next-method.1 (mapcar #'cnm-gf-01 '(0 2/3 1.3 #c(1 1) a)) ((a b c d) (b c d) (c d) (d) nil)) ;; Check that call-next-method passes along multiple values correctly (defgeneric cnm-gf-02 (x) (:method ((x integer)) (call-next-method)) (:method ((x number)) (values)) (:method ((x (eql 'a))) (call-next-method)) (:method ((x symbol)) (values 1 2 3 4 5 6))) (deftest call-next-method.2 (cnm-gf-02 0)) (deftest call-next-method.3 (cnm-gf-02 'a) 1 2 3 4 5 6) ;;; Call next method has indefinite extent (defgeneric cnm-gf-03 (x) (:method ((x integer)) #'call-next-method) (:method ((x t)) t)) (deftest call-next-method.4 (funcall (cnm-gf-03 0)) t) ;;; The arguments to c-n-m can be changed (defgeneric cnm-gf-04 (x) (:method ((x integer)) (call-next-method (+ x 10))) (:method ((x number)) (1+ x))) (deftest call-next-method.5 (mapcar #'cnm-gf-04 '(0 1 2 5/3 9/2 1.0 #c(1 1))) (11 12 13 8/3 11/2 2.0 #c(2 1))) ;;; call-next-method goes up the list of applicable methods ;;; which may be to a method with specializers incomparable to ;;; the current method (defgeneric cnm-gf-05 (x y) (:method ((x integer) (y integer)) (cons 'a (call-next-method))) (:method ((x integer) (y t)) (cons 'b (call-next-method))) (:method ((x t) (y integer)) (cons 'c (call-next-method))) (:method ((x t) (y t)) (list 'd))) (deftest call-next-method.6 (mapcar #'cnm-gf-05 '(0 0 t t) '(0 t 0 t)) ((a b c d) (b d) (c d) (d))) (defclass cnm-class-01a () ()) (defclass cnm-class-01b (cnm-class-01a) ()) (defclass cnm-class-01c (cnm-class-01a) ()) (defclass cnm-class-01d (cnm-class-01c cnm-class-01b) ()) (defgeneric cnm-gf-06 (x) (:method ((x cnm-class-01d)) (cons 1 (call-next-method))) (:method ((x cnm-class-01c)) (cons 2 (call-next-method))) (:method ((x cnm-class-01b)) (cons 3 (call-next-method))) (:method ((x cnm-class-01a)) (cons 4 (call-next-method))) (:method ((x t)) nil)) (deftest call-next-method.7 (values (cnm-gf-06 (make-instance 'cnm-class-01d)) (cnm-gf-06 (make-instance 'cnm-class-01c)) (cnm-gf-06 (make-instance 'cnm-class-01b)) (cnm-gf-06 (make-instance 'cnm-class-01a)) (cnm-gf-06 nil)) (1 2 3 4) (2 4) (3 4) (4) nil) ;;; Neither rebinding nor setq affects the arguments passed by ;;; (call-next-method) (defgeneric cnm-gf-07 (x) (:method ((x integer)) (list (incf x) (call-next-method))) (:method ((x symbol)) (list (setq x 'a) x (call-next-method))) (:method ((x cons)) (list x (let ((x :bad)) (declare (ignorable x)) (call-next-method)))) (:method ((x t)) x)) (deftest call-next-method.8 (mapcar #'cnm-gf-07 '(0 z (x) #\a)) ((1 0) (a a z) ((x) (x)) #\a)) ;; Nor does argument defaulting (defgeneric cnm-gf-08 (x &optional y) (:method ((x integer) &optional y) (list* x y (call-next-method))) (:method ((x t) &optional y) (list x y))) (deftest call-next-method.9 (values (cnm-gf-08 0) (cnm-gf-08 0 t) (cnm-gf-08 'a) (cnm-gf-08 'a 'b)) (0 nil 0 nil) (0 t 0 t) (a nil) (a b)) ;;; When c-n-m is called with arguments but omits optionals, those ;;; optionals are defaulted (defgeneric cnm-gf-09 (x &optional y) (:method ((x integer) &optional y) (list* x y (call-next-method (1+ x)))) (:method ((x t) &optional y) (list x y))) (deftest call-next-method.10 (values (cnm-gf-09 5) (cnm-gf-09 8 'a) (cnm-gf-09 'x) (cnm-gf-09 'x 'y)) (5 nil 6 nil) (8 a 9 nil) (x nil) (x y)) (defgeneric cnm-gf-10 (x &optional y z) (:method ((x integer) &optional (y 'a y-p) (z 'b z-p)) (list* x y (notnot y-p) z (notnot z-p) (call-next-method (1+ x)))) (:method ((x t) &optional (y 'c y-p) (z 'd z-p)) (list x y (notnot y-p) z (notnot z-p)))) (deftest call-next-method.11 (values (cnm-gf-10 5) (cnm-gf-10 8 'p) (cnm-gf-10 8 'p 'q) (cnm-gf-10 'x) (cnm-gf-10 'x 'u) (cnm-gf-10 'x 'u 'v)) (5 a nil b nil 6 c nil d nil) (8 p t b nil 9 c nil d nil) (8 p t q t 9 c nil d nil) (x c nil d nil) (x u t d nil) (x u t v t)) ;;; "When providing arguments to call-next-method, the following ;;; rule must be satisfied or an error of type error should be signaled: ;;; the ordered set of applicable methods for a changed set of arguments ;;; for call-next-method must be the same as the ordered set of applicable ;;; methods for the original arguments to the generic function." (defgeneric cnm-order-error-gf-01 (x) (declare (optimize (safety 3))) (:method ((x (eql 0))) (declare (optimize (safety 3))) (call-next-method 1)) ;; no longer EQL to 0 (:method ((x t)) nil)) (deftest call-next-method.error.1 (locally (declare (optimize (safety 3))) (handler-case (eval '(locally (declare (optimize (safety 3))) (cnm-order-error-gf-01 0))) (error () :error))) :error) (defgeneric cnm-order-error-gf-02 (x) (declare (optimize (safety 3))) (:method ((x integer)) (declare (optimize (safety 3))) (call-next-method :bad)) (:method ((x t)) x)) (deftest call-next-method.error.2 (locally (declare (optimize (safety 3))) (handler-case (eval '(locally (declare (optimize (safety 3))) (cnm-order-error-gf-02 0))) (error () :error))) :error) gcl27-2.7.0/ansi-tests/case.lsp000066400000000000000000000070611454061450500161730ustar00rootroot00000000000000;-*- 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) ;;; No implicit tagbody (deftest case.35 (block done (tagbody (case 'a (a (go 10) 10 (return-from done 'bad))) 10 (return-from done 'good))) good) (deftest case.36 (block done (tagbody (case 'b (a 'bad) (otherwise (go 10) 10 (return-from done 'bad))) 10 (return-from done 'good))) good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest case.37 (macrolet ((%m (z) z)) (case (expand-in-current-env (%m :b)) (:a :bad1) (:b :good) (:c :bad2) (t :bad3))) :good) ;;; (deftest case.error.1 ;;; (signals-error (case) program-error) ;;; t) (deftest case.error.1 (signals-error (funcall (macro-function 'case)) program-error) t) (deftest case.error.2 (signals-error (funcall (macro-function 'case) '(case t)) program-error) t) (deftest case.error.3 (signals-error (funcall (macro-function 'case) '(case t) nil nil) program-error) t) gcl27-2.7.0/ansi-tests/catch.lsp000066400000000000000000000035271454061450500163450ustar00rootroot00000000000000;-*- 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) ;;; No implicit tagbody (deftest catch.13 (block done (tagbody (catch 'foo (go 10) 10 (return-from done 'bad)) 10 (return-from done 'good))) good) ;;; Macros are expanded in the appropriate environment (deftest catch.14 (macrolet ((%m (z) z)) (catch 'foo (expand-in-current-env (%m :good)))) :good) (deftest catch.15 (macrolet ((%m (z) z)) (catch 'foo (throw (expand-in-current-env (%m 'foo)) :good) :bad)) :good) (deftest catch.16 (macrolet ((%m (z) z)) (catch 'foo (throw 'foo (expand-in-current-env (%m :good))) :bad)) :good) (deftest throw-error (signals-error (throw (gensym) nil) control-error) t) gcl27-2.7.0/ansi-tests/ccase.lsp000066400000000000000000000073361454061450500163430ustar00rootroot00000000000000;-*- 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 (signals-type-error x 1 (ccase x)) t) (deftest ccase.3 (signals-type-error x 1 (ccase x (a 1) (b 2) (c 3))) t) ;;; It is legal to use T or OTHERWISE as key designators ;;; in CCASE forms. They have no special meaning here. (deftest ccase.4 (signals-type-error x 1 (ccase x (t nil))) t) (deftest ccase.5 (signals-type-error x 1 (ccase x (otherwise nil))) t) (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 (signals-type-error x nil (ccase x (nil 'a))) t) (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 (signals-type-error x t (ccase x (a 10))) t) (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 (signals-type-error x 'otherwise (ccase x ((t) 10))) t) (deftest ccase.16 (signals-type-error x t (ccase x ((otherwise) 10))) t) (deftest ccase.17 (signals-type-error x 'a (ccase x (b 0) (c 1) (otherwise 2))) t) (deftest ccase.19 (signals-type-error x 'a (ccase x (b 0) (c 1) ((t) 2))) t) (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) ;;; No implicit tagbody (deftest ccase.32 (block done (tagbody (let ((x 'a)) (ccase x (a (go 10) 10 (return-from done 'bad)))) 10 (return-from done 'good))) good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest ccase.33 (let ((x :b)) (macrolet ((%m (z) z)) (ccase (expand-in-current-env (%m x)) (:a :bad1) (:b :good) (:c :bad2)))) :good) ;;; (deftest ccase.error.1 ;;; (signals-error (ccase) program-error) ;;; t) (deftest ccase.error.1 (signals-error (funcall (macro-function 'ccase)) program-error) t) (deftest ccase.error.2 (signals-error (funcall (macro-function 'ccase) '(ccase t)) program-error) t) (deftest ccase.error.3 (signals-error (funcall (macro-function 'ccase) '(ccase t) nil nil) program-error) t) gcl27-2.7.0/ansi-tests/ceiling-aux.lsp000066400000000000000000000050521454061450500174630ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Aug 19 06:52:02 2003 ;;;; Contains: Aux. functions for CEILING (in-package :cl-test) (defun ceiling.1-fn () (loop for n = (- (random 2000000000) 1000000000) for d = (1+ (random 10000)) for vals = (multiple-value-list (ceiling n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (= n n2) (integerp r) (< (- d) r 1)) collect (list n d q r n2))) (defun ceiling.2-fn () (loop for num = (random 1000000000) for denom = (1+ (random 1000)) for n = (/ num denom) for d = (1+ (random 10000)) for vals = (multiple-value-list (ceiling n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (<= r 0) (< (- d) r) (= n n2)) collect (list n d q r n2))) (defun ceiling.3-fn (width) (loop for n = (- (random width) (/ width 2)) for vals = (multiple-value-list (ceiling n)) for (q r) = vals for n2 = (+ q r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (= n n2) (<= 0 (- r)) (< (- r) 1) ) collect (list n q r n2))) (defun ceiling.7-fn () (loop for numerator = (- (random 10000000000) 5000000000) for denominator = (1+ (random 100000)) for n = (/ numerator denominator) for vals = (multiple-value-list (ceiling n)) for (q r) = vals for n2 = (+ q r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (rationalp r) (= n n2) (<= 0 (- r)) (< (- r) 1) ) collect (list n q r n2))) (defun ceiling.8-fn () (loop for num1 = (- (random 10000000000) 5000000000) for den1 = (1+ (random 100000)) for n = (/ num1 den1) for num2 = (- (1+ (random 1000000))) for den2 = (1+ (random 1000000)) for d = (/ num2 den2) for vals = (multiple-value-list (ceiling n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (rationalp r) (<= 0 r) (< r (- d)) (= n n2)) collect (list n q d r n2))) (defun ceiling.9-fn () (loop for num1 = (- (random 1000000000000000) 500000000000000) for den1 = (1+ (random 10000000000)) for n = (/ num1 den1) for num2 = (- (1+ (random 1000000000))) for den2 = (1+ (random 10000000)) for d = (/ num2 den2) for vals = (multiple-value-list (ceiling n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (rationalp r) (<= 0 r) (< r (- d)) (= n n2)) collect (list n q d r n2))) gcl27-2.7.0/ansi-tests/ceiling.lsp000066400000000000000000000073471454061450500167010ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Aug 19 06:50:44 2003 ;;;; Contains: Tests of CEILING (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "ceiling-aux.lsp") (deftest ceiling.error.1 (signals-error (ceiling) program-error) t) (deftest ceiling.error.2 (signals-error (ceiling 1.0 1 nil) program-error) t) ;;; (deftest ceiling.1 (ceiling.1-fn) nil) (deftest ceiling.2 (ceiling.2-fn) nil) (deftest ceiling.3 (ceiling.3-fn 2.0s4) nil) (deftest ceiling.4 (ceiling.3-fn 2.0f4) nil) (deftest ceiling.5 (ceiling.3-fn 2.0d4) nil) (deftest ceiling.6 (ceiling.3-fn 2.0l4) nil) (deftest ceiling.7 (ceiling.7-fn) nil) (deftest ceiling.8 (ceiling.8-fn) nil) (deftest ceiling.9 (ceiling.9-fn) nil) (deftest ceiling.10 (loop for x in (remove-if #'zerop *reals*) for (q r) = (multiple-value-list (ceiling x x)) unless (and (eql q 1) (zerop r) (if (rationalp x) (eql r 0) (eql r (float 0 x)))) collect x) nil) (deftest ceiling.11 (loop for x in (remove-if #'zerop *reals*) for (q r) = (multiple-value-list (ceiling (- x) x)) unless (and (eql q -1) (zerop r) (if (rationalp x) (eql r 0) (eql r (float 0 x)))) collect x) nil) (deftest ceiling.12 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (ceiling x)) unless (and (eql q (1+ i)) (eql r (- rrad 1))) collect (list i x q r))) nil) (deftest ceiling.13 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (ceiling x)) unless (and (eql q i) (eql r (- rrad 1))) collect (list i x q r))) nil) (deftest ceiling.14 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (ceiling x)) unless (and (eql q (1+ i)) (eql r (- rrad 1))) collect (list i x q r))) nil) (deftest ceiling.15 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (ceiling x)) unless (and (eql q i) (eql r (- rrad 1))) collect (list i x q r))) nil) (deftest ceiling.16 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (ceiling x)) unless (and (eql q (1+ i)) (eql r (- rrad 1))) collect (list i x q r))) nil) (deftest ceiling.17 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (ceiling x)) unless (and (eql q i) (eql r (- rrad 1))) collect (list i x q r))) nil) (deftest ceiling.18 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (ceiling x)) unless (and (eql q (1+ i)) (eql r (- rrad 1))) collect (list i x q r))) nil) (deftest ceiling.19 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (ceiling x)) unless (and (eql q i) (eql r (- rrad 1))) collect (list i x q r))) nil) ;;; To add: tests that involve adding/subtracting EPSILON constants ;;; (suitably scaled) to floated integers. gcl27-2.7.0/ansi-tests/cell-error-name.lsp000066400000000000000000000022741454061450500202450ustar00rootroot00000000000000;-*- 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 (signals-error (cell-error-name) program-error) t) (deftest cell-error-name.error.2 (signals-error (cell-error-name (make-condition 'unbound-variable :name 'foo) nil) program-error) t) gcl27-2.7.0/ansi-tests/cerror.lsp000066400000000000000000000032321454061450500165500ustar00rootroot00000000000000;-*- 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.2a (let* ((fmt (formatter "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.4a (let ((fmt (formatter "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) ;;; Program error cases (deftest cerror.error.1 (signals-error (cerror) program-error) t) (deftest cerror.error.2 (signals-error (cerror "foo") program-error) t) gcl27-2.7.0/ansi-tests/change-class.lsp000066400000000000000000000441631454061450500176140ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 3 14:23:29 2003 ;;;; Contains: Tests of CHANGE-CLASS (in-package :cl-test) (defclass change-class-class-01a () ((a :initarg :a) (b :initarg :b) (c :initarg :c))) (defclass change-class-class-01b () ((c :initarg :c2) (d :initarg :d2) (b :initarg :b2))) (deftest change-class.1.1 (let ((obj (make-instance 'change-class-class-01a)) (new-class (find-class 'change-class-class-01b))) (values (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (map-slot-boundp* obj '(a b c)) (slot-exists-p obj 'd) (eqt obj (change-class obj new-class)) (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (slot-exists-p obj 'a) (map-slot-boundp* obj '(b c d)))) t nil (nil nil nil) nil t nil t nil (nil nil nil)) (deftest change-class.1.2 (let ((obj (make-instance 'change-class-class-01a :a 1)) (new-class (find-class 'change-class-class-01b))) (values (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (map-slot-boundp* obj '(a b c)) (slot-exists-p obj 'd) (eqt obj (change-class obj new-class)) (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (slot-exists-p obj 'a) (map-slot-boundp* obj '(b c d)))) t nil (t nil nil) nil t nil t nil (nil nil nil)) (deftest change-class.1.3 (let ((obj (make-instance 'change-class-class-01a :b 2)) (new-class (find-class 'change-class-class-01b))) (values (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (map-slot-boundp* obj '(a b c)) (slot-exists-p obj 'd) (eqt obj (change-class obj new-class)) (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (slot-exists-p obj 'a) (map-slot-boundp* obj '(b c d)) (slot-value obj 'b))) t nil (nil t nil) nil t nil t nil (t nil nil) 2) (deftest change-class.1.4 (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5)) (new-class (find-class 'change-class-class-01b))) (values (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (map-slot-boundp* obj '(a b c)) (slot-exists-p obj 'd) (eqt obj (change-class obj new-class)) (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (slot-exists-p obj 'a) (map-slot-boundp* obj '(b c d)) (map-slot-value obj '(b c)))) t nil (t t t) nil t nil t nil (t t nil) (2 5)) (deftest change-class.1.5 (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5)) (new-class (find-class 'change-class-class-01b))) (values (eqt obj (change-class obj new-class :b2 8 :c2 76)) (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (slot-exists-p obj 'a) (map-slot-boundp* obj '(b c d)) (map-slot-value obj '(b c)))) t nil t nil (t t nil) (8 76)) (deftest change-class.1.6 (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5)) (new-class (find-class 'change-class-class-01b))) (values (eqt obj (change-class obj new-class :b2 19 :b2 34)) (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (slot-exists-p obj 'a) (map-slot-boundp* obj '(b c d)) (map-slot-value obj '(b c)))) t nil t nil (t t nil) (19 5)) (deftest change-class.1.7 (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5)) (new-class (find-class 'change-class-class-01b))) (values (eqt obj (change-class obj new-class :allow-other-keys nil)) (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (slot-exists-p obj 'a) (map-slot-boundp* obj '(b c d)) (map-slot-value obj '(b c)))) t nil t nil (t t nil) (2 5)) (deftest change-class.1.8 (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5)) (new-class (find-class 'change-class-class-01b))) (values (eqt obj (change-class obj new-class :allow-other-keys t)) (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (slot-exists-p obj 'a) (map-slot-boundp* obj '(b c d)) (map-slot-value obj '(b c)))) t nil t nil (t t nil) (2 5)) (deftest change-class.1.9 (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5)) (new-class (find-class 'change-class-class-01b))) (values (eqt obj (change-class obj new-class :allow-other-keys t :nonsense t)) (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (slot-exists-p obj 'a) (map-slot-boundp* obj '(b c d)) (map-slot-value obj '(b c)))) t nil t nil (t t nil) (2 5)) (deftest change-class.1.10 (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5)) (new-class (find-class 'change-class-class-01b))) (values (eqt obj (change-class obj new-class :bad 0 :allow-other-keys t :allow-other-keys nil :nonsense t)) (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (slot-exists-p obj 'a) (map-slot-boundp* obj '(b c d)) (map-slot-value obj '(b c)))) t nil t nil (t t nil) (2 5)) (deftest change-class.1.11 (handler-case (eval '(let ((obj (make-instance 'change-class-class-01a)) (new-class (find-class 'change-class-class-01b))) (declare (optimize (safety 3))) (eqt obj (change-class obj new-class :nonsense t)))) (error () :expected-error)) :expected-error) ;; test of class name as second argument (deftest change-class.1.12 (let ((obj (make-instance 'change-class-class-01a :b 1)) ;; (new-class (find-class 'change-class-class-01b)) ) (values (eqt obj (change-class obj 'change-class-class-01b :c2 3)) (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (slot-exists-p obj 'a) (map-slot-boundp* obj '(b c d)) (map-slot-value obj '(b c)))) t nil t nil (t t nil) (1 3)) ;;; Shared slots (defclass change-class-class-02a () ((a :initarg :a :allocation :class) (b :initarg :b :allocation :class))) (defclass change-class-class-02b () ((a :initarg :a2) (b :initarg :b2))) (deftest change-class.2.1 (let ((obj (make-instance 'change-class-class-02a)) (new-class (find-class 'change-class-class-02b))) (slot-makunbound obj 'a) (slot-makunbound obj 'b) (values (map-slot-boundp* obj '(a b)) (eqt obj (change-class obj new-class)) (typep* obj 'change-class-class-02a) (typep* obj 'change-class-class-02b) (map-slot-boundp* (make-instance 'change-class-class-02a) '(a b)) (map-slot-boundp* obj '(a b)))) (nil nil) t nil t (nil nil) (nil nil)) (deftest change-class.2.2 (let ((obj (make-instance 'change-class-class-02a)) (obj2 (make-instance 'change-class-class-02a)) obj3 (new-class (find-class 'change-class-class-02b))) (setf (slot-value obj 'a) 'foo) (slot-makunbound obj 'b) (values (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj2 'a) (eqt obj (change-class obj new-class)) (typep* obj 'change-class-class-02a) (typep* obj 'change-class-class-02b) (map-slot-boundp* (setf obj3 (make-instance 'change-class-class-02a)) '(a b)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj2 'a) (slot-value obj3 'a) (eqt obj obj2) (eqt obj obj3) (eqt obj2 obj3) )) (t nil) foo foo t nil t (t nil) (t nil) foo foo foo nil nil nil) (deftest change-class.2.3 (let ((obj (make-instance 'change-class-class-02a)) (obj2 (make-instance 'change-class-class-02a)) (new-class (find-class 'change-class-class-02b))) (setf (slot-value obj 'a) 1 (slot-value obj 'b) 16) (values (map-slot-boundp* obj '(a b)) (eqt obj (change-class obj new-class)) (typep* obj 'change-class-class-02a) (typep* obj 'change-class-class-02b) (map-slot-boundp* obj2 '(a b)) (map-slot-boundp* (make-instance 'change-class-class-02a) '(a b)) (map-slot-boundp* obj '(a b)) (progn (slot-makunbound obj2 'a) (slot-makunbound obj2 'b) (map-slot-boundp* obj '(a b))))) (t t) t nil t (t t) (t t) (t t) (t t)) ;;; Destination slots are shared (defclass change-class-class-03a () ((a :initarg :a) (b :initarg :b))) (defclass change-class-class-03b () ((a :allocation :class :initarg :a2) (b :allocation :class :initarg :b2))) (deftest change-class.3.1 (let* ((obj (make-instance 'change-class-class-03a)) (new-class (find-class 'change-class-class-03b)) (obj2 (make-instance new-class)) obj3) (slot-makunbound obj2 'a) (slot-makunbound obj2 'b) (values (eqt obj (change-class obj new-class)) (typep* obj 'change-class-class-03a) (typep* obj 'change-class-class-03b) (typep* obj new-class) (eqt (setq obj3 (make-instance new-class)) obj) (map-slot-boundp* obj '(a b)) (map-slot-boundp* obj2 '(a b)) (map-slot-boundp* obj3 '(a b)) )) t nil t t nil (nil nil) (nil nil) (nil nil)) (deftest change-class.3.2 (let* ((obj (make-instance 'change-class-class-03a :a 1)) (new-class (find-class 'change-class-class-03b)) (obj2 (make-instance new-class)) obj3) (slot-makunbound obj2 'a) (setf (slot-value obj2 'b) 17) (values (map-slot-boundp* obj2 '(a b)) (eqt obj (change-class obj new-class)) (typep* obj 'change-class-class-03a) (typep* obj 'change-class-class-03b) (typep* obj new-class) (eqt (setq obj3 (make-instance new-class)) obj) (map-slot-boundp* obj '(a b)) (map-slot-boundp* obj2 '(a b)) (map-slot-boundp* obj3 '(a b)) (slot-value obj 'b) (slot-value obj2 'b) (slot-value obj3 'b) )) (nil t) t nil t t nil (nil t) (nil t) (nil t) 17 17 17) ;;; Destination class has slot initforms (defclass change-class-class-04a () ((a :initarg :a) (b :initarg :b))) (defclass change-class-class-04b () ((a :initform 'x :initarg :a2) (c :initform 'y :initarg :c2))) (deftest change-class.4.1 (let ((obj (make-instance 'change-class-class-04a)) (new-class (find-class 'change-class-class-04b))) (values (eqt obj (change-class obj new-class)) (map-slot-boundp* obj '(a c)) (slot-value obj 'c))) t (nil t) y) (deftest change-class.4.2 (let ((obj (make-instance 'change-class-class-04a)) (new-class (find-class 'change-class-class-04b))) (values (eqt obj (change-class obj new-class :a2 'z)) (map-slot-value obj '(a c)))) t (z y)) (deftest change-class.4.3 (let ((obj (make-instance 'change-class-class-04a :a 'p :b 'q)) (new-class (find-class 'change-class-class-04b))) (values (eqt obj (change-class obj new-class)) (map-slot-value obj '(a c)))) t (p y)) (deftest change-class.4.4 (let ((obj (make-instance 'change-class-class-04a)) (new-class (find-class 'change-class-class-04b))) (values (eqt obj (change-class obj new-class :c2 'k)) (map-slot-boundp* obj '(a c)) (slot-value obj 'c))) t (nil t) k) (deftest change-class.4.5 (let* ((class (find-class 'change-class-class-04b)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a c)) (eqt obj (change-class obj class)) (map-slot-boundp* obj '(a c)))) (nil nil) t (nil nil)) ;;; Custom methods for change-class (declaim (special *changed-class-on-class-05*)) (defclass change-class-class-05 () (a b c)) (report-and-ignore-errors (defmethod change-class ((obj change-class-class-05) (new-class (eql (find-class 'change-class-class-05))) &rest initargs &key &allow-other-keys) (declare (ignore initargs new-class)) (setq *changed-class-on-class-05* t) obj)) (deftest change-class.5 (let ((*changed-class-on-class-05* nil) (obj (make-instance 'change-class-class-05))) (values (eqt obj (change-class obj (find-class 'change-class-class-05))) *changed-class-on-class-05*)) t t) ;;; Method that invokes the standard method with call-next-method (defclass change-class-class-06 () ((a :initarg :a) (b :initarg :b) (c :initarg :c))) (report-and-ignore-errors (defmethod change-class ((obj change-class-class-06) (new-class standard-class) &rest initargs &key &allow-other-keys) (declare (ignore initargs)) (setf (slot-value obj 'a) 123) (call-next-method))) (deftest change-class.6.1 (let* ((class (find-class 'change-class-class-06)) (obj (make-instance class))) (values (map-slot-boundp* obj '(a b c)) (eqt obj (change-class obj class)) (map-slot-boundp* obj '(a b c)) (slot-value obj 'a) )) (nil nil nil) t (t nil nil) 123) (deftest change-class.6.2 (let* ((class (find-class 'change-class-class-06)) (obj (make-instance class :a 'bad))) (values (map-slot-boundp* obj '(a b c)) (eqt obj (change-class obj class)) (map-slot-boundp* obj '(a b c)) (slot-value obj 'a) )) (t nil nil) t (t nil nil) 123) ;;; Before method (defclass change-class-class-07 () ((a :initform 'x :initarg :a) (b :initform 'y :initarg :b) (c :initarg :c))) (defclass change-class-class-07b () ((a :initform 'aa :initarg :a) (d :initform 'dd :initarg :d))) (report-and-ignore-errors (defmethod change-class :before ((obj change-class-class-07) (new-class standard-class) &rest initargs &key &allow-other-keys) (declare (ignore initargs)) (setf (slot-value obj 'a) 'z) obj)) (deftest change-class.7.1 (let* ((class (find-class 'change-class-class-07)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b c)) (eqt obj (change-class obj class)) (map-slot-boundp* obj '(a b c)) (slot-value obj 'a))) (nil nil nil) t (t nil nil) z) (deftest change-class.7.2 (let* ((class (find-class 'change-class-class-07)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b c)) (eqt obj (change-class obj class :a 10)) (map-slot-boundp* obj '(a b c)) (slot-value obj 'a))) (nil nil nil) t (t nil nil) 10) (deftest change-class.7.3 (let* ((class (find-class 'change-class-class-07)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b c)) (eqt obj (change-class obj class :b 10)) (map-slot-boundp* obj '(a b c)) (slot-value obj 'a) (slot-value obj 'b))) (nil nil nil) t (t t nil) z 10) (deftest change-class.7.4 (let* ((class (find-class 'change-class-class-07)) (new-class (find-class 'change-class-class-07b)) (obj (allocate-instance class))) (values (eqt obj (change-class obj new-class)) (map-slot-boundp* obj '(a d)) (slot-value obj 'a) (slot-value obj 'd))) t (t t) z dd) (deftest change-class.7.5 (let* ((class (find-class 'change-class-class-07)) (new-class (find-class 'change-class-class-07b)) (obj (allocate-instance class))) (values (eqt obj (change-class obj new-class :allow-other-keys nil)) (map-slot-boundp* obj '(a d)) (slot-value obj 'a) (slot-value obj 'd))) t (t t) z dd) (deftest change-class.7.6 (let* ((class (find-class 'change-class-class-07)) (new-class (find-class 'change-class-class-07b)) (obj (allocate-instance class))) (values (eqt obj (change-class obj new-class :allow-other-keys t)) (map-slot-boundp* obj '(a d)) (slot-value obj 'a) (slot-value obj 'd))) t (t t) z dd) ;;; After method (report-and-ignore-errors (defclass change-class-class-08 () ((a :initarg :a) (b :initarg :b)))) (report-and-ignore-errors (defmethod change-class :after ((obj change-class-class-08) (class (eql (find-class 'change-class-class-08))) &rest initargs &key &allow-other-keys) (declare (ignore initargs)) (setf (slot-value obj 'a) 'z) obj)) (deftest change-class.8.1 (let* ((class (find-class 'change-class-class-08)) (obj (make-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (change-class obj class)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a))) (nil nil) t (t nil) z) (deftest change-class.8.2 (let* ((class (find-class 'change-class-class-08)) (obj (make-instance class :a 1 :b 2))) (values (map-slot-boundp* obj '(a b)) (eqt obj (change-class obj class)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) (t t) t (t t) z 2) (deftest change-class.8.3 (let* ((class (find-class 'change-class-class-08)) (obj (make-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (change-class obj class :a 12 :b 17)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) (nil nil) t (t t) z 17) ;;; Put around method test here ;;; Put more inheritance tests here ;;; Error tests (deftest change-class.error.1 (signals-error (change-class) program-error) t) (deftest change-class.error.2 (signals-error (change-class (make-instance 'change-class-class-01a)) program-error) t) (deftest change-class.error.3 (signals-error (let ((obj (make-instance 'change-class-class-01a)) (new-class (find-class 'change-class-class-01b))) (change-class obj new-class :c2)) program-error) t) (deftest change-class.error.4 (signals-error (let ((obj (make-instance 'change-class-class-01a)) (new-class (find-class 'change-class-class-01b))) (change-class obj new-class '(nonsense) 'a)) program-error) t) ;;; According to the page for BUILT-IN-CLASS, using CHANGE-CLASS ;;; to change the class to/from a builtin class should raise a ;;; signal of type ERROR. (deftest change-class.error.5 (let ((built-in-class (find-class 'built-in-class))) (loop for e in *mini-universe* for class = (class-of e) when (and (eq (class-of class) built-in-class) (handler-case (progn (change-class (make-instance 'change-class-class-01a) class) t) (error () nil))) collect e)) nil) (deftest change-class.error.6 (let ((built-in-class (find-class 'built-in-class))) (loop for e in *mini-universe* for class = (class-of e) when (and (eq (class-of class) built-in-class) (handler-case (progn (change-class e (find-class 'change-class-class-01a)) t) (error () nil))) collect e)) nil) gcl27-2.7.0/ansi-tests/char-aux.lsp000066400000000000000000000220321454061450500167630ustar00rootroot00000000000000;-*- 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) (declare (type function 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) (declare (type function fn)) (and (is-ordered-by seq fn) (is-ordered-by (reverse seq) (complement fn)))) (defun is-case-insensitive (fn) (when (symbolp fn) (assert (fboundp fn)) (setf fn (symbol-function fn))) (assert (typep fn 'function)) (locally (declare (type function 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) (when (symbolp fn) (assert (fboundp fn)) (setf fn (symbol-function fn))) (assert (typep fn 'function)) (locally (declare (type function fn)) (loop for x in *universe* always (or (characterp x) ;; FIXME -- catch the type error and check that datum ;; is eql to x (and that datum is not in the expected type) (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 'base-char) (typep c 'extended-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 (my-aref 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.old () (loop for r from 2 to 36 always (loop for i from 0 to 36 always (let* ((c (digit-char i r)) (result (if (>= i r) (null c) (eqlt c (char +extended-digit-chars+ i))))) (unless result (format t "~A ~A ~A~%" r i c)) result)))) (defun digit-char.1.body () (loop for r from 2 to 36 nconc (loop for i from 0 to 36 for c = (digit-char i r) unless (if (>= i r) (null c) (eqlt c (char +extended-digit-chars+ i))) collect (list r i c)))) (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)))))) (or (loop for i from 0 below (min (ash 1 16) char-code-limit) unless (%insert (code-char i)) collect i) (loop for i = (random char-code-limit) repeat 1000 unless (%insert (code-char i)) collect i) (find-if-not #'%insert +standard-chars+) (find-if-not #'%insert *universe*))))) (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 (min (ash 1 16) 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) ;; FIXME The rest of this wasn't reachable #| (let ((name (char-name c))) (declare (type (or null string) name)) (and name (string-equal name s))) |# ))))) gcl27-2.7.0/ansi-tests/char-compare.lsp000066400000000000000000000363711454061450500176270ustar00rootroot00000000000000;-*- 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 `(signals-error (funcall ',f) program-error))) (t t t t t t t t t t t t)) (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) gcl27-2.7.0/ansi-tests/char-schar.lsp000066400000000000000000000101711454061450500172670ustar00rootroot00000000000000;-*- 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) ;;; Error tests (deftest char.error.1 (signals-error (char) program-error) t) (deftest char.error.2 (signals-error (char "abc") program-error) t) (deftest char.error.3 (signals-error (char "abc" 1 nil) program-error) t) ;;; 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) ;;; Error tests (deftest schar.error.1 (signals-error (schar) program-error) t) (deftest schar.error.2 (signals-error (schar "abc") program-error) t) (deftest schar.error.3 (signals-error (schar "abc" 1 nil) program-error) t) gcl27-2.7.0/ansi-tests/character.lsp000066400000000000000000000270471454061450500172220ustar00rootroot00000000000000;-*- 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 (signals-error (character) program-error) t) (deftest character.error.2 (signals-error (character #\a #\a) program-error) t) ;;; (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 (signals-error (characterp) program-error) t) (deftest characterp.error.2 (signals-error (characterp #\a #\b) program-error) t) (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.4 (macrolet ((%m (z) z)) (alpha-char-p (expand-in-current-env (%m #\?)))) nil) (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 (signals-error (alpha-char-p) program-error) t) (deftest alpha-char-p.error.2 (signals-error (alpha-char-p #\a #\b) program-error) t) ;;; (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 alphanumbericp.6 (macrolet ((%m (z) z)) (alphanumericp (expand-in-current-env (%m #\=)))) nil) (deftest alphanumericp.order.1 (let ((i 0)) (values (alphanumericp (progn (incf i) #\?)) i)) nil 1) (deftest alphanumericp.error.1 (signals-error (alphanumericp) program-error) t) (deftest alphanumericp.error.2 (signals-error (alphanumericp #\a #\b) program-error) t) ;;; (deftest digit-char.1 (digit-char.1.body) nil) (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 (signals-error (digit-char) program-error) t) (deftest digit-char.error.2 (signals-error (digit-char 0 10 'foo) program-error) t) ;;; (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 (signals-error (digit-char-p) program-error) t) (deftest digit-char-p.error.2 (signals-error (digit-char-p #\1 10 'foo) program-error) t) ;;; (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 (signals-error (graphic-char-p) program-error) t) (deftest graphic-char-p.error.2 (signals-error (graphic-char-p #\a #\a) program-error) t) ;;; (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 (signals-error (standard-char-p) program-error) t) (deftest standard-char-p.error.2 (signals-error (standard-char-p #\a #\a) program-error) t) ;;; (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 (signals-error (char-upcase) program-error) t) (deftest char-upcase.error.2 (signals-error (char-upcase #\a #\a) program-error) t) ;;; (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 (signals-error (char-downcase) program-error) t) (deftest char-downcase.error.2 (signals-error (char-downcase #\A #\A) program-error) t) ;;; (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 (signals-error (upper-case-p) program-error) t) (deftest upper-case-p.error.2 (signals-error (upper-case-p #\a #\A) program-error) t) ;;; (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 (signals-error (lower-case-p) program-error) t) (deftest lower-case-p.error.2 (signals-error (lower-case-p #\a #\a) program-error) t) ;;; (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.4 (notnot (macrolet ((%m (z) z)) (both-case-p (expand-in-current-env (%m #\a))))) 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 (signals-error (both-case-p) program-error) t) (deftest both-case-p.error.2 (signals-error (both-case-p #\a #\a) program-error) t) ;;; (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 (signals-error (char-code) program-error) t) (deftest char-code.error.2 (signals-error (char-code #\a #\a) program-error) t) ;;; (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 (signals-error (code-char) program-error) t) (deftest code-char.error.2 (signals-error (code-char 1 1) program-error) t) ;;; (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) nil) (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 (signals-error (char-int) program-error) t) (deftest char-int.error.2 (signals-error (char-int #\a #\a) program-error) t) ;;; (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 (signals-error (char-name) program-error) t) (deftest char-name.error.2 (signals-error (char-name #\a #\a) program-error) t) gcl27-2.7.0/ansi-tests/check-type.lsp000066400000000000000000000041431454061450500173120ustar00rootroot00000000000000;-*- 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 (signals-type-error x 'a (check-type x integer)) t) (deftest check-type.3 (let ((x 'a)) (handler-bind ((type-error #'(lambda (c) (assert (eql (type-error-datum c) x)) (assert (not (typep x (type-error-expected-type c)))) ;; Can we assume the expected-type is NUMBER? (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) (assert (eql (type-error-datum c) x)) (assert (not (typep x (type-error-expected-type c)))) ;; Can we assume the expected-type is STRING? (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) (assert (eql (type-error-datum c) x)) (assert (not (typep x (type-error-expected-type c)))) ;; Can we assume the expected-type is NUMBER? (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) (assert (eql (type-error-datum c) x)) (assert (not (typep x (type-error-expected-type c)))) ;; Can we assume the expected-type is NUMBER? (store-value 15)))) (values (check-type x number) x))) nil 15) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest check-type.8 (let ((x 10)) (macrolet ((%m (z) z)) (check-type (expand-in-current-env (%m x)) (integer 8 13)))) nil) (deftest check-type.9 (let ((x 10)) (macrolet ((%m (z) z)) (check-type x (integer 9 12) (expand-in-current-env (%m "Foo!"))))) nil) gcl27-2.7.0/ansi-tests/cis.lsp000066400000000000000000000021201454061450500160250ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 6 18:42:15 2003 ;;;; Contains: Tests of CIS (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (deftest cis.error.1 (signals-error (cis) program-error) t) (deftest cis.error.2 (signals-error (cis 0 nil) program-error) t) (deftest cis.1 (let ((result (cis 0))) (or (=t result 1) (eqlt #c(1.0 0.0)))) t) (deftest cis.2 (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) for vals = (multiple-value-list (cis x)) for c = (car vals) unless (and (= (length vals) 1) (eql c (complex (float 1 x) x))) collect (cons x vals)) nil) (deftest cis.3 (loop for x = (random (* 2 pi)) for c = (cis x) repeat 1000 unless (and (complexp c) (approx= (imagpart c) (sin x)) (approx= (realpart c) (cos x))) collect (list x c (cos x) (sin x))) nil) (deftest cis.4 (loop for x = (random (coerce (* 2 pi) 'single-float)) for c = (cis x) repeat 1000 unless (and (complexp c) (approx= (imagpart c) (sin x)) (approx= (realpart c) (cos x))) collect (list x c (cos x) (sin x))) nil) gcl27-2.7.0/ansi-tests/cl-symbol-names.lsp000066400000000000000000001036101454061450500202570ustar00rootroot00000000000000;-*- 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))) (#-clisp progn #+clisp ext:without-package-lock #+clisp ("COMMON-LISP") (mapcar #'(lambda (str) (intern str pkg)) *cl-symbol-names*)))) (defparameter *cl-symbols-vector* (make-array (length *cl-symbols*) :initial-contents *cl-symbols*)) ;;; Symbols that name unary predicate that can be safely applied to any object (defparameter *cl-safe-predicates* '(arrayp atom bit-vector-p characterp compiled-function-p complexp consp floatp functionp hash-table-p keywordp listp not null numberp packagep pathnamep random-state-p rationalp readtablep realp simple-bit-vector-p simple-string-p simple-vector-p streamp stringp symbolp vectorp)) ;;; 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-string-length file-write-date fill 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 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 cl:handler-bind cl: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 ed))))) (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*))) gcl27-2.7.0/ansi-tests/cl-symbols-aux.lsp000066400000000000000000000025301454061450500201330ustar00rootroot00000000000000;-*- 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 as an external symbol (not (eqt status :external)) ;; Check if it has any properties whose indicators are ;; external in any of the standard packages or are accessible ;; in CL-USER (let ((plist (symbol-plist sym))) (loop for e = plist then (cddr e) for indicator = (car e) while 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))) gcl27-2.7.0/ansi-tests/cl-symbols.lsp000066400000000000000000002344551454061450500173550ustar00rootroot00000000000000;-*- 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) ;;; Standardized packages have the right names, nicknames (deftest keyword-package-nicknames :notes :standardized-package-nicknames (package-nicknames (find-package "KEYWORD")) nil) (deftest common-lisp-package-nicknames :notes :standardized-package-nicknames (remove "CL" (package-nicknames (find-package "COMMON-LISP")) :test-not 'string=);FIXME double check, spec just says CL is a nickname ("CL")) (deftest common-lisp-user-package-nicknames :notes :standardized-package-nicknames (remove "CL-USER" (package-nicknames (find-package "COMMON-LISP-USER")) :test-not 'string=);FIXME double check, spec just says CL-USER is a nickname ("CL-USER")) ;;; Test there are no extra exported symbols (deftest no-extra-symbols-exported-from-common-lisp (let ((ht (make-hash-table :test 'equal))) (loop for n in *cl-symbol-names* do (setf (gethash n ht) t)) (let ((extras nil)) (do-external-symbols (s "CL") (unless (gethash (symbol-name s) ht) (push s extras))) extras)) 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) ;;;;;;;;;;;;;;;;;;;; ;;; 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 symbol-package.error.1 (signals-error (symbol-package) program-error) t) (deftest symbol-package.error.2 (signals-error (symbol-package 'cons nil) program-error) t) (deftest symbol-package.error.3 (check-type-error #'symbol-package #'symbolp) nil) (deftest symbol-plist.error.1 (signals-error (symbol-plist) program-error) t) (deftest symbol-plist.error.2 (signals-error (symbol-plist 'cons nil) program-error) t) (deftest symbol-plist.error.3 (check-type-error #'symbol-plist #'symbolp) nil) (deftest symbol-plist.error.4 (check-type-error #'(lambda (x) (setf (symbol-plist x) nil)) #'symbolp) nil) (deftest symbol-value.error.1 (signals-error (symbol-value) program-error) t) (deftest symbol-value.error.2 (signals-error (symbol-value '*package* nil) program-error) t) (deftest symbol-value.error.3 (check-type-error #'symbol-value #'symbolp) nil) (deftest symbol-value.error.4 (check-type-error #'(lambda (x) (setf (symbol-value x) nil)) #'symbolp) nil) (deftest symbol-value.error.5 (let ((sym (gensym))) (declare (optimize safety)) (handler-case (progn (symbol-value sym) :bad) (unbound-variable (c) (assert (eq (cell-error-name c) sym)) :good))) :good) gcl27-2.7.0/ansi-tests/cl-test-package.lsp000066400000000000000000000013021454061450500202140ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 14 10:13:21 1998 ;;;; Contains: CL test case package definition (let* ((name :cl-test) (pkg (find-package name))) (unless pkg (setq pkg (make-package name :use '(:cl :regression-test)))) (let ((*package* pkg)) (shadow '(#:handler-case #:handler-bind)) (import '(common-lisp-user::compile-and-load) pkg) (export (mapcar #'intern (mapcar #'symbol-name '(#:random-from-seq #:random-case #:coin #:random-permute #:*universe* #:*mini-universe* #:*cl-symbols* #:signals-error #:typef))))) (let ((s (find-symbol "QUIT" "CL-USER"))) (when s (import s :cl-test)))) gcl27-2.7.0/ansi-tests/class-name.lsp000066400000000000000000000022011454061450500172720ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jun 15 12:05:47 2003 ;;;; Contains: Tests of CLASS-NAME (in-package :cl-test) ;;; This is mostly tested elsewhere. (deftest class-name.1 (class-name (find-class 'symbol)) symbol) (defclass class-name-class-01 () (a b c)) (report-and-ignore-errors (eval '(defmethod class-name ((x class-name-class-01)) 'silly))) (deftest class-name.2 (class-name (make-instance 'class-name-class-01)) silly) ;; Tests of (setf class-name) (deftest setf-class-name.1 (typep* #'(setf class-name) 'standard-generic-function) t) (deftest setf-class-name.2 (let ((sym (gensym)) (newsym (gensym))) (eval `(defclass ,sym () (a b c))) (let ((class (find-class sym))) (values (eqlt (class-name class) sym) (equalt (multiple-value-list (setf (class-name (find-class sym)) newsym)) (list newsym)) (eqlt newsym (class-name class))))) t t t) ;;; Error tests (deftest class-name.error.1 (signals-error (class-name) program-error) t) (deftest class-name.error.2 (signals-error (class-name (find-class 'symbol) nil) program-error) t) gcl27-2.7.0/ansi-tests/class-of.lsp000066400000000000000000000005371454061450500167700ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jun 16 19:40:32 2003 ;;;; Contains: Tests of CLASS-OF (in-package :cl-test) ;;; Most tests of CLASS-OF are in other files (deftest class-of.error.1 (signals-error (class-of) program-error) t) (deftest class-of.error.2 (signals-error (class-of nil nil) program-error) t) gcl27-2.7.0/ansi-tests/class-precedence-lists.lsp000066400000000000000000000173441454061450500216210ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jun 4 20:18:29 2003 ;;;; Contains: Tests that builtin classes have the right CPLs (in-package :cl-test) (eval-when (:load-toplevel :compile-toplevel :execute) (unless #| (fboundp 'class-precedence-list-foo) |# nil (report-and-ignore-errors (defgeneric class-precedence-list-foo (x) (:method-combination list) . #.(loop for s in *cl-types-that-are-classes-symbols* collect `(:method list ((x ,s)) ',s)))))) (defmacro def-cpl-test (objform expected-cpl &optional name) (let* ((ordered (loop for e = expected-cpl then (cdr e) for x = (car e) for y = (cadr e) while y always (subtypep x y)))) `(deftest ,(or name (intern (concatenate 'string (symbol-name (first expected-cpl)) "-CPL") :cl-test)) (let* ((obj ,objform) (cpl (class-precedence-list-foo obj))) (or ,(if ordered nil `(and (not (eql (class-of obj) (find-class ',(first expected-cpl)))) (progn (format t "~%Note: ~S not a direct instance of ~A~%" ',objform ',(first expected-cpl)) t))) (and ,(if ordered t `(eql (first cpl) ',(first expected-cpl))) (is-noncontiguous-sublist-of ',expected-cpl cpl)))) t))) ;;; Condition types (defmacro def-cond-cpl-test (expected-cpl) `(def-cpl-test (make-condition ',(first expected-cpl)) ,expected-cpl)) (def-cond-cpl-test (arithmetic-error error serious-condition condition t)) (def-cond-cpl-test (cell-error error serious-condition condition t)) (def-cond-cpl-test (condition t)) (def-cond-cpl-test (control-error error serious-condition condition t)) (def-cond-cpl-test (division-by-zero arithmetic-error error serious-condition condition t)) (def-cond-cpl-test (end-of-file stream-error error serious-condition condition t)) (def-cond-cpl-test (error serious-condition condition t)) (def-cond-cpl-test (file-error error serious-condition condition t)) (def-cond-cpl-test (floating-point-inexact arithmetic-error error serious-condition condition t)) (def-cond-cpl-test (floating-point-invalid-operation arithmetic-error error serious-condition condition t)) (def-cond-cpl-test (floating-point-overflow arithmetic-error error serious-condition condition t)) (def-cond-cpl-test (floating-point-underflow arithmetic-error error serious-condition condition t)) (def-cond-cpl-test (package-error error serious-condition condition t)) (def-cond-cpl-test (parse-error error serious-condition condition t)) (def-cond-cpl-test (print-not-readable error serious-condition condition t)) (def-cond-cpl-test (program-error error serious-condition condition t)) (def-cond-cpl-test (reader-error parse-error stream-error error serious-condition condition t)) (def-cond-cpl-test (serious-condition condition t)) (def-cond-cpl-test (simple-condition condition t)) (def-cond-cpl-test (simple-error simple-condition error serious-condition condition t)) (def-cond-cpl-test (simple-type-error simple-condition type-error error serious-condition condition t)) (def-cond-cpl-test (simple-warning simple-condition warning condition t)) (def-cond-cpl-test (storage-condition serious-condition condition t)) (def-cond-cpl-test (stream-error error serious-condition condition t)) (def-cond-cpl-test (style-warning warning condition t)) (def-cond-cpl-test (type-error error serious-condition condition t)) (def-cond-cpl-test (unbound-slot cell-error error serious-condition condition t)) (def-cond-cpl-test (unbound-variable cell-error error serious-condition condition t)) (def-cond-cpl-test (undefined-function cell-error error serious-condition condition t)) (def-cond-cpl-test (warning condition t)) (def-cpl-test (make-array '(2 3 4)) (array t)) (def-cpl-test (make-array '(10) :element-type 'bit :adjustable t :fill-pointer 5) (bit-vector vector array sequence t)) (def-cpl-test (make-broadcast-stream) (broadcast-stream stream t)) (def-cpl-test (class-of 'symbol) (built-in-class class standard-object t)) (def-cpl-test #\a (character t) character-cpl.1) (def-cpl-test #c(1.0 2.0) (complex number t) complex-cpl.1) (def-cpl-test #c(1 2) (complex number t) complex-cpl.2) (def-cpl-test #c(1/2 2/3) (complex number t) complex-cpl.3) (def-cpl-test (make-concatenated-stream) (concatenated-stream stream t)) (def-cpl-test '(a b c) (cons list sequence t)) (def-cpl-test (let ((out (make-string-output-stream))) (make-echo-stream (make-string-input-stream "foo") out)) (echo-stream stream t)) (def-cpl-test (open "class-precedence-lists.lsp" :direction :probe) (file-stream stream t)) (def-cpl-test 1.0s0 (float real number t) float-cpl.1) (def-cpl-test 1.0f0 (float real number t) float-cpl.2) (def-cpl-test 1.0d0 (float real number t) float-cpl.3) (def-cpl-test 1.0l0 (float real number t) float-cpl.4) (def-cpl-test #'car (function t)) ;; (def-cpl-test #'make-instance (generic-function function t)) (def-cpl-test (make-hash-table) (hash-table t) hash-table-cpl.1) (def-cpl-test (make-hash-table :test 'eq) (hash-table t) hash-table-cpl.2) (def-cpl-test (make-hash-table :test 'equal) (hash-table t) hash-table-cpl.3) (def-cpl-test 0 (integer rational real number t) integer-cpl.1) (def-cpl-test (1+ most-positive-fixnum) (integer rational real number t) integer-cpl.2) (def-cpl-test (1- most-negative-fixnum) (integer rational real number t) integer-cpl.3) (def-cpl-test nil (list sequence t) list-cpl.1) (def-cpl-test '(a b c) (list sequence t) list-cpl.2) ;;; Insert a test for LOGICAL-PATHNAME here ;;; (def-cpl-test ????? (logical-pathname pathname t)) ;;; (def-cpl-test (find-method #'class-name nil (list (find-class 'class))) ;;; (method t)) ;;; Insert test for METHOD-COMBINATION here (def-cpl-test nil (null symbol list sequence t)) (def-cpl-test (find-package "CL") (package t)) (def-cpl-test #p"foo" (pathname t)) (def-cpl-test *random-state* (random-state t)) (def-cpl-test 5/3 (ratio rational real number t)) (def-cpl-test *readtable* (readtable t)) (defclass cpl-example-class () ()) (def-cpl-test (find-class 'cpl-example-class) (standard-class class standard-object t)) (defgeneric cpl-example-gf (x y)) (def-cpl-test #'cpl-example-gf (standard-generic-function generic-function function t)) (def-cpl-test (eval '(defmethod cpl-example-gf ((x t) (y t)) (list y x))) (standard-method method standard-object t)) (def-cpl-test (make-array '(10) :element-type 'character :initial-element #\a :fill-pointer t :adjustable t) (string vector array sequence t) string-cpl.1) (def-cpl-test "abcd" (string vector array sequence t) string-cpl.2) (def-cpl-test (make-string-input-stream "abcdef") (string-stream stream t)) (defstruct cpl-example-structure-class a b c) ;;; No test for STRUCTURE-OBJECT (def-cpl-test 'a (symbol t)) (defparameter *cpl-input-stream* (make-string-input-stream "foofoofoofoo")) (def-cpl-test (make-synonym-stream '*cpl-input-stream*) (synonym-stream stream t)) (defparameter *cpl-output-stream* (make-string-output-stream)) (def-cpl-test (make-two-way-stream *cpl-input-stream* *cpl-output-stream*) (two-way-stream stream t)) (def-cpl-test (make-array '(10) :fill-pointer t :adjustable t :initial-element '(a b c)) (vector array sequence t)) gcl27-2.7.0/ansi-tests/clear-input.lsp000066400000000000000000000025671454061450500175110ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jan 28 06:12:39 2004 ;;;; Contains: Tests of CLEAR-INPUT (in-package :cl-test) ;;; These tests are limited, since whether an input stream can be ;;; cleared is not well specified. (deftest clear-input.1 (loop for s in (list *debug-io* *query-io* *standard-input* *terminal-io*) always (eq (clear-input s) nil)) t) (deftest clear-input.2 (clear-input) nil) (deftest clear-input.3 (clear-input nil) nil) (deftest clear-input.4 (clear-input t) nil) (deftest clear-input.5 (with-input-from-string (is "!?*") (let ((*terminal-io* (make-two-way-stream is (make-broadcast-stream)))) (clear-input t))) nil) (deftest clear-input.6 (with-input-from-string (*standard-input* "345") (clear-input nil)) nil) ;;; Error cases (deftest clear-input.error.1 :notes (:assume-no-simple-streams) (signals-error (clear-input t nil) program-error) t) (deftest clear-input.error.2 :notes (:assume-no-simple-streams) (signals-error (clear-input nil nil) program-error) t) (deftest clear-input.error.3 (signals-error (clear-input t nil nil) program-error) t) (deftest clear-input.error.4 (signals-error (clear-input nil nil nil) program-error) t) (deftest clear-input.error.5 (check-type-error #'clear-input #'(lambda (x) (typep x '(or stream (member nil t))))) nil) gcl27-2.7.0/ansi-tests/clear-output.lsp000066400000000000000000000024011454061450500176750ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jan 28 06:43:17 2004 ;;;; Contains: Tests of CLEAR-OUTPUT (in-package :cl-test) (deftest clear-output.1 (progn (finish-output) (clear-output)) nil) (deftest clear-output.2 (progn (finish-output) (clear-output t)) nil) (deftest clear-output.3 (progn (finish-output) (clear-output nil)) nil) (deftest clear-output.4 (loop for s in (list *debug-io* *error-output* *query-io* *standard-output* *trace-output* *terminal-io*) for dummy = (finish-output s) for results = (multiple-value-list (clear-output s)) unless (equal results '(nil)) collect s) nil) (deftest clear-output.5 (let ((os (make-string-output-stream))) (let ((*terminal-io* (make-two-way-stream (make-string-input-stream "") os))) (clear-output t))) nil) (deftest clear-output.6 (let ((*standard-output* (make-string-output-stream))) (clear-output nil)) nil) ;;; Error tests (deftest clear-output.error.1 (signals-error (clear-output nil nil) program-error) t) (deftest clear-output.error.2 (signals-error (clear-output t nil) program-error) t) (deftest clear-output.error.3 (check-type-error #'clear-output #'(lambda (x) (typep x '(or stream (member nil t))))) nil) gcl27-2.7.0/ansi-tests/clrhash.lsp000066400000000000000000000030551454061450500167030ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Nov 28 09:33:40 2003 ;;;; Contains: Tests of CLRHASH (in-package :cl-test) (deftest clrhash.1 (let ((table (make-hash-table))) (setf (gethash 'a table) 'b) (values (hash-table-count table) (equalt (multiple-value-list (clrhash table)) (list table)) (hash-table-count table))) 1 t 0) (deftest clrhash.2 (let ((table (make-hash-table :test 'eq))) (setf (gethash 'a table) 'b) (values (hash-table-count table) (equalt (multiple-value-list (clrhash table)) (list table)) (hash-table-count table))) 1 t 0) (deftest clrhash.3 (let ((table (make-hash-table :test 'equal))) (setf (gethash 'a table) 'b) (values (hash-table-count table) (equalt (multiple-value-list (clrhash table)) (list table)) (hash-table-count table))) 1 t 0) (deftest clrhash.4 (let ((table (make-hash-table :test 'equalp))) (setf (gethash 'a table) 'b) (values (hash-table-count table) (equalt (multiple-value-list (clrhash table)) (list table)) (hash-table-count table))) 1 t 0) (deftest clrhash.5 (let ((table (make-hash-table :test 'eql))) (setf (gethash 'a table) 'b) (values (hash-table-count table) (equalt (multiple-value-list (clrhash table)) (list table)) (hash-table-count table))) 1 t 0) ;;; (deftest clrhash.error.1 (signals-error (clrhash) program-error) t) (deftest clrhash.error.2 (signals-error (clrhash (make-hash-table) nil) program-error) t) gcl27-2.7.0/ansi-tests/cltest.system000066400000000000000000000050531454061450500173030ustar00rootroot00000000000000;-*- 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" )))) gcl27-2.7.0/ansi-tests/coerce.lsp000066400000000000000000000104401454061450500165130ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Dec 13 20:48:04 2002 ;;;; Contains: Tests for COERCE (in-package :cl-test) (deftest coerce.1 (check-predicate #'(lambda (x) (let ((type (type-of x))) (or (and (consp type) (eqt (car type) 'function)) (eql (coerce x type) x))))) nil) (deftest coerce.2 (check-predicate #'(lambda (x) (eql (coerce x t) x))) nil) (deftest coerce.3 (check-predicate #'(lambda (x) (let ((class (class-of x))) (eql (coerce x class) x)))) nil) (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) ;;; Constant folding test ;;; If the coerce call is folded to a constant, this will fail ;;; when that constant is modified. (def-fold-test coerce.fold.1 (coerce '(1 2 3) 'vector)) (def-fold-test coerce.fold.2 (coerce '(1 0 1) 'bit-vector)) (def-fold-test coerce.fold.3 (coerce '(#\a #\b #\c) 'string)) ;;; Error tests ;;; (deftest coerce.error.1 ;;; (signals-error (coerce -1 '(integer 0 100)) type-error) ;;; t) (deftest coerce.error.2 (signals-error (coerce '(a b c) '(vector * 2)) type-error) t) (deftest coerce.error.3 (signals-error (coerce '(a b c) '(vector * 4)) type-error) t) (deftest coerce.error.4 (signals-error (coerce nil 'cons) type-error) t) (deftest coerce.error.5 (handler-case (eval '(coerce 'not-a-bound-function 'function)) (error () :caught)) :caught) (deftest coerce.error.6 (signals-error (coerce) program-error) t) (deftest coerce.error.7 (signals-error (coerce t) program-error) t) (deftest coerce.error.8 (signals-error (coerce 'x t 'foo) program-error) t) (deftest coerce.error.9 (signals-error (locally (coerce nil 'cons) t) type-error) t) (deftest coerce.error.10 :notes (:result-type-element-type-by-subtype) (let* ((tp1 '(vector character)) (tp2 `(vector t)) (tp3 `(or ,tp1 ,tp2))) (if (not (subtypep tp3 'vector)) t (handler-case (eval `(coerce '(#\a #\b #\c) ',tp3)) (type-error (c) (cond ((typep (type-error-datum c) (type-error-expected-type c)) `((typep ',(type-error-datum c) ',(type-error-expected-type c)) "==>" true)) (t t))) (error (c) (declare (ignore c)) t)))) t) gcl27-2.7.0/ansi-tests/compile-and-load.lsp000066400000000000000000000032401454061450500203600ustar00rootroot00000000000000#-(and gcl (not ansi-cl)) (in-package :common-lisp-user) #+(and gcl (not ansi-cl)) (in-package "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-toplevel :compile-toplevel :execute) ;; (intern "==>" "CL-USER") (unless (fboundp 'compile-file-pathname) (defun compile-file-pathname (pathname) (make-pathname :defaults pathname :type "o")))) ;;; On-demand compile and load (defvar *compiled-and-loaded-files* nil "List containing pathname, creation times for files that have already been loaded.") (defun compile-and-load (pathspec &key force) "Find the file indicated by PATHSPEC, compiling it first if the associated compiled file is out of date." (let* ((pathname (pathname pathspec)) (pathname (if *load-pathname* (merge-pathnames pathname *load-pathname*) pathname)) (former-data (assoc pathname *compiled-and-loaded-files* :test #'equalp)) (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)))) (unless (and (not force) former-data (>= (cadr former-data) source-write-time)) (when (or (not target-write-time) (<= target-write-time source-write-time)) (handler-bind #-sbcl () #+sbcl ((sb-ext:code-deletion-note #'muffle-warning)) (compile-file pathname))) (if former-data (setf (cadr former-data) source-write-time) (push (list pathname source-write-time) *compiled-and-loaded-files*)) (load compile-pathname)))) gcl27-2.7.0/ansi-tests/compile-file-test-file-2.lsp000066400000000000000000000004351454061450500216540ustar00rootroot00000000000000(in-package "CL-TEST") (defun compile-file-test-fun.2 () nil) (eval-when (:compile-toplevel) (unless (find-class 'compile-file-test-condition.2 nil) (define-condition compile-file-test-condition.2 (style-warning) nil)) (warn (make-condition 'compile-file-test-condition.2))) gcl27-2.7.0/ansi-tests/compile-file-test-file-2a.lsp000066400000000000000000000004331454061450500220130ustar00rootroot00000000000000(in-package "CL-TEST") (defun compile-file-test-fun.2a () nil) (eval-when (:compile-toplevel) (unless (find-class 'compile-file-test-condition.2a nil) (define-condition compile-file-test-condition.2a (warning) nil)) (warn (make-condition 'compile-file-test-condition.2a))) gcl27-2.7.0/ansi-tests/compile-file-test-file-3.lsp000066400000000000000000000000471454061450500216540ustar00rootroot00000000000000(defun compile-file-test-fun.3 () nil) gcl27-2.7.0/ansi-tests/compile-file-test-file-4.lsp000066400000000000000000000001001454061450500216430ustar00rootroot00000000000000(in-package "CL-TEST") (defun compile-file-test-fun.4 () !foo) gcl27-2.7.0/ansi-tests/compile-file-test-file-5.lsp000066400000000000000000000002321454061450500216520ustar00rootroot00000000000000(in-package "CL-TEST") (defun compile-file-test-fun.5 () '#.*compile-file-truename*) (defun compile-file-test-fun.5a () '#.*compile-file-pathname*) gcl27-2.7.0/ansi-tests/compile-file-test-file.lsp000066400000000000000000000000771454061450500215170ustar00rootroot00000000000000(in-package "CL-TEST") (defun compile-file-test-fun.1 () nil) gcl27-2.7.0/ansi-tests/compile-file.lsp000066400000000000000000000151231454061450500176230ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 9 08:25:25 2005 ;;;; Contains: Tests of COMPILE-FILE (in-package :cl-test) (defun compile-file-test (file funname &rest args &key expect-warnings expect-style-warnings output-file (print nil print-p) (verbose nil verbose-p) (*compile-print* nil) (*compile-verbose* nil) external-format) (declare (ignorable external-format)) (let* ((target-pathname (or output-file (compile-file-pathname file))) (actual-warnings-p nil) (actual-style-warnings-p nil)) (when (probe-file target-pathname) (delete-file target-pathname)) (fmakunbound funname) (let* ((str (make-array '(0) :element-type 'character :adjustable t :fill-pointer 0)) (vals (multiple-value-list (handler-bind ((style-warning #'(lambda (c) (declare (ignore c)) (setf actual-style-warnings-p t) nil)) ((or error warning) #'(lambda (c) (unless (typep c 'style-warning) (setf actual-warnings-p t)) nil))) (with-output-to-string (*standard-output* str) (apply #'compile-file file :allow-other-keys t args)))))) (assert (= (length vals) 3)) (destructuring-bind (output-truename warnings-p failure-p) vals (print (namestring (truename target-pathname))) (print (namestring output-truename)) (values (let ((v1 (or print verbose (and (not print-p) *compile-print*) (and (not verbose-p) *compile-verbose*) (string= str ""))) (v2 (or (and verbose-p (not verbose)) (and (not verbose-p) (not *compile-verbose*)) (position #\; str))) (v3 (if actual-warnings-p failure-p t)) (v4 (if expect-warnings failure-p t)) (v5 (if expect-style-warnings warnings-p t)) (v6 (or (null output-truename) (pathnamep output-truename))) (v7 (equalpt-or-report (namestring (truename target-pathname)) (namestring output-truename))) (v8 (not (fboundp funname)))) (if (and v1 v2 v3 v4 v5 v6 (eql v7 t) v8) t (list v1 v2 v3 v4 v5 v6 v7 v8))) (progn (load output-truename) (funcall funname))))))) (deftest compile-file.1 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1) t nil) (deftest compile-file.2 (compile-file-test "compile-file-test-file-2.lsp" 'compile-file-test-fun.2 :expect-style-warnings t) t nil) (deftest compile-file.2a (compile-file-test "compile-file-test-file-2a.lsp" 'compile-file-test-fun.2a :expect-warnings t) t nil) (deftest compile-file.3 (let ((*package* (find-package "CL-TEST"))) (compile-file-test "compile-file-test-file-3.lsp" 'compile-file-test-fun.3)) t nil) (deftest compile-file.4 (let ((*package* (find-package "CL-USER"))) (compile-file-test "compile-file-test-file-3.lsp" 'cl-user::compile-file-test-fun.3)) t nil) (deftest compile-file.5 (compile-file-test #p"compile-file-test-file.lsp" 'compile-file-test-fun.1) t nil) (deftest compile-file.6 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :output-file "foo.fasl") t nil) (deftest compile-file.6a (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :output-file "foo.ufsl") t nil) (deftest compile-file.7 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :external-format :default) t nil) (deftest compile-file.8 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :output-file #p"foo.fasl") t nil) (deftest compile-file.9 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :print t) t nil) (deftest compile-file.10 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :verbose t) t nil) (deftest compile-file.11 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :print nil) t nil) (deftest compile-file.12 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :verbose nil) t nil) ;;; A file stream is a pathname designator (deftest compile-file.13 (with-open-file (s "compile-file-test-file.lsp" :direction :input) (compile-file-test s 'compile-file-test-fun.1)) t nil) (deftest compile-file.14 (let ((s (open "foo.fasl" :direction :output :if-exists :supersede :if-does-not-exist :create))) (close s) (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :output-file s)) t nil) (deftest compile-file.15 (let ((*readtable* (copy-readtable nil))) (set-macro-character #\! (get-macro-character #\')) (compile-file-test "compile-file-test-file-4.lsp" 'compile-file-test-fun.4)) t foo) ;;; Tests for *compile-file-truename*, *compile-file-pathname* (deftest compile-file.16 (let* ((file #p"compile-file-test-file-5.lsp") (target-pathname (compile-file-pathname file)) (*compile-print* nil) (*compile-verbose* nil)) (when (probe-file target-pathname) (delete-file target-pathname)) (compile-file file) (load target-pathname) (values (equalpt-or-report (truename file) (funcall 'compile-file-test-fun.5)) (equalpt-or-report (pathname (merge-pathnames file)) (funcall 'compile-file-test-fun.5a)))) t t) ;;; Add tests of logical pathnames (deftest compile-file.17 (let ((file (logical-pathname "CLTEST:COMPILE-FILE-TEST-LP.LSP"))) (with-open-file (s file :direction :output :if-exists :supersede :if-does-not-exist :create) (format s "(in-package :cl-test)~%(defun compile-file-test-lp.fun () nil)~%")) (compile-file-test file 'compile-file-test-lp.fun)) t nil) (deftest compile-file.18 (let ((file (logical-pathname "CLTEST:COMPILE-FILE-TEST-LP.OUT"))) (with-open-file (s file :direction :output :if-exists :supersede :if-does-not-exist :create)) (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :output-file file)) t nil) (deftest compile-file.19 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :*compile-verbose* t) t nil) (deftest compile-file.20 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :*compile-print* t) t nil) (deftest compile-file-pathname.1 *compile-file-pathname* nil) (deftest compile-file-truename.1 *compile-file-truename* nil) ;;; Error cases (deftest compile-file.error.1 (signals-error (compile-file "nonexistent-file-to-compile.lsp") file-error) t) (deftest compile-file.error.2 (signals-error (compile-file) program-error) t) gcl27-2.7.0/ansi-tests/compile.lsp000066400000000000000000000041051454061450500167040ustar00rootroot00000000000000;-*- 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 (eval '(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) ;;; Error tests (deftest compile.error.1 (signals-error (compile) program-error) t) (deftest compile.error.2 (signals-error (compile nil '(lambda () nil) 'garbage) program-error) t) gcl27-2.7.0/ansi-tests/compiled-function-p.lsp000066400000000000000000000014541454061450500211340ustar00rootroot00000000000000;-*- 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 (check-type-predicate #'compiled-function-p 'compiled-function) 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 (signals-error (compiled-function-p) program-error) t) (deftest compiled-function-p.error.2 (signals-error (compiled-function-p nil nil) program-error) t) gcl27-2.7.0/ansi-tests/compileit.lsp000066400000000000000000000014451454061450500172450ustar00rootroot00000000000000;;; Uncomment the next line to make MAKE-STRING and MAKE-SEQUENCE ;;; tests require that a missing :initial-element argument defaults ;;; to a single value, rather than leaving the string/sequence filled ;;; with arbitrary legal garbage. ;; (pushnew :ansi-tests-strict-initial-element *features*) #+allegro (run-shell-command "rm -f *.fasl") #+cmu (run-program "rm -f *.x86f") (load "gclload1.lsp") (load "gclload2.lsp") (setq rt::*compile-tests* t) #+allegro (progn (rt:disable-note :nil-vectors-are-strings) (rt:disable-note :standardized-package-nicknames) (rt:disable-note :type-of/strict-builtins) (rt:disable-note :assume-no-simple-streams) (rt:disable-note :assume-no-gray-streams)) (in-package :cl-test) (time (regression-test:do-tests)) #+allegro :exit #+(or cmu sbcl gcl) (quit) gcl27-2.7.0/ansi-tests/compiler-macros.lsp000066400000000000000000000003011454061450500203420ustar00rootroot00000000000000;-*- 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 gcl27-2.7.0/ansi-tests/complement.lsp000066400000000000000000000071431454061450500174240ustar00rootroot00000000000000;-*- 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 (check-predicate #'(lambda (x) (eql (funcall (cl::complement #'not) x) (not (not x))))) nil) (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.6 (flet ((%f (&rest args) (notnot (evenp (length args))))) (let ((cf (complement #'%f))) (values (%f) (%f 'a) (%f 'a 'b) (%f 'a 'b 'c) (funcall cf) (funcall cf 'a) (funcall cf 'a 'b) (funcall cf 'a 'b 'c)))) t nil t nil nil t nil t) (deftest complement.7 (flet ((%f (&optional x y) (if x (not y) y))) (let ((cf (complement #'%f))) (values (%f) (%f nil) (%f t) (%f nil nil) (%f t nil) (%f nil t) (%f t t) (funcall cf) (funcall cf nil) (funcall cf t) (funcall cf nil nil) (funcall cf t nil) (funcall cf nil t) (funcall cf t t)))) nil nil t nil t t nil t t nil t nil nil t) (deftest complement.8 (flet ((%f (&key x y) (if x (not y) y))) (let ((cf (complement #'%f))) (values (list (%f) (%f :x nil) (%f :x t) (%f :y nil) (%f :y t :y nil) (%f :x nil :y nil) (%f :x t :y nil) (%f :y t :x nil) (%f :x t :y t)) (list (funcall cf) (funcall cf :x nil) (funcall cf :x t) (funcall cf :y nil) (funcall cf :y t) (funcall cf :x nil :y nil) (funcall cf :x t :y nil) (funcall cf :y t :x nil) (funcall cf :x t :y t :x nil)) (list (funcall cf :x nil :y t :foo nil :allow-other-keys t) (funcall cf :x nil :y t :allow-other-keys nil))))) (nil nil t nil t nil t t nil) (t t nil t nil t nil nil t) (nil nil)) (deftest complement.9 (let ((sym (gensym))) (eval `(defgeneric ,sym (x y))) (eval `(defmethod ,sym ((x integer) (y integer)) (evenp (+ x y)))) (eval `(defmethod ,sym ((x t) (y t)) nil)) (let ((cf (complement (symbol-function sym)))) (values (funcall cf 'a 'b) (funcall cf 0 0) (funcall cf 0 1) (funcall cf 1 0) (funcall cf 1 1)))) t nil t t nil) (deftest complement.10 (let ((cf (complement (compile nil '(lambda (x y) (evenp (+ x y))))))) (values (funcall cf 0 0) (funcall cf 0 1) (funcall cf 1 0) (funcall cf 1 1))) nil t t nil) (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) ;;; Error tests (deftest complement.error.1 (signals-error (complement) program-error) t) (deftest complement.error.2 (signals-error (complement #'not t) program-error) t) (deftest complement.error.3 (signals-error (funcall (complement #'identity)) program-error) t) (deftest complement.error.4 (signals-error (funcall (complement #'identity) t t) program-error) t) (deftest complement.error.5 (signals-error (funcall (complement #'(lambda (&key) t)) :foo t) program-error) t) (deftest complement.error.6 (signals-error (funcall (complement #'(lambda (&key) t)) :allow-other-keys nil :allow-other-keys t :foo t) program-error) t) (deftest complement.error.7 (signals-error (funcall (complement #'(lambda (x &rest y) (and x (evenp (length y)))))) program-error) t) gcl27-2.7.0/ansi-tests/complex.lsp000066400000000000000000000023641454061450500167300ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 6 19:56:29 2003 ;;;; Contains: Tests of COMPLEX (in-package :cl-test) ;;; Error tests (deftest complex.error.1 (signals-error (complex) program-error) t) (deftest complex.error.2 (signals-error (complex 1 1 nil) program-error) t) ;;; Non-error tests (deftest complex.1 (loop for x in *rationals* for c = (complex x) always (eql c x)) t) (deftest complex.2 (loop for x in *floats* for c = (complex x) always (and (complexp c) (eql x (realpart c)) (eql (float 0 x) (imagpart c)))) t) (deftest complex.3 (loop for x in *rationals* for c = (complex 0 x) unless (or (zerop x) (and (complexp c) (eql (realpart c) 0) (eql (imagpart c) x))) collect (list c x)) nil) (deftest complex.4 (loop for x in *floats* for c = (complex 0 x) always (and (complexp c) (eql (float 0 x) (realpart c)) (eql x (imagpart c)))) t) ;;; Tests of some properties of complex numbers (deftest complex.5 (loop for c in *complexes* unless (loop for type in '(short-float single-float double-float long-float) always (if (typep (realpart c) type) (typep (imagpart c) type) (not (typep (imagpart c) type)))) collect c) nil) gcl27-2.7.0/ansi-tests/complexp.lsp000066400000000000000000000007151454061450500171060ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 6 21:03:18 2003 ;;;; Contains: Tests for COMPLEXP (in-package :cl-test) (deftest complexp.error.1 (signals-error (complexp) program-error) t) (deftest complexp.error.2 (signals-error (complexp 0 0) program-error) t) (deftest complexp.error.3 (signals-error (complexp #C(1 1) nil) program-error) t) (deftest complexp.1 (check-type-predicate #'complexp 'complex) nil) gcl27-2.7.0/ansi-tests/compute-applicable-methods.lsp000066400000000000000000000066561454061450500225000ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jun 2 06:40:41 2003 ;;;; Contains: Tests for COMPUTE-APPLICABLE-METHODS (in-package :cl-test) (defgeneric cam-gf-01 (x y)) (defparameter *cam-gf-01-method1* (defmethod cam-gf-01 ((x integer) (y integer)) 1)) (defparameter *cam-gf-01-method2* (defmethod cam-gf-01 ((x integer) (y t)) 2)) (defparameter *cam-gf-01-method3* (defmethod cam-gf-01 ((x t) (y integer)) 3)) (defparameter *cam-gf-01-method4* (defmethod cam-gf-01 ((x t) (y t)) 4)) (deftest compute-applicable-methods.1 (let ((methods (compute-applicable-methods #'cam-gf-01 (list 1 2)))) (equalt methods (list *cam-gf-01-method1* *cam-gf-01-method2* *cam-gf-01-method3* *cam-gf-01-method4*))) t) (deftest compute-applicable-methods.2 (let ((methods (compute-applicable-methods #'cam-gf-01 (list 1 'x)))) (equalt methods (list *cam-gf-01-method2* *cam-gf-01-method4*))) t) (deftest compute-applicable-methods.3 (let ((methods (compute-applicable-methods #'cam-gf-01 (list 'x 10)))) (equalt methods (list *cam-gf-01-method3* *cam-gf-01-method4*))) t) (deftest compute-applicable-methods.4 (let ((methods (compute-applicable-methods #'cam-gf-01 (list 'x 'y)))) (equalt methods (list *cam-gf-01-method4*))) t) (defgeneric cam-gf-02 (x)) (deftest compute-applicable-methods.5 (compute-applicable-methods #'cam-gf-02 '(1)) nil) (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defgeneric cam-gf-03 (x) (:method-combination + :most-specific-first)) (defparameter *cam-gf-03-method1* (defmethod cam-gf-03 + ((x integer)) 1)) (defparameter *cam-gf-03-method2* (defmethod cam-gf-03 + ((x rational)) 2)) (defparameter *cam-gf-03-method3* (defmethod cam-gf-03 + ((x real)) 4)) (defparameter *cam-gf-03-method4* (defmethod cam-gf-03 + ((x number)) 8)) (defparameter *cam-gf-03-method5* (defmethod cam-gf-03 + ((x t)) 16)))) (deftest compute-applicable-methods.6 (equalt (compute-applicable-methods #'cam-gf-03 (list 0)) (list *cam-gf-03-method1* *cam-gf-03-method2* *cam-gf-03-method3* *cam-gf-03-method4* *cam-gf-03-method5*)) t) (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defgeneric cam-gf-04 (x) (:method-combination + :most-specific-last)) (defparameter *cam-gf-04-method1* (defmethod cam-gf-04 + ((x integer)) 1)) (defparameter *cam-gf-04-method2* (defmethod cam-gf-04 + ((x rational)) 2)) (defparameter *cam-gf-04-method3* (defmethod cam-gf-04 + ((x real)) 4)) (defparameter *cam-gf-04-method4* (defmethod cam-gf-04 + ((x number)) 8)) (defparameter *cam-gf-04-method5* (defmethod cam-gf-04 + ((x t)) 16)) )) (deftest compute-applicable-methods.7 (equalt (compute-applicable-methods #'cam-gf-04 (list 0)) (list *cam-gf-04-method1* *cam-gf-04-method2* *cam-gf-04-method3* *cam-gf-04-method4* *cam-gf-04-method5*)) t) ;;; Need tests with :around, :before, :after methods ;;; Error tests (deftest compute-applicable-methods.error.1 (signals-error (compute-applicable-methods) program-error) t) (deftest compute-applicable-methods.error.2 (signals-error (compute-applicable-methods #'cam-gf-01) program-error) t) (deftest compute-applicable-methods.error.3 (signals-error (compute-applicable-methods #'cam-gf-01 '(1 2) nil) program-error) t) gcl27-2.7.0/ansi-tests/compute-restarts.lsp000066400000000000000000000057421454061450500206050ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 22 23:48:53 2003 ;;;; Contains: Tests of COMPUTE-RESTARTS (in-package :cl-test) (deftest compute-restarts.1 (loop for r in (compute-restarts) always (typep r 'restart)) t) (deftest compute-restarts.2 (loop for r in (compute-restarts) always (typep r (find-class 'restart))) t) (deftest compute-restarts.3 (restart-case (let ((r (find-restart 'foo))) (eqt r (find 'foo (compute-restarts) :key #'restart-name))) (foo () nil)) t) (deftest compute-restarts.4 (loop for r1 in (compute-restarts) for r2 in (compute-restarts) always (eq r1 r2)) t) (deftest compute-restarts.5 (restart-case (loop for r1 in (compute-restarts) for r2 in (compute-restarts) always (eq r1 r2)) (foo () t) (bar () t) (foo () nil)) t) (deftest compute-restarts.6 (restart-case (let* ((restarts (compute-restarts)) (p (position 'foo restarts :key #'restart-name)) (r (find 'foo restarts :start (1+ p) :key #'restart-name))) (invoke-restart r)) (foo () 'bad) (foo () 'good) (foo () 'bad)) good) (deftest compute-restarts.7 (handler-bind ((error #'(lambda (c) (let* ((restarts (compute-restarts c)) (r (remove 'foo restarts :test-not #'eq :key #'restart-name))) (invoke-restart (second r)))))) (restart-case (error "an error") (foo () 'bad) (foo () 'good) (foo () 'bad))) good) (deftest compute-restarts.8 (handler-bind ((error #'(lambda (c) (declare (ignore c)) (let* ((restarts (compute-restarts)) (r (remove 'foo restarts :test-not #'eq :key #'restart-name))) (invoke-restart (second r)))))) (restart-case (error "an error") (foo () 'bad) (foo () 'good) (foo () 'bad))) good) (deftest compute-restarts.9 (let ((c2 (make-condition 'error))) (block done (handler-bind ((error #'(lambda (c) (declare (ignore c)) (let* ((restarts (compute-restarts c2)) (r (remove 'foo restarts :test-not #'eq :key #'restart-name))) ;; (write restarts) (return-from done (values r (mapcar #'restart-name r))))))) (restart-case (error "an error") (foo () 'bad) (foo () 'also-bad))))) nil nil) ;;; This test is disabled until I figure out how to fix ;;; it. See sbcl-devel mailing list, Oct 2005 #| (deftest compute-restarts.10 (let ((c2 (make-condition 'error))) (block done (handler-bind ((error #'(lambda (c) (declare (ignore c)) (let* ((restarts (compute-restarts c2)) (r (remove 'foo restarts :test-not #'eq :key #'restart-name))) ;; (write restarts) (return-from done (values r (mapcar #'restart-name r))))))) (restart-case (progn (error "an error")) (foo () :test (lambda (c) (or (null c) (not (eq c c2)))) 'bad) (foo () :test (lambda (c) (or (null c) (not (eq c c2)))) 'also-bad))))) nil nil) |# gcl27-2.7.0/ansi-tests/concatenate.lsp000066400000000000000000000202531454061450500175420ustar00rootroot00000000000000;-*- 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.18a (concatenate '(vector *) '(a b c) '(d e f) #(g h)) #(a b c d e f g h)) (deftest concatenate.18b (concatenate '(vector) '(a b c) '(d e f) #(g h)) #(a b c d e f g h)) (deftest concatenate.18c (concatenate '(simple-vector *) '(a b c) '(d e f) #(g h)) #(a b c d e f g h)) (deftest concatenate.18d (concatenate '(simple-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 10) x x) (concatenate '(bit-vector *) x) (not (simple-bit-vector-p (concatenate 'bit-vector x))) )) #*011000 #*001100 #*0110001100 #*01100 nil) (deftest concatenate.30a (let* ((x (make-array '(10) :initial-contents #*0110010111 :fill-pointer 5 :element-type 'bit))) (values (concatenate 'simple-bit-vector x '(0)) (concatenate 'simple-bit-vector '(0) x) (concatenate 'simple-bit-vector x x) (concatenate 'simple-bit-vector x) (not (simple-bit-vector-p (concatenate 'bit-vector x))) )) #*011000 #*001100 #*0110001100 #*01100 nil) (deftest concatenate.31 :notes (:nil-vectors-are-strings) (concatenate 'string "abc" (make-array '(0) :element-type nil) "def") "abcdef") (deftest concatenate.32 :notes (:nil-vectors-are-strings) (concatenate '(array nil (*))) "") (deftest concatenate.33 (do-special-strings (s "abc" nil) (assert (string= (concatenate 'string s s s) "abcabcabc")) (assert (string= (concatenate 'string "xy" s) "xyabc")) (assert (string= (concatenate 'simple-string s "z" s "w" s) "abczabcwabc")) (assert (string= (concatenate 'base-string s "z" s "w" s) "abczabcwabc")) (assert (string= (concatenate 'simple-base-string s "z" s "w" s) "abczabcwabc")) (assert (string= (concatenate '(vector character) s "z" s "w" s) "abczabcwabc"))) nil) (deftest concatenate.34 (concatenate 'simple-string "abc" "def") "abcdef") (deftest concatenate.35 (concatenate '(simple-string) "abc" "def") "abcdef") (deftest concatenate.36 (concatenate '(simple-string *) "abc" "def") "abcdef") (deftest concatenate.37 (concatenate '(simple-string 6) "abc" "def") "abcdef") (deftest concatenate.38 (concatenate '(string) "abc" "def") "abcdef") (deftest concatenate.39 (concatenate '(string *) "abc" "def") "abcdef") (deftest concatenate.40 (concatenate '(string 6) "abc" "def") "abcdef") ;;; Order of evaluation tests (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) ;;; Constant folding tests (def-fold-test concatenate.fold.1 (concatenate 'list '(a b) '(c d))) (def-fold-test concatenate.fold.2 (concatenate 'vector '(a b) '(c d))) (def-fold-test concatenate.fold.3 (concatenate 'bit-vector '(0 0) '(1 0 1))) (def-fold-test concatenate.fold.4 (concatenate 'string "ab" "cd")) (def-fold-test concatenate.fold.5 (concatenate 'list '(a b c d))) (def-fold-test concatenate.fold.6 (concatenate 'vector #(a b c d))) (def-fold-test concatenate.fold.7 (concatenate 'bit-vector #*110101101)) (def-fold-test concatenate.fold.8 (concatenate 'string "abcdef")) ;;; Error tests (deftest concatenate.error.1 (signals-error (concatenate 'sequence '(a b c)) error) t) (deftest concatenate.error.2 (signals-error-always (concatenate 'fixnum '(a b c d e)) error) t t) (deftest concatenate.error.3 (signals-error (concatenate '(vector * 3) '(a b c d e)) type-error) t) (deftest concatenate.error.4 (signals-error (concatenate) program-error) t) (deftest concatenate.error.5 (signals-error (locally (concatenate '(vector * 3) '(a b c d e)) t) type-error) t) (deftest concatenate.error.6 :notes (:result-type-element-type-by-subtype) (let ((type '(or (vector bit) (vector t)))) (if (subtypep type 'vector) (eval `(signals-error-always (concatenate ',type '(0 1 0) '(1 1 0)) error)) (values t t))) t t) gcl27-2.7.0/ansi-tests/concatenated-stream-streams.lsp000066400000000000000000000031321454061450500226500ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 14 08:43:45 2004 ;;;; Contains: Tests of CONCATENATED-STREAM-STREAMS (in-package :cl-test) (deftest concatenated-stream-streams.1 (concatenated-stream-streams (make-concatenated-stream)) nil) (deftest concatenated-stream-streams.2 (equalt (list (list *standard-input*)) (multiple-value-list (concatenated-stream-streams (make-concatenated-stream *standard-input*)))) t) (deftest concatenated-stream-streams.3 (with-input-from-string (s1 "abc") (with-input-from-string (s2 "def") (let ((s (make-concatenated-stream s1 s2))) (equalt (list (list s1 s2)) (multiple-value-list (concatenated-stream-streams s)))))) t) (deftest concatenated-stream-streams.4 (with-input-from-string (s1 "") (with-input-from-string (s2 "def") (let ((s (make-concatenated-stream s1 s2))) (equalt (list (list s1 s2)) (multiple-value-list (concatenated-stream-streams s)))))) t) (deftest concatenated-stream-streams.5 (with-input-from-string (s1 "") (with-input-from-string (s2 "def") (let ((s (make-concatenated-stream s1 s2))) (values (read-char s) (equalt (list (list s2)) (multiple-value-list (concatenated-stream-streams s))))))) #\d t) ;;; Error cases (deftest concatenated-stream-streams.error.1 (signals-error (concatenated-stream-streams) program-error) t) (deftest concatenated-stream-streams.error.2 (signals-error (concatenated-stream-streams (make-concatenated-stream) nil) program-error) t) gcl27-2.7.0/ansi-tests/cond.lsp000066400000000000000000000034531454061450500162040ustar00rootroot00000000000000;-*- 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)))) ;;; No implicit tagbody (deftest cond.15 (block done (tagbody (cond (t (go 10) 10 (return-from done 'bad))) 10 (return-from done 'good))) good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest cond.16 (macrolet ((%m (z) z)) (cond ((expand-in-current-env (%m nil)) :bad) (t :good))) :good) (deftest cond.17 (macrolet ((%m (z) z)) (cond (nil :bad1) ((expand-in-current-env (%m :good))) (t :bad2))) :good) ;;; Error tests (deftest cond.error.1 (signals-error (funcall (macro-function 'cond)) program-error) t) (deftest cond.error.2 (signals-error (funcall (macro-function 'cond) '(cond)) program-error) t) (deftest cond.error.3 (signals-error (funcall (macro-function 'cond) '(cond) nil nil) program-error) t) gcl27-2.7.0/ansi-tests/condition.lsp000066400000000000000000000052121454061450500172420ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/conjugate.lsp000066400000000000000000000025771454061450500172460ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 6 21:07:36 2003 ;;;; Contains: Tests of CONJUGATE (in-package :cl-test) ;;; Error tests (deftest conjugate.error.1 (signals-error (conjugate) program-error) t) (deftest conjugate.error.2 (signals-error (conjugate 0 0) program-error) t) ;;; Non-error tests (deftest conjugate.1 (loop for x in *reals* for vals = (multiple-value-list (conjugate x)) for xc = (car vals) always (and (= (length vals) 1) (eql x xc))) t) (deftest conjugate.2 (loop for x in *complexes* for vals = (multiple-value-list (conjugate x)) for xc = (car vals) always (and (= (length vals) 1) (eql (realpart x) (realpart xc)) (eql (- (imagpart x)) (imagpart xc)))) t) (deftest conjugate.3 (eqlt (conjugate #c(0.0s0 0.0s0)) #c(0.0s0 -0.0s0)) t) (deftest conjugate.4 (eqlt (conjugate #c(1.0s0 0.0s0)) #c(1.0s0 -0.0s0)) t) (deftest conjugate.5 (eqlt (conjugate #c(0.0f0 0.0f0)) #c(0.0f0 -0.0f0)) t) (deftest conjugate.6 (eqlt (conjugate #c(1.0f0 0.0f0)) #c(1.0f0 -0.0f0)) t) (deftest conjugate.7 (eqlt (conjugate #c(0.0d0 0.0d0)) #c(0.0d0 -0.0d0)) t) (deftest conjugate.8 (eqlt (conjugate #c(1.0d0 0.0d0)) #c(1.0d0 -0.0d0)) t) (deftest conjugate.9 (eqlt (conjugate #c(0.0l0 0.0l0)) #c(0.0l0 -0.0l0)) t) (deftest conjugate.10 (eqlt (conjugate #c(1.0l0 0.0l0)) #c(1.0l0 -0.0l0)) t) gcl27-2.7.0/ansi-tests/cons-aux.lsp000066400000000000000000000451701454061450500170200ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Mar 6 17:45:42 2003 ;;;; Contains: Auxiliary functions for cons-related tests (in-package :cl-test) ;;; ;;; 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))))) (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 my-set-exclusive-or (set1 set2 &key key test test-not) (assert (not (and test test-not))) (cond (test-not (when (symbolp test-not) (setq test-not (symbol-function test-not))) (setq test (complement test-not))) ((not test) (setq test #'eql))) ;;; (when (symbolp test) (setq test (symbol-function test))) (etypecase test (symbol (setq test (symbol-function test))) (function nil)) (etypecase key (null nil) (symbol (setq key (symbol-function key))) (function nil)) (let* ((keys1 (if key (mapcar (the function key) set1) set1)) (keys2 (if key (mapcar (the function key) set2) set2)) (mask1 (make-array (length set1) :element-type 'bit :initial-element 0)) (mask2 (make-array (length set2) :element-type 'bit :initial-element 0))) (loop for i1 from 0 for k1 in keys1 do (loop for i2 from 0 for k2 in keys2 when (funcall (the function test) k1 k2) do (setf (sbit mask1 i1) 1 (sbit mask2 i2) 1))) (nconc (loop for e in set1 for i across mask1 when (= i 0) collect e) (loop for e in set2 for i across mask2 when (= i 0) collect e)))) (defun make-random-set-exclusive-or-input (n) (let* ((set1 (loop for i from 1 to n collect (random n))) (set2 (loop for i from 1 to n collect (random n))) (test-args (random-case nil nil nil (list :test 'eql) (list :test #'eql) (list :test (complement #'eql)))) (test-not-args (and (not test-args) (random-case nil nil (list :test-not 'eql) (list :test-not #'eql) (list :test-not (complement #'eql))))) (key-args (random-case nil nil nil nil (list :key nil) (list :key 'identity) (list :key 'not)))) (list* set1 set2 (reduce #'append (random-permute (list test-args test-not-args key-args)))))) (defun random-set-exclusive-or-test (n reps &optional (fn 'set-exclusive-or)) (let ((actual-fn (etypecase fn (symbol (symbol-function fn)) (function fn)))) (declare (type function actual-fn)) (loop for i below reps for args = (make-random-set-exclusive-or-input n) for set1 = (car args) for set2 = (cadr args) for result1 = (apply #'remove-duplicates (sort (copy-list (apply #'my-set-exclusive-or args)) #'<) (cddr args)) for result2 = (apply #'remove-duplicates (sort (copy-list (apply actual-fn (copy-list set1) (copy-list set2) (cddr args))) #'<) (cddr args)) unless (equal result1 result2) return (list (list 'remove-duplicates (list 'sort (cons fn args) '<) "...") "actual: " result2 "should be: " result1)))) (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)))))) (defvar *mapc.6-var* nil) (defun mapc.6-fun (x) (push x *mapc.6-var*) x) gcl27-2.7.0/ansi-tests/cons-test-01.lsp000066400000000000000000000067031454061450500174170ustar00rootroot00000000000000;-*- 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))) (compile-and-load "cons-aux.lsp") ;; ;; 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) nil) #+gcl(defvar *cons-fns* '(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)) #-gcl(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) gcl27-2.7.0/ansi-tests/cons-test-02.lsp000066400000000000000000000637671454061450500174350ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/cons-test-03.lsp000066400000000000000000000013171454061450500174150ustar00rootroot00000000000000;-*- 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) (compile-and-load "cons-aux.lsp") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; (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) gcl27-2.7.0/ansi-tests/cons-test-04.lsp000066400000000000000000000222411454061450500174150ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/cons-test-05.lsp000066400000000000000000000067751454061450500174340ustar00rootroot00000000000000;-*- 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) (compile-and-load "cons-aux.lsp") (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) (signals-error (,name) program-error) t)) do (eval `(deftest ,(intern (concatenate 'string (symbol-name name) ".ERROR.EXCESS-ARGS") :cl-test) (signals-error (,name nil nil) program-error) t))) gcl27-2.7.0/ansi-tests/cons-test-06.lsp000066400000000000000000000016741454061450500174260ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/cons-test-07.lsp000066400000000000000000000102711454061450500174200ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/cons-test-08.lsp000066400000000000000000000203721454061450500174240ustar00rootroot00000000000000;-*- 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 gcl27-2.7.0/ansi-tests/cons-test-09.lsp000066400000000000000000000073311454061450500174250ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/cons-test-10.lsp000066400000000000000000000032761454061450500174210ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/cons-test-11.lsp000066400000000000000000000135331454061450500174170ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/cons-test-12.lsp000066400000000000000000000037531454061450500174230ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/cons-test-13.lsp000066400000000000000000000147071454061450500174250ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/cons-test-14.lsp000066400000000000000000000151151454061450500174200ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/cons-test-15.lsp000066400000000000000000000327461454061450500174320ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/cons-test-16.lsp000066400000000000000000000376141454061450500174320ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/cons-test-17.lsp000066400000000000000000000320221454061450500174170ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/cons-test-18.lsp000066400000000000000000000155621454061450500174320ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/cons-test-19.lsp000066400000000000000000000423711454061450500174310ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/cons-test-20.lsp000066400000000000000000000225021454061450500174130ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/cons-test-21.lsp000066400000000000000000000216041454061450500174160ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/cons-test-22.lsp000066400000000000000000000326111454061450500174170ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/cons-test-23.lsp000066400000000000000000000400661454061450500174230ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/cons-test-24.lsp000066400000000000000000000131461454061450500174230ustar00rootroot00000000000000;-*- 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)gcl27-2.7.0/ansi-tests/cons-test-25.lsp000066400000000000000000000026351454061450500174250ustar00rootroot00000000000000;-*- 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))) gcl27-2.7.0/ansi-tests/cons.lsp000066400000000000000000000020341454061450500162150ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:24:25 2003 ;;;; Contains: Tests for CONS (in-package :cl-test) (compile-and-load "cons-aux.lsp") ;;; 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) (def-fold-test cons.fold.1 (cons 'a 'b)) ;;; Error tests (deftest cons.error.1 (signals-error (cons) program-error) t) (deftest cons.error.2 (signals-error (cons 'a) program-error) t) (deftest cons.error.3 (signals-error (cons 'a 'b 'c) program-error) t) gcl27-2.7.0/ansi-tests/consp.lsp000066400000000000000000000022761454061450500164050ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:27:16 2003 ;;;; Contains: Tests of CONSP (in-package :cl-test) (compile-and-load "cons-aux.lsp") ;; 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 (check-predicate #'(lambda (x) (or (and (consp x) (not (atom x))) (and (not (consp x)) (atom x))))) nil) ;; Everything in type cons satisfies consp, and vice versa (deftest consp-cons-universe (check-type-predicate 'consp 'cons) nil) (deftest consp.order.1 (let ((i 0)) (values (consp (incf i)) i)) nil 1) ;;; Error tests (deftest consp.error.1 (signals-error (consp) program-error) t) (deftest consp.error.2 (signals-error (consp 'a 'b) program-error) t) gcl27-2.7.0/ansi-tests/constantly.lsp000066400000000000000000000015101454061450500174470ustar00rootroot00000000000000;-*- 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 (signals-error (cl:constantly) program-error) t) ;;; The next test fails in CMUCL, which has non-conformantly extended ;;; the syntax of constantly. (deftest constantly.error.2 (signals-error (cl:constantly 1 1) program-error) t) gcl27-2.7.0/ansi-tests/constantp.lsp000066400000000000000000000033141454061450500172660ustar00rootroot00000000000000;-*- 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) ;;; Error tests (deftest constantp.error.1 (signals-error (constantp) program-error) t) (deftest constantp.error.2 (signals-error (constantp nil nil nil) program-error) t) ;;; Non-error tests (deftest constantp.1 (check-predicate #'(lambda (e) (or (symbolp e) (consp e) (constantp 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) (defmacro macro-for-constantp.11 (x) x) (deftest constantp.11 (macrolet ((macro-for-constantp.11 (y) (declare (ignore y)) '*standard-input*)) (macrolet ((%m (&environment env) (if (constantp '(macro-for-constantp.11 0) env) :bad :good))) (%m))) :good) (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) gcl27-2.7.0/ansi-tests/continue.lsp000066400000000000000000000021461454061450500171030ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 23 08:37:15 2003 ;;;; Contains: Tests of CONTINUE restart and function (in-package :cl-test) (deftest continue.1 (restart-case (progn (continue) 'bad) (continue () 'good)) good) (deftest continue.2 (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 (list (first (compute-restarts))) (continue c2)) (continue () 'bad) (continue () 'good))) good) (deftest continue.3 (restart-case (progn (continue nil) 'bad) (continue () 'good)) good) (deftest continue.4 (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 (list (first (compute-restarts))) (continue nil)) (continue () 'good) (continue () 'bad))) good) (deftest continue.5 (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (with-condition-restarts c1 (compute-restarts) ;; All conditions are now associated with c1 (continue c2))) nil) gcl27-2.7.0/ansi-tests/copy-alist.lsp000066400000000000000000000022161454061450500173410ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:29:07 2003 ;;;; Contains: Tests of COPY-ALIST (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) (eqlt (car p1) (car p2)) (eqlt (cdr p1) (cdr p2))))) x result) t)) t) (def-fold-test copy-alist.2 (copy-alist '((a . b) nil (c . d)))) (def-fold-test copy-alist.3 (car (copy-alist '((a . b) nil (c . d))))) (def-fold-test copy-alist.4 (caddr (copy-alist '((a . b) nil (c . d))))) ;;; Error tests (deftest copy-alist.error.1 (signals-error (copy-alist) program-error) t) (deftest copy-alist.error.2 (signals-error (copy-alist nil nil) program-error) t) (deftest copy-alist.error.3 (signals-error (copy-alist '((a . b) . c)) type-error) t) gcl27-2.7.0/ansi-tests/copy-list.lsp000066400000000000000000000014711454061450500172020ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:55:19 2003 ;;;; Contains: Tests of COPY-LIST (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) (def-fold-test copy-list.fold.1 (copy-list '(a b c d))) (def-fold-test copy-list.fold.2 (copy-list '(a . b))) ;;; Error tests (deftest copy-list.error.1 (signals-error (copy-list) program-error) t) (deftest copy-list.error.2 (signals-error (copy-list nil nil) program-error) t) gcl27-2.7.0/ansi-tests/copy-pprint-dispatch.lsp000066400000000000000000000061571454061450500213460ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Feb 23 04:41:29 2004 ;;;; Contains: Tests of COPY-PPRINT-DISPATCH (in-package :cl-test) (deftest copy-pprint-dispatch.1 (with-standard-io-syntax (let ((obj '(foo bar)) (*package* (find-package :cl-test)) (*print-readably* nil) (*print-pretty* t)) (values (prin1-to-string obj) (let ((*print-pprint-dispatch* (copy-pprint-dispatch))) (set-pprint-dispatch `(eql ,obj) #'(lambda (s obj2) (let ((*print-pretty* nil)) (format s "#.'~S" obj2)))) (prin1-to-string obj)) (prin1-to-string obj)))) "(FOO BAR)" "#.'(FOO BAR)" "(FOO BAR)") (deftest copy-pprint-dispatch.2 (with-standard-io-syntax (let ((obj '(foo bar)) (*package* (find-package :cl-test)) (*print-readably* nil) (*print-pretty* t)) (values (prin1-to-string obj) (let ((*print-pprint-dispatch* (copy-pprint-dispatch *print-pprint-dispatch*))) (set-pprint-dispatch `(eql ,obj) #'(lambda (s obj2) (let ((*print-pretty* nil)) (format s "#.'~S" obj2)))) (prin1-to-string obj)) (prin1-to-string obj)))) "(FOO BAR)" "#.'(FOO BAR)" "(FOO BAR)") (deftest copy-pprint-dispatch.3 (with-standard-io-syntax (let ((obj '(foo bar)) (*package* (find-package :cl-test)) (*print-readably* nil) (*print-pretty* t)) (values (prin1-to-string obj) (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))) (set-pprint-dispatch `(eql ,obj) #'(lambda (s obj2) (let ((*print-pretty* nil)) (format s "#.'~S" obj2)))) (prin1-to-string obj)) (prin1-to-string obj)))) "(FOO BAR)" "#.'(FOO BAR)" "(FOO BAR)") (deftest copy-pprint-dispatch.4 (with-standard-io-syntax (let ((obj '(foo bar)) (*package* (find-package :cl-test)) (*print-readably* nil) (*print-pretty* t)) (values (prin1-to-string obj) (let ((table (copy-pprint-dispatch))) (set-pprint-dispatch `(eql ,obj) #'(lambda (s obj2) (let ((*print-pretty* nil)) (format s "#.'~S" obj2))) 0 table) (let ((*print-pprint-dispatch* (copy-pprint-dispatch table))) (prin1-to-string obj))) (prin1-to-string obj)))) "(FOO BAR)" "#.'(FOO BAR)" "(FOO BAR)") (deftest copy-pprint-dispatch.5 (let ((new-table (copy-pprint-dispatch))) (values (eql new-table *print-pprint-dispatch*) (member new-table *universe*))) nil nil) (deftest copy-pprint-dispatch.6 (let ((new-table (copy-pprint-dispatch *print-pprint-dispatch*))) (values (eql new-table *print-pprint-dispatch*) (member new-table *universe*))) nil nil) (deftest copy-pprint-dispatch.7 (let ((new-table (copy-pprint-dispatch nil))) (values (eql new-table *print-pprint-dispatch*) (member new-table *universe*))) nil nil) (deftest copy-pprint-dispatch.8 (let* ((table1 (copy-pprint-dispatch)) (table2 (copy-pprint-dispatch table1))) (eql table1 table2)) nil) ;;; Error tests (deftest copy-pprint-dispatch.error.1 (signals-error (copy-pprint-dispatch nil nil) program-error) t) (deftest copy-pprint-dispatch.error.2 (check-type-error #'copy-pprint-dispatch #'null) nil) gcl27-2.7.0/ansi-tests/copy-readtable.lsp000066400000000000000000000021501454061450500201450ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Dec 31 07:15:35 2004 ;;;; Contains: Tests of COPY-READTABLE (in-package :cl-test) (deftest copy-readtable.1 (notnot-mv (typep (copy-readtable) 'readtable)) t) (deftest copy-readtable.2 (notnot-mv (typep (copy-readtable *readtable*) 'readtable)) t) (deftest copy-readtable.3 (notnot-mv (typep (copy-readtable *readtable* nil) 'readtable)) t) (deftest copy-readtable.4 (let ((rt (copy-readtable *readtable*))) (eql rt *readtable*)) nil) (deftest copy-readtable.5 (let ((rt (copy-readtable *readtable* nil))) (eql rt *readtable*)) nil) (deftest copy-readtable.6 (let* ((rt (copy-readtable)) (rt2 (copy-readtable *readtable* rt))) (notnot (eql rt rt2))) t) ;;; NIL as a readtable designator indicating the standard readtable (deftest copy-readtable.7 (let ((rt (copy-readtable nil))) (values (notnot rt) (notnot (readtablep rt)) (not (eql rt *readtable*)))) t t t) ;;; Error tests (deftest copy-readtable.error.1 (signals-error (copy-readtable *readtable* nil nil) program-error) t) gcl27-2.7.0/ansi-tests/copy-seq.lsp000066400000000000000000000137061454061450500170230ustar00rootroot00000000000000;-*- 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.19 :notes (:nil-vectors-are-strings) (copy-seq (make-array '(0) :element-type nil)) "") ;;; Specialized string tests (deftest copy-seq.20 (do-special-strings (s "abcde" nil) (let ((s2 (copy-seq s))) (assert (typep s2 'simple-array)) (assert (string= s s2)) (assert (equal (array-element-type s) (array-element-type s2))))) nil) ;;; Specialized vector tests (deftest copy-seq.21 (let ((v0 #(1 1 0 1 1 2))) (do-special-integer-vectors (v v0 nil) (let ((v2 (copy-seq v))) (assert (typep v2 'simple-array)) (assert (equalp v v2)) (assert (equalp v v0)) (assert (equal (array-element-type v) (array-element-type v2)))))) nil) (deftest copy-seq.22 (let ((v0 #(-1 1 1 0 1 -1 0))) (do-special-integer-vectors (v v0 nil) (let ((v2 (copy-seq v))) (assert (typep v2 'simple-array)) (assert (equalp v v2)) (assert (equalp v v0)) (assert (equal (array-element-type v) (array-element-type v2)))))) nil) (deftest copy-seq.23 (loop for type in '(short-float single-float long-float double-float) for len = 10 for vals = (loop for i from 1 to len collect (coerce i type)) for vec = (make-array len :element-type type :initial-contents vals) for result = (copy-seq vec) unless (and (= (length result) len) (equal (array-element-type vec) (array-element-type result)) (equalp vec result)) collect (list type vals result)) nil) (deftest copy-seq.24 (loop for etype in '(short-float single-float long-float double-float) for type = `(complex ,etype) for len = 10 for vals = (loop for i from 1 to len collect (complex (coerce i etype) (coerce (- i) etype))) for vec = (make-array len :element-type type :initial-contents vals) for result = (copy-seq vec) unless (and (= (length result) len) (equal (array-element-type vec) (array-element-type result)) (equalp vec result)) collect (list type vals result)) nil) ;;; Order of evaluation test (deftest copy-seq.order.1 (let ((i 0)) (values (copy-seq (progn (incf i) "abc")) i)) "abc" 1) (def-fold-test copy-seq.fold.1 (copy-seq '(a b c))) (def-fold-test copy-seq.fold.2 (copy-seq #(a b c))) (def-fold-test copy-seq.fold.3 (copy-seq #*01101100)) (def-fold-test copy-seq.fold.4 (copy-seq "abcdef")) ;;; Error tests (deftest copy-seq.error.1 (check-type-error #'copy-seq #'sequencep) nil) (deftest copy-seq.error.4 (signals-error (copy-seq) program-error) t) (deftest copy-seq.error.5 (signals-error (copy-seq "abc" 2 nil) program-error) t) (deftest copy-seq.error.6 (signals-error (locally (copy-seq 10) t) type-error) t) gcl27-2.7.0/ansi-tests/copy-symbol.lsp000066400000000000000000000042761454061450500175420ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jun 14 05:44:41 2003 ;;;; Contains: Tests of COPY-SYMBOL (in-package :cl-test) (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) ;;; Error tests (deftest copy-symbol.error.1 (signals-error (copy-symbol) program-error) t) (deftest copy-symbol.error.2 (signals-error (copy-symbol 'a t 'foo) program-error) t) gcl27-2.7.0/ansi-tests/copy-tree.lsp000066400000000000000000000021051454061450500171610ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:31:33 2003 ;;;; Contains: Tests of COPY-TREE (in-package :cl-test) (compile-and-load "cons-aux.lsp") ;; 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)))) (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) (def-fold-test copy-tree.fold.1 (copy-tree '(a . b))) (def-fold-test copy-tree.fold.2 (copy-tree '(a))) (def-fold-test copy-tree.fold.3 (copy-tree '(a b c d e))) ;;; Error tests (deftest copy-tree.error.1 (signals-error (copy-tree) program-error) t) (deftest copy-tree.error.2 (signals-error (copy-tree 'a 'b) program-error) t) gcl27-2.7.0/ansi-tests/cos.lsp000066400000000000000000000063531454061450500160470ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Feb 9 20:53:42 2004 ;;;; Contains: Tests of COS (in-package :cl-test) (deftest cos.1 (loop for i from -1000 to 1000 for rlist = (multiple-value-list (cos i)) for y = (car rlist) always (and (null (cdr rlist)) (<= -1 y 1) (or (rationalp y) (typep y 'single-float)))) t) (deftest cos.2 (loop for x = (- (random 2000.0s0) 1000.0s0) for rlist = (multiple-value-list (cos x)) for y = (car rlist) repeat 1000 always (and (null (cdr rlist)) (<= -1 y 1) (typep y 'short-float))) t) (deftest cos.3 (loop for x = (- (random 2000.0f0) 1000.0f0) for rlist = (multiple-value-list (cos x)) for y = (car rlist) repeat 1000 always (and (null (cdr rlist)) (<= -1 y 1) (typep y 'single-float))) t) (deftest cos.4 (loop for x = (- (random 2000.0d0) 1000.0d0) for rlist = (multiple-value-list (cos x)) for y = (car rlist) repeat 1000 always (and (null (cdr rlist)) (<= -1 y 1) (typep y 'double-float))) t) (deftest cos.5 (loop for x = (- (random 2000.0l0) 1000.0l0) for rlist = (multiple-value-list (cos x)) for y = (car rlist) repeat 1000 always (and (null (cdr rlist)) (<= -1 y 1) (typep y 'long-float))) t) (deftest cos.6 (let ((r (cos 0))) (or (eqlt r 1) (eqlt r 1.0))) t) (deftest cos.7 (cos 0.0s0) 1.0s0) (deftest cos.8 (cos 0.0) 1.0) (deftest cos.9 (cos 0.0d0) 1.0d0) (deftest cos.10 (cos 0.0l0) 1.0l0) (deftest cos.11 (loop for i from 1 to 100 unless (approx= (cos i) (cos (coerce i 'single-float))) collect i) nil) (deftest cos.12 (approx= (cos (coerce (/ pi 2) 'single-float)) 0.0) t) (deftest cos.13 (approx= (cos (coerce (/ pi -2) 'single-float)) 0.0) t) (deftest cos.14 (approx= (cos (coerce (/ pi 2) 'short-float)) 0s0) t) (deftest cos.15 (approx= (cos (coerce (/ pi -2) 'short-float)) 0s0) t) (deftest cos.16 (approx= (cos (coerce (/ pi 2) 'double-float)) 0d0) t) (deftest cos.17 (approx= (cos (coerce (/ pi -2) 'double-float)) 0d0) t) (deftest cos.18 (approx= (cos (coerce (/ pi 2) 'long-float)) 0l0) t) (deftest cos.19 (approx= (cos (coerce (/ pi -2) 'long-float)) 0l0) t) (deftest cos.20 (loop for r = (- (random 2000) 1000) for i = (- (random 20) 10) for y = (cos (complex r i)) repeat 1000 always (numberp y)) t) (deftest cos.21 (loop for r = (- (random 2000.0s0) 1000.0s0) for i = (- (random 20.0s0) 10.0s0) for y = (cos (complex r i)) repeat 1000 always (numberp y)) t) (deftest cos.22 (loop for r = (- (random 2000.0f0) 1000.0f0) for i = (- (random 20.0f0) 10.0f0) for y = (cos (complex r i)) repeat 1000 always (numberp y)) t) (deftest cos.23 (loop for r = (- (random 2000.0d0) 1000.0d0) for i = (- (random 20.0d0) 10.0d0) for y = (cos (complex r i)) repeat 1000 always (numberp y)) t) (deftest cos.24 (loop for r = (- (random 2000.0l0) 1000.0l0) for i = (- (random 20.0l0) 10.0l0) for y = (cos (complex r i)) repeat 1000 always (numberp y)) t) ;;; FIXME ;;; More accuracy tests here ;;; Error tests (deftest cos.error.1 (signals-error (cos) program-error) t) (deftest cos.error.2 (signals-error (cos 0.0 0.0) program-error) t) (deftest cos.error.3 (check-type-error #'cos #'numberp) nil) gcl27-2.7.0/ansi-tests/cosh.lsp000066400000000000000000000037111454061450500162120ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Feb 11 06:54:15 2004 ;;;; Contains: Tests of COSH (in-package :cl-test) (deftest cosh.1 (let ((result (cosh 0))) (or (eqlt result 1) (eqlt result 1.0))) t) (deftest cosh.2 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 type) for one = (coerce 1 type) unless (equal (multiple-value-list (cosh zero)) (list one)) collect type) nil) (deftest cosh.3 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 `(complex ,type)) for one = (coerce 1 `(complex ,type)) unless (equal (multiple-value-list (cosh zero)) (list one)) collect type) nil) (deftest cosh.4 (loop for den = (1+ (random 10000)) for num = (random (* 10 den)) for x = (/ num den) for rlist = (multiple-value-list (cosh x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (numberp y)) collect (list x rlist)) nil) (deftest cosh.5 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x = (- (random (coerce 20 type)) 10) for rlist = (multiple-value-list (cosh x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y type)) collect (list x rlist))) nil) (deftest cosh.6 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x1 = (- (random (coerce 20 type)) 10) for x2 = (- (random (coerce 20 type)) 10) for rlist = (multiple-value-list (cosh (complex x1 x2))) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y `(complex ,type))) collect (list x1 x2 rlist))) nil) ;;; FIXME ;;; Add accuracy tests here ;;; Error tests (deftest cosh.error.1 (signals-error (cosh) program-error) t) (deftest cosh.error.2 (signals-error (cosh 1.0 1.0) program-error) t) (deftest cosh.error.3 (check-type-error #'cosh #'numberp) nil) gcl27-2.7.0/ansi-tests/count-if-not.lsp000066400000000000000000000354751454061450500176140ustar00rootroot00000000000000;-*- 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) ;;; Other special vectors `(deftest count-if-not.special-vector.1 (do-special-integer-vectors (v #(1 0 1 1 1 0 1 1 1 0 1) nil) (assert (eql (count-if-not #'plusp v) 3)) (assert (eql (count-if-not #'zerop v) 8)) (assert (eql (count-if-not #'plusp v :start 2) 2)) (assert (eql (count-if-not #'zerop v :end 9) 7))) nil) (deftest count-if-not.special-vector.2 (do-special-integer-vectors (v #(1 3 2 4 7 5 6 1 0 2 4) nil) (assert (eql (count-if-not #'evenp v) 5)) (assert (eql (count-if-not #'oddp v) 6)) (assert (eql (count-if-not #'plusp v :start 2) 1)) (assert (eql (count-if-not #'zerop v :end 8) 8))) nil) (deftest count-if-not.special-vector.3 (loop for etype in '(short-float single-float double-float long-float) for vals = (loop for e in '(0 1 2 1 3 0 4 5 6 0) collect (coerce e etype)) for vec = (make-array (length vals) :element-type etype :initial-contents vals) for result = (count-if-not #'zerop vec) unless (= result 7) collect (list etype vals vec result)) nil) (deftest count-if-not.special-vector.4 (loop for cetype in '(short-float single-float double-float long-float integer rational) for etype = `(complex ,cetype) for vals = (loop for e in '(6 1 2 1 3 -4 4 5 6 100) collect (complex 0 (coerce e cetype))) for vec = (make-array (length vals) :element-type etype :initial-contents vals) for result = (count-if-not #'(lambda (x) (< (abs x) 5/2)) vec) unless (= result 7) collect (list etype vals vec result)) nil) ;;; 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) (deftest count-if-not-string.18 (do-special-strings (s "a1ha^%&%#( 873ff83nfa!" nil) (assert (= (count-if-not #'alpha-char-p s) 14))) nil) ;;; 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 (check-type-error #'(lambda (x) (count-if-not #'identity x)) #'sequencep) nil) (deftest count-if-not.error.4 (signals-error (count-if-not) program-error) t) (deftest count-if-not.error.5 (signals-error (count-if-not #'null) program-error) t) (deftest count-if-not.error.6 (signals-error (count-if-not #'null nil :bad t) program-error) t) (deftest count-if-not.error.7 (signals-error (count-if-not #'null nil :bad t :allow-other-keys nil) program-error) t) (deftest count-if-not.error.8 (signals-error (count-if-not #'null nil :key) program-error) t) (deftest count-if-not.error.9 (signals-error (count-if-not #'null nil 3 3) program-error) t) ;;; Only leftmost :allow-other-keys argument matters (deftest count-if-not.error.10 (signals-error (count-if-not #'null nil :bad t :allow-other-keys nil :allow-other-keys t) program-error) t) (deftest count-if-not.error.11 (signals-error (locally (count-if-not #'identity 1) t) type-error) t) (deftest count-if-not.error.12 (signals-error (count-if-not #'cons '(a b c)) program-error) t) (deftest count-if-not.error.13 (signals-error (count-if-not #'car '(a b c)) type-error) t) (deftest count-if-not.error.14 (signals-error (count-if-not #'identity '(a b c) :key #'cdr) type-error) t) (deftest count-if-not.error.15 (signals-error (count-if-not #'identity '(a b c) :key #'cons) program-error) t) gcl27-2.7.0/ansi-tests/count-if.lsp000066400000000000000000000341571454061450500170120ustar00rootroot00000000000000;-*- 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) ;;; Other special vectors (deftest count-if.special-vector.1 (do-special-integer-vectors (v #(1 0 1 1 1 0 1 1 1 0 1) nil) (assert (eql (count-if #'plusp v) 8)) (assert (eql (count-if #'zerop v) 3)) (assert (eql (count-if #'plusp v :start 2) 7)) (assert (eql (count-if #'zerop v :end 9) 2))) nil) (deftest count-if.special-vector.2 (do-special-integer-vectors (v #(1 3 2 4 7 5 6 1 0 2 4) nil) (assert (eql (count-if #'evenp v) 6)) (assert (eql (count-if #'oddp v) 5)) (assert (eql (count-if #'plusp v :start 2) 8)) (assert (eql (count-if #'zerop v :end 8) 0))) nil) (deftest count-if.special-vector.3 (loop for etype in '(short-float single-float double-float long-float) for vals = (loop for e in '(0 1 2 1 3 0 4 5 6 0) collect (coerce e etype)) for vec = (make-array (length vals) :element-type etype :initial-contents vals) for result = (count-if #'zerop vec) unless (= result 3) collect (list etype vals vec result)) nil) (deftest count-if.special-vector.4 (loop for cetype in '(short-float single-float double-float long-float integer rational) for etype = `(complex ,cetype) for vals = (loop for e in '(6 1 2 1 3 -4 4 5 6 100) collect (complex 0 (coerce e cetype))) for vec = (make-array (length vals) :element-type etype :initial-contents vals) for result = (count-if #'(lambda (x) (< (abs x) 5/2)) vec) unless (= result 3) collect (list etype vals vec result)) nil) ;;; 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) (deftest count-if-string.18 (do-special-strings (s "1abC3!?deZ" nil) (assert (= (count-if #'alpha-char-p s) 6))) nil) ;;; 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 (check-type-error #'(lambda (x) (count-if #'identity x)) #'sequencep) nil) (deftest count-if.error.4 (signals-error (count-if) program-error) t) (deftest count-if.error.5 (signals-error (count-if #'null) program-error) t) (deftest count-if.error.6 (signals-error (count-if #'null nil :bad t) program-error) t) (deftest count-if.error.7 (signals-error (count-if #'null nil :bad t :allow-other-keys nil) program-error) t) (deftest count-if.error.8 (signals-error (count-if #'null nil :key) program-error) t) (deftest count-if.error.9 (signals-error (count-if #'null nil 3 3) program-error) t) ;;; Only leftmost :allow-other-keys argument matters (deftest count-if.error.10 (signals-error (count-if #'null nil :bad t :allow-other-keys nil :allow-other-keys t) program-error) t) (deftest count-if.error.11 (signals-error (locally (count-if #'identity 1) t) type-error) t) (deftest count-if.error.12 (signals-error (count-if #'cons '(a b c)) program-error) t) (deftest count-if.error.13 (signals-error (count-if #'car '(a b c)) type-error) t) (deftest count-if.error.14 (signals-error (count-if #'identity '(a b c) :key #'cdr) type-error) t) (deftest count-if.error.15 (signals-error (count-if #'identity '(a b c) :key #'cons) program-error) t) gcl27-2.7.0/ansi-tests/count.lsp000066400000000000000000000373521454061450500164160ustar00rootroot00000000000000;-*- 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) (deftest count-list.17 (count 10 '(1 11 2 4 14 5 18 6 7) :test #'<) 3) (deftest count-list.18 (count 10 '(1 11 2 4 14 5 18 6 7) :test-not #'>=) 3) (defharmless count-list.test-and-test-not.1 (count 0 '(0 1 2 0 1 2 3 0 1) :test #'eql :test-not #'eql)) (defharmless count-list.test-and-test-not.2 (count 0 '(0 1 2 0 1 2 3 0 1) :test-not #'eql :test #'eql)) ;;; 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-vector.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) (deftest count-vector.17 (count 10 #(1 11 2 4 14 5 18 6 7) :test #'<) 3) (deftest count-vector.18 (count 10 #(1 11 2 4 14 5 18 6 7) :test-not #'>=) 3) (defharmless count-vector.test-and-test-not.1 (count 0 #(0 1 2 0 1 2 3 0 1) :test #'eql :test-not #'eql)) (defharmless count-vector.test-and-test-not.2 (count 0 #(0 1 2 0 1 2 3 0 1) :test-not #'eql :test #'eql)) ;;; 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) ;;; Other specialized vectors (deftest count.special-vector.1 (do-special-integer-vectors (v #(0 1 1 0 1 1 1 0 1 1 1 1 0) nil) (assert (eql (count 0 v) 4)) (assert (eql (count 1 v) 9)) (assert (eql (count 2 v) 0)) (assert (eql (count 0 v :start 2) 3)) (assert (eql (count 1 v :end 11) 8))) nil) (deftest count.special-vector.2 (do-special-integer-vectors (v #(1 2 3 4 5 6 7) nil) (assert (eql (count 0 v) 0)) (assert (eql (count 1 v) 1)) (assert (eql (count 2 v) 1)) (assert (eql (count 3 v) 1)) (assert (eql (count 4 v) 1)) (assert (eql (count 5 v) 1)) (assert (eql (count 6 v) 1)) (assert (eql (count 7 v) 1))) nil) (deftest count.special-vector.3 (loop for etype in '(short-float single-float double-float long-float) for vals = (loop for e in '(0 1 2 1 3 1 4 5 6 0) collect (coerce e etype)) for vec = (make-array (length vals) :element-type etype :initial-contents vals) for result = (count (coerce 1 etype) vec) unless (= result 3) collect (list etype vals vec result)) nil) (deftest count.special-vector.4 (loop for cetype in '(short-float single-float double-float long-float rational integer) for etype = `(complex ,cetype) for vals = (loop for e in '(4 1 2 1 3 1 4 5 6 6) collect (complex 0 (coerce e cetype))) for vec = (make-array (length vals) :element-type etype :initial-contents vals) for result = (count (complex 0 (coerce 1 cetype)) vec) unless (= result 3) collect (list etype vals vec result)) nil) ;;; 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) (deftest count-bit-vector.21 (count 1 #*00001100100 :test #'<=) 3) (deftest count-bit-vector.22 (count 1 #*00001100100 :test-not #'>) 3) (defharmless count-bit-vector.test-and-test-not.1 (count 0 #*0011010101100010000 :test #'eql :test-not #'eql)) (defharmless count-bit-vector.test-and-test-not.2 (count 0 #*0011010101100010000 :test-not #'eql :test #'eql)) ;;; 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) (deftest count-string.21 (count #\1 "00001100100" :test #'char<=) 3) (deftest count-string.22 (count #\1 "00001100100" :test-not #'char>) 3) (deftest count-string.23 (do-special-strings (s "a1a3abcda" nil) (assert (= (count #\a s) 4))) nil) (defharmless count-string.test-and-test-not.1 (count #\0 "0011010101100010000" :test #'eql :test-not #'eql)) (defharmless count-string.test-and-test-not.2 (count #\0 "0011010101100010000" :test-not #'eql :test #'eql)) ;;; 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 (check-type-error #'(lambda (x) (count 'a x)) #'sequencep) nil) (deftest count.error.4 (signals-error (count) program-error) t) (deftest count.error.5 (signals-error (count nil) program-error) t) (deftest count.error.6 (signals-error (count nil nil :bad t) program-error) t) (deftest count.error.7 (signals-error (count nil nil :bad t :allow-other-keys nil) program-error) t) (deftest count.error.8 (signals-error (count nil nil :key) program-error) t) (deftest count.error.9 (signals-error (count nil nil 3 3) program-error) t) ;;; Only leftmost :allow-other-keys argument matters (deftest count.error.10 (signals-error (count 'a nil :bad t :allow-other-keys nil :allow-other-keys t) program-error) t) (deftest count.error.11 (signals-error (locally (count 'a 1) t) type-error) t) (deftest count.error.12 (signals-error (count 'b '(a b c) :test #'identity) program-error) t) (deftest count.error.13 (signals-error (count 'b '(a b c) :key #'car) type-error) t) (deftest count.error.14 (signals-error (count 'b '(a b c) :test-not #'identity) program-error) t) (deftest count.error.15 (signals-error (count 'b '(a b c) :key #'cons) program-error) t) gcl27-2.7.0/ansi-tests/ctypecase.lsp000066400000000000000000000053331454061450500172400ustar00rootroot00000000000000;-*- 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 (check-type-error #'(lambda (x) (ctypecase x (symbol 'a))) #'symbolp) nil) (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) (assert (eql (type-error-datum c) 1)) (assert (not (typep 1 (type-error-expected-type c)))) (store-value 'a c)))) (ctypecase x (symbol :good) (float :bad))) x)) :good a) ;;; (deftest ctypecase.error.1 ;;; (signals-error (ctypecase) program-error) ;;; t) (deftest ctypecase.13 (let ((x 'a)) (ctypecase x (number 'bad) (#.(find-class 'symbol nil) 'good))) good) (deftest ctypecase.14 (block done (tagbody (let ((x 'a)) (ctypecase x (symbol (go 10) 10 (return-from done 'bad)))) 10 (return-from done 'good))) good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest ctypecase.15 (macrolet ((%m (z) z)) (ctypecase (expand-in-current-env (%m :foo)) (integer :bad1) (keyword :good) (symbol :bad2))) :good) (deftest ctypecase.16 (macrolet ((%m (z) z)) (ctypecase :foo (integer (expand-in-current-env (%m :bad1))) (keyword (expand-in-current-env (%m :good))) (symbol (expand-in-current-env (%m :bad2))))) :good) (deftest ctypecase.error.1 (signals-error (funcall (macro-function 'ctypecase)) program-error) t) (deftest ctypecase.error.2 (signals-error (funcall (macro-function 'ctypecase) '(ctypecase t)) program-error) t) (deftest ctypecase.error.3 (signals-error (funcall (macro-function 'ctypecase) '(ctypecase t) nil nil) program-error) t) gcl27-2.7.0/ansi-tests/cxr.lsp000066400000000000000000000256021454061450500160550ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:28:38 2003 ;;;; Contains: Tests of C*R functions (in-package :cl-test) (compile-and-load "cons-aux.lsp") ;; 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 car.1 (car '(a)) a) (deftest car-nil (car nil) nil) (deftest car.error.1 (check-type-error #'car #'listp) nil) (deftest car.error.2 (signals-error (locally (car 'a) t) type-error) t) (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.error.1 (check-type-error #'cdr #'listp) nil) (deftest cdr.error.2 (signals-error (locally (cdr 'a) t) type-error) t) ;;; Error checking of c*r functions (deftest caar.error.1 (signals-error (caar 'a) type-error) t) (deftest caar.error.2 (signals-error (caar '(a)) type-error) t) (deftest cadr.error.1 (signals-error (cadr 'a) type-error) t) (deftest cadr.error.2 (signals-error (cadr '(a . b)) type-error) t) (deftest cdar.error.1 (signals-error (cdar 'a) type-error) t) (deftest cdar.error.2 (signals-error (cdar '(a . b)) type-error) t) (deftest cddr.error.1 (signals-error (cddr 'a) type-error) t) (deftest cddr.error.2 (signals-error (cddr '(a . b)) type-error) t) (deftest caaar.error.1 (signals-error (caaar 'a) type-error) t) (deftest caaar.error.2 (signals-error (caaar '(a)) type-error) t) (deftest caaar.error.3 (signals-error (caaar '((a))) type-error) t) (deftest caadr.error.1 (signals-error (caadr 'a) type-error) t) (deftest caadr.error.2 (signals-error (caadr '(a . b)) type-error) t) (deftest caadr.error.3 (signals-error (caadr '(a . (b))) type-error) t) (deftest cadar.error.1 (signals-error (cadar 'a) type-error) t) (deftest cadar.error.2 (signals-error (cadar '(a . b)) type-error) t) (deftest cadar.error.3 (signals-error (cadar '((a . c) . b)) type-error) t) (deftest caddr.error.1 (signals-error (caddr 'a) type-error) t) (deftest caddr.error.2 (signals-error (caddr '(a . b)) type-error) t) (deftest caddr.error.3 (signals-error (caddr '(a c . b)) type-error) t) (deftest cdaar.error.1 (signals-error (cdaar 'a) type-error) t) (deftest cdaar.error.2 (signals-error (cdaar '(a)) type-error) t) (deftest cdaar.error.3 (signals-error (cdaar '((a . b))) type-error) t) (deftest cdadr.error.1 (signals-error (cdadr 'a) type-error) t) (deftest cdadr.error.2 (signals-error (cdadr '(a . b)) type-error) t) (deftest cdadr.error.3 (signals-error (cdadr '(a b . c)) type-error) t) (deftest cddar.error.1 (signals-error (cddar 'a) type-error) t) (deftest cddar.error.2 (signals-error (cddar '(a . b)) type-error) t) (deftest cddar.error.3 (signals-error (cddar '((a . b) . b)) type-error) t) (deftest cdddr.error.1 (signals-error (cdddr 'a) type-error) t) (deftest cdddr.error.2 (signals-error (cdddr '(a . b)) type-error) t) (deftest cdddr.error.3 (signals-error (cdddr '(a c . b)) type-error) t) ;; (deftest caaaar.error.1 (signals-error (caaaar 'a) type-error) t) (deftest caaaar.error.2 (signals-error (caaaar '(a)) type-error) t) (deftest caaaar.error.3 (signals-error (caaaar '((a))) type-error) t) (deftest caaaar.error.4 (signals-error (caaaar '(((a)))) type-error) t) (deftest caaadr.error.1 (signals-error (caaadr 'a) type-error) t) (deftest caaadr.error.2 (signals-error (caaadr '(a . b)) type-error) t) (deftest caaadr.error.3 (signals-error (caaadr '(a . (b))) type-error) t) (deftest caaadr.error.4 (signals-error (caaadr '(a . ((b)))) type-error) t) (deftest caadar.error.1 (signals-error (caadar 'a) type-error) t) (deftest caadar.error.2 (signals-error (caadar '(a . b)) type-error) t) (deftest caadar.error.3 (signals-error (caadar '((a . c) . b)) type-error) t) (deftest caadar.error.4 (signals-error (caadar '((a . (c)) . b)) type-error) t) (deftest caaddr.error.1 (signals-error (caaddr 'a) type-error) t) (deftest caaddr.error.2 (signals-error (caaddr '(a . b)) type-error) t) (deftest caaddr.error.3 (signals-error (caaddr '(a c . b)) type-error) t) (deftest caaddr.error.4 (signals-error (caaddr '(a c . (b))) type-error) t) (deftest cadaar.error.1 (signals-error (cadaar 'a) type-error) t) (deftest cadaar.error.2 (signals-error (cadaar '(a)) type-error) t) (deftest cadaar.error.3 (signals-error (cadaar '((a . b))) type-error) t) (deftest cadaar.error.4 (signals-error (cadaar '((a . (b)))) type-error) t) (deftest cadadr.error.1 (signals-error (cadadr 'a) type-error) t) (deftest cadadr.error.2 (signals-error (cadadr '(a . b)) type-error) t) (deftest cadadr.error.3 (signals-error (cadadr '(a b . c)) type-error) t) (deftest cadadr.error.4 (signals-error (cadadr '(a (b . e) . c)) type-error) t) (deftest caddar.error.1 (signals-error (caddar 'a) type-error) t) (deftest caddar.error.2 (signals-error (caddar '(a . b)) type-error) t) (deftest caddar.error.3 (signals-error (caddar '((a . b) . b)) type-error) t) (deftest caddar.error.4 (signals-error (caddar '((a b . c) . b)) type-error) t) (deftest cadddr.error.1 (signals-error (cadddr 'a) type-error) t) (deftest cadddr.error.2 (signals-error (cadddr '(a . b)) type-error) t) (deftest cadddr.error.3 (signals-error (cadddr '(a c . b)) type-error) t) (deftest cadddr.error.4 (signals-error (cadddr '(a c e . b)) type-error) t) (deftest cdaaar.error.1 (signals-error (cdaaar 'a) type-error) t) (deftest cdaaar.error.2 (signals-error (cdaaar '(a)) type-error) t) (deftest cdaaar.error.3 (signals-error (cdaaar '((a))) type-error) t) (deftest cdaaar.error.4 (signals-error (cdaaar '(((a . b)))) type-error) t) (deftest cdaadr.error.1 (signals-error (cdaadr 'a) type-error) t) (deftest cdaadr.error.2 (signals-error (cdaadr '(a . b)) type-error) t) (deftest cdaadr.error.3 (signals-error (cdaadr '(a . (b))) type-error) t) (deftest cdaadr.error.4 (signals-error (cdaadr '(a . ((b . c)))) type-error) t) (deftest cdadar.error.1 (signals-error (cdadar 'a) type-error) t) (deftest cdadar.error.2 (signals-error (cdadar '(a . b)) type-error) t) (deftest cdadar.error.3 (signals-error (cdadar '((a . c) . b)) type-error) t) (deftest cdadar.error.4 (signals-error (cdadar '((a . (c . d)) . b)) type-error) t) (deftest cdaddr.error.1 (signals-error (cdaddr 'a) type-error) t) (deftest cdaddr.error.2 (signals-error (cdaddr '(a . b)) type-error) t) (deftest cdaddr.error.3 (signals-error (cdaddr '(a c . b)) type-error) t) (deftest cdaddr.error.4 (signals-error (cdaddr '(a c b . d)) type-error) t) (deftest cddaar.error.1 (signals-error (cddaar 'a) type-error) t) (deftest cddaar.error.2 (signals-error (cddaar '(a)) type-error) t) (deftest cddaar.error.3 (signals-error (cddaar '((a . b))) type-error) t) (deftest cddaar.error.4 (signals-error (cddaar '((a . (b)))) type-error) t) (deftest cddadr.error.1 (signals-error (cddadr 'a) type-error) t) (deftest cddadr.error.2 (signals-error (cddadr '(a . b)) type-error) t) (deftest cddadr.error.3 (signals-error (cddadr '(a b . c)) type-error) t) (deftest cddadr.error.4 (signals-error (cddadr '(a (b . e) . c)) type-error) t) (deftest cdddar.error.1 (signals-error (cdddar 'a) type-error) t) (deftest cdddar.error.2 (signals-error (cdddar '(a . b)) type-error) t) (deftest cdddar.error.3 (signals-error (cdddar '((a . b) . b)) type-error) t) (deftest cdddar.error.4 (signals-error (cdddar '((a b . c) . b)) type-error) t) (deftest cddddr.error.1 (signals-error (cddddr 'a) type-error) t) (deftest cddddr.error.2 (signals-error (cddddr '(a . b)) type-error) t) (deftest cddddr.error.3 (signals-error (cddddr '(a c . b)) type-error) t) (deftest cddddr.error.4 (signals-error (cddddr '(a c e . b)) type-error) t) ;;; Need to add 'locally' wrapped forms of these ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 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) (equalt 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))) gcl27-2.7.0/ansi-tests/data-and-control-flow.lsp000066400000000000000000000016551454061450500213570ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/decf.lsp000066400000000000000000000071021454061450500161550ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Sep 4 20:50:54 2003 ;;;; Contains: Tests of DECF (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (deftest decf.1 (let ((x 12)) (values (decf x) x)) 11 11) (deftest decf.2 (let ((x 3.0s0)) (values (decf x) x)) 2.0s0 2.0s0) (deftest decf.3 (let ((x 19.0f0)) (values (decf x) x)) 18.0f0 18.0f0) (deftest decf.4 (let ((x 813.0d0)) (values (decf x) x)) 812.0d0 812.0d0) (deftest decf.5 (let ((x -17.0l0)) (values (decf x) x)) -18.0l0 -18.0l0) (deftest decf.6 (loop for x from 1 to 5 collect (let ((y x)) (list (decf y) y))) ((0 0) (1 1) (2 2) (3 3) (4 4))) (deftest decf.7 (loop for x in '(3.0s0 3.0f0 3.0d0 3.0l0) collect (let ((y x)) (list (decf y) y))) ((2.0s0 2.0s0) (2.0f0 2.0f0) (2.0d0 2.0d0) (2.0l0 2.0l0))) (deftest decf.8 (loop for x in '(3.0s0 3.0f0 3.0d0 3.0f0) for y = (complex x 0) for z = (decf y) for x1c = (complex (1- x) 0) unless (and (eql y z) (eql x1c y)) collect (list x y z x1c)) nil) (deftest decf.9 (let ((x most-negative-fixnum)) (values (decf x) x)) #.(1- most-negative-fixnum) #.(1- most-negative-fixnum)) (deftest decf.10 (let ((x (1- most-negative-fixnum))) (values (decf x) x)) #.(- most-negative-fixnum 2) #.(- most-negative-fixnum 2)) (deftest decf.11 (loop for x in *numbers* unless (let* ((y x) (z (decf y))) (and (eql y (1- x)) (eql y z))) collect x) nil) ;;; Increment by other than 1 (deftest decf.12 (loop for x in *numbers* unless (let* ((y x) (z (decf y 0))) (and (eql x y) (eql y z))) collect x) nil) (deftest decf.13 (loop for x in *numbers* nconc (loop for r = (random-from-interval 1000000) repeat 100 when (let* ((y x) (z (decf y r))) (and (not (and (eql (- x r) y) (eql y z))) (list x y r))) collect it)) nil) (deftest decf.14 (let ((x 1)) (values (decf x 0.0s0) x)) 1.0s0 1.0s0) (deftest decf.15 (let ((x 1)) (values (decf x 0.0f0) x)) 1.0f0 1.0f0) (deftest decf.16 (let ((x 2)) (values (decf x 0.0d0) x)) 2.0d0 2.0d0) (deftest decf.17 (let ((x 10)) (values (decf x 0.0l0) x)) 10.0l0 10.0l0) (deftest decf.18 (let ((x 1)) (values (decf x #c(0.0s0 10.0s0)) x)) #c(1.0s0 -10.0s0) #c(1.0s0 -10.0s0)) (deftest decf.19 (let ((x 1)) (values (decf x #c(0.0f0 2.0f0)) x)) #c(1.0f0 -2.0f0) #c(1.0f0 -2.0f0)) (deftest decf.20 (let ((x 1)) (values (decf x #c(0.0d0 2.0d0)) x)) #c(1.0d0 -2.0d0) #c(1.0d0 -2.0d0)) (deftest decf.21 (let ((x 1)) (values (decf x #c(0.0l0 -2.0l0)) x)) #c(1.0l0 2.0l0) #c(1.0l0 2.0l0)) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest decf.22 (macrolet ((%m (z) z)) (let ((x 10)) (values (decf (expand-in-current-env (%m x))) x))) 9 9) (deftest decf.23 (macrolet ((%m (z) z)) (let ((x 5)) (values (decf x (expand-in-current-env (%m 3))) x))) 2 2) (deftest decf.order.2 (let ((a (vector 1 2 3 4)) (i 0) x y z) (values (decf (aref (progn (setf x (incf i)) a) (progn (setf y (incf i)) 0)) (progn (setf z (incf i)) 17)) i x y z a)) -16 3 1 2 3 #(-16 2 3 4)) (deftest decf.order.3 (let ((a (vector 10 2 3 4)) (i 0) x y) (values (decf (aref (progn (setf x (incf i)) a) (progn (setf y (incf i)) 0))) i x y a)) 9 2 1 2 #(9 2 3 4)) (deftest decf.order.4 (let ((x 0)) (progn "See CLtS 5.1.3" (values (decf x (setf x 1)) x))) 0 0) gcl27-2.7.0/ansi-tests/declaim.lsp000066400000000000000000000020771454061450500166600ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 21 07:44:07 2005 ;;;; Contains: Tests of DECLAIM (in-package :cl-test) (deftest declaim.1 (progn (declaim) nil) nil) (deftest declaim.2 (progn (eval `(declaim (optimize))) nil) nil) (deftest declaim.3 (progn (eval `(declaim (inline))) nil) nil) (deftest declaim.4 (progn (eval `(declaim (notinline))) nil) nil) (deftest declaim.5 (progn (eval `(declaim (type t))) nil) nil) (deftest declaim.6 (progn (eval `(declaim (special))) nil) nil) (deftest declaim.7 (progn (eval `(declaim (integer))) nil) nil) (deftest declaim.8 (progn (eval `(declaim (declaration))) nil) nil) (deftest declaim.9 (progn (eval `(declaim (ftype (function (t) t)))) nil) nil) (deftest declaim.10 (let ((sym (gensym))) (eval `(declaim (declaration ,sym))) (eval `(declaim (,sym))) nil) nil) (deftest declaim.11 (let ((sym (gensym))) (eval `(declaim (optimize) (special ,sym) (inline) (special))) (eval `(flet ((%f () ,sym)) (let ((,sym :good)) (%f))))) :good) gcl27-2.7.0/ansi-tests/declaration.lsp000066400000000000000000000043771454061450500175540ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 29 07:16:15 2005 ;;;; Contains: Tests of the DECLARATION declarations (in-package :cl-test) (deftest declaration.1 (progn (declaim (declaration)) nil) nil) (deftest declaration.2 (progn (proclaim '(declaration)) nil) nil) (deftest declaration.3 (let ((sym (gensym)) (sym2 (gensym))) (proclaim `(declaration ,sym ,sym2)) nil) nil) ;;; For the error tests, see the page in the CLHS for TYPE: ;;; "A symbol cannot be both the name of a type and the name ;;; of a declaration. Defining a symbol as the name of a class, ;;; structure, condition, or type, when the symbol has been ;;; declared as a declaration name, or vice versa, signals an error." ;;; Declare these only if bad declarations produce warnings. (when (block done (handler-bind ((warning #'(lambda (c) (return-from done t)))) (eval `(let () (declare (,(gensym))) nil)))) (deftest declaration.4 (let ((sym (gensym))) (proclaim `(declaration ,sym)) (eval `(signals-error-always (deftype ,sym () t) error))) t t) (deftest declaration.5 (let ((sym (gensym))) (proclaim `(declaration ,sym)) (eval `(signals-error-always (defstruct ,sym a b c) error))) t t) (deftest declaration.6 (let ((sym (gensym))) (proclaim `(declaration ,sym)) (eval `(signals-error-always (defclass ,sym () (a b c)) error))) t t) (deftest declaration.7 (let ((sym (gensym))) (proclaim `(declaration ,sym)) (eval `(signals-error-always (define-condition ,sym (condition) (a b c)) error))) t t) (deftest declaration.8 (let ((sym (gensym))) (eval `(deftype ,sym () 'error)) (eval `(signals-error-always (proclaim '(declaration ,sym)) error))) t t) (deftest declaration.9 (let ((sym (gensym))) (eval `(defstruct ,sym a b c)) (eval `(signals-error-always (proclaim '(declaration ,sym)) error))) t t) (deftest declaration.10 (let ((sym (gensym))) (eval `(defclass ,sym () (a b c))) (eval `(signals-error-always (proclaim '(declaration ,sym)) error))) t t) (deftest declaration.11 (let ((sym (gensym))) (eval `(define-condition ,sym (condition) (a b c))) (eval `(signals-error-always (proclaim '(declaration ,sym)) error))) t t) ) gcl27-2.7.0/ansi-tests/decode-universal-time.lsp000066400000000000000000000077701454061450500214540ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 7 07:00:58 2005 ;;;; Contains: Tests of DECODE-UNIVERSAL-TIME (in-package :cl-test) (deftest decode-universal-time.1 (decode-universal-time 0 0) 0 0 0 1 1 1900 0 nil 0) (deftest decode-universal-time.2 (decode-universal-time 0 -1) 0 0 1 1 1 1900 0 nil -1) (deftest decode-universal-time.3 (let ((count 0)) (loop for time = (random 10000000000) for tz = (- (random 49) 24) for (second minute hour date month year day daylight-p zone) = (multiple-value-list (decode-universal-time time tz)) for time2 = (encode-universal-time second minute hour date month year zone) repeat 1000 unless (and (eql tz zone) (eql time time2) (null daylight-p)) collect (progn (incf count) (list time tz (list second minute hour date month year day daylight-p zone) time2)) until (>= count 100))) nil) (deftest decode-universal-time.4 (let ((count 0)) (loop for time = (random 10000000000) for tz = (/ (- (random (1+ (* 48 3600))) (* 24 3600)) 3600) for (second minute hour date month year day daylight-p zone) = (multiple-value-list (decode-universal-time time tz)) for time2 = (encode-universal-time second minute hour date month year zone) repeat 1000 unless (and (eql tz zone) (eql time time2) (null daylight-p)) collect (progn (incf count) (list time tz (list second minute hour date month year day daylight-p zone) time2)) until (>= count 100))) nil) (deftest decode-universal-time.5 (let ((count 0)) (loop for time = (random 10000000000) for (second minute hour date month year day daylight-p zone) = (handler-case (multiple-value-list (decode-universal-time time)) (error (c) (print time) (error c))) for time2 = (encode-universal-time second minute hour date month year) repeat 1000 unless (let ((daylight-p-2 (nth-value 7 (decode-universal-time time2)))) (or (eql time time2) (and daylight-p (not daylight-p-2) ; (eql time (- time2 3600)) ) (and (not daylight-p) daylight-p-2 ; (eql time (+ time2 3600)) ))) collect (progn (incf count) (list time (list second minute hour date month year day daylight-p zone) time2)) until (>= count 100))) nil) (deftest decode-universal-time.6 (let ((vals0 (multiple-value-list (get-decoded-time))) (vals1 (multiple-value-list (decode-universal-time (get-universal-time)))) (vals2 (multiple-value-list (get-decoded-time)))) (when (equal vals0 vals2) (assert (= (length vals1) 9)) (assert (= (length vals2) 9)) (assert (equal (subseq vals1 0 7) (subseq vals2 0 7))) (assert (if (elt vals1 7) (elt vals2 7) (not (elt vals2 7)))) (assert (= (elt vals1 8) (elt vals2 8)))) (values))) (deftest decode-universal-time.7 (decode-universal-time (* 365 3600 24) 0) 0 0 0 1 1 1901 1 nil 0) (deftest decode-universal-time.8 (decode-universal-time (* 2 365 3600 24) 0) 0 0 0 1 1 1902 2 nil 0) (deftest decode-universal-time.9 (decode-universal-time (* 3 365 3600 24) 0) 0 0 0 1 1 1903 3 nil 0) (deftest decode-universal-time.10 (decode-universal-time (* 4 365 3600 24) 0) 0 0 0 1 1 1904 4 nil 0) (deftest decode-universal-time.11 (decode-universal-time (+ (* 24 3600) (* 5 365 3600 24)) 0) 0 0 0 1 1 1905 6 nil 0) (deftest decode-universal-time.12 (loop for time = (random 100000000000) for tz = (- (random 49) 24) for interval = (1+ (random 10000)) for time2 = (+ time (* interval 24 3600)) ;; 'time2' is exactly interval days after 'time' for day = (nth-value 6 (decode-universal-time time tz)) for day2 = (nth-value 6 (decode-universal-time time2 tz)) repeat 1000 ;; Check that the days of the week are consistent unless (= (mod day2 7) (mod (+ day interval) 7)) collect (list time time2 tz interval day day2)) nil) ;;; Error tests (deftest decode-universal-time.error.1 (signals-error (decode-universal-time) program-error) t) (deftest decode-universal-time.error.2 (signals-error (decode-universal-time 0 0 nil) program-error) t) gcl27-2.7.0/ansi-tests/defclass-01.lsp000066400000000000000000000471041454061450500172640ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 20:58:54 2003 ;;;; Contains: Tests for DEFCLASS, part 01 (in-package :cl-test) ;;; I've decided to write some 'manual' tests, then refactor these back ;;; to the automatic mechanisms I'll put into defclass-aux.lsp after ;;; I have a better understanding of the object system (defclass class-01 () (s1 s2 s3)) (deftest class-01.1 (notnot-mv (typep (make-instance 'class-01) 'class-01)) t) (deftest class-01.2 (notnot-mv (typep (make-instance (find-class 'class-01)) 'class-01)) t) (deftest class-01.3 (let ((c (make-instance 'class-01))) (values (setf (slot-value c 's1) 12) (setf (slot-value c 's2) 18) (setf (slot-value c 's3) 27) (loop for s in '(s1 s2 s3) collect (slot-value c s)))) 12 18 27 (12 18 27)) ;;;; (defclass class-02 () ((s1) (s2) (s3))) (deftest class-02.1 (notnot-mv (typep (make-instance 'class-02) 'class-02)) t) (deftest class-02.2 (notnot-mv (typep (make-instance (find-class 'class-02)) 'class-02)) t) (deftest class-02.3 (let ((c (make-instance 'class-02))) (values (setf (slot-value c 's1) 12) (setf (slot-value c 's2) 18) (setf (slot-value c 's3) 27) (loop for s in '(s1 s2 s3) collect (slot-value c s)))) 12 18 27 (12 18 27)) ;;;; (defclass class-03 () ((s1 :type integer) (s2 :type t) (s3 :type fixnum))) (deftest class-03.1 (notnot-mv (typep (make-instance 'class-03) 'class-03)) t) (deftest class-03.2 (notnot-mv (typep (make-instance (find-class 'class-03)) 'class-03)) t) (deftest class-03.3 (let ((c (make-instance 'class-03))) (values (setf (slot-value c 's1) 12) (setf (slot-value c 's2) 'a) (setf (slot-value c 's3) 27) (loop for s in '(s1 s2 s3) collect (slot-value c s)))) 12 a 27 (12 a 27)) ;;;; (defclass class-04 () ((s1 :reader s1-r) (s2 :writer s2-w) (s3 :accessor s3-a))) ;;; Readers, writers, and accessors (deftest class-04.1 (let ((c (make-instance 'class-04))) (values (setf (slot-value c 's1) 'a) (setf (slot-value c 's2) 'b) (setf (slot-value c 's3) 'c) (s1-r c) (slot-value c 's2) (s2-w 'd c) (slot-value c 's2) (s3-a c) (setf (s3-a c) 'e) (slot-value c 's3) (s3-a c))) a b c a b d d c e e e) (deftest class-04.2 (notnot-mv (typep #'s1-r 'generic-function)) t) (deftest class-04.3 (notnot-mv (typep #'s2-w 'generic-function)) t) (deftest class-04.4 (notnot-mv (typep #'s3-a 'generic-function)) t) (deftest class-04.5 (notnot-mv (typep #'(setf s3-a) 'generic-function)) t) ;;;; (defclass class-05 () (s1 (s2 :allocation :instance) (s3 :allocation :class))) (deftest class-05.1 (let ((c1 (make-instance 'class-05)) (c2 (make-instance 'class-05))) (values (not (eql c1 c2)) (list (setf (slot-value c1 's1) 12) (setf (slot-value c2 's1) 17) (slot-value c1 's1) (slot-value c2 's1)) (list (setf (slot-value c1 's2) 'a) (setf (slot-value c2 's2) 'b) (slot-value c1 's2) (slot-value c2 's2)) (list (setf (slot-value c1 's3) 'x) (slot-value c1 's3) (slot-value c2 's3) (setf (slot-value c2 's3) 'y) (slot-value c1 's3) (slot-value c2 's3) (setf (slot-value c1 's3) 'z) (slot-value c1 's3) (slot-value c2 's3)) (slot-value (make-instance 'class-05) 's3))) t (12 17 12 17) (a b a b) (x x x y y y z z z) z) ;;;; (defclass class-06 () ((s1 :reader s1-r1 :reader s1-r2 :writer s1-w1 :writer s1-w2))) (defclass class-06a () ((s1 :reader s1-r1) s3)) (deftest class-06.1 (let ((c (make-instance 'class-06))) (values (setf (slot-value c 's1) 'x) (slot-value c 's1) (s1-r1 c) (s1-r2 c) (s1-w1 'y c) (slot-value c 's1) (s1-r1 c) (s1-r2 c) (s1-w2 'z c) (slot-value c 's1) (s1-r1 c) (s1-r2 c))) x x x x y y y y z z z z) (deftest class-06.2 (let ((c1 (make-instance 'class-06)) (c2 (make-instance 'class-06a))) (values (setf (slot-value c1 's1) 'x) (setf (slot-value c2 's1) 'y) (mapcar #'s1-r1 (list c1 c2)))) x y (x y)) ;;;; (defclass class-07 () ((s1 :initarg :s1a :initarg :s1b :reader s1) (s2 :initarg :s2 :reader s2))) (deftest class-07.1 (let ((c (make-instance 'class-07))) (values (slot-boundp c 's1) (slot-boundp c 's2))) nil nil) (deftest class-07.2 (let ((c (make-instance 'class-07 :s1a 'x))) (values (notnot (slot-boundp c 's1)) (s1 c) (slot-boundp c 's2))) t x nil) (deftest class-07.3 (let ((c (make-instance 'class-07 :s1b 'x))) (values (notnot (slot-boundp c 's1)) (s1 c) (slot-boundp c 's2))) t x nil) (deftest class-07.4 (let ((c (make-instance 'class-07 :s1a 'y :s1b 'x))) (values (notnot (slot-boundp c 's1)) (s1 c) (slot-boundp c 's2))) t y nil) (deftest class-07.5 (let ((c (make-instance 'class-07 :s1b 'y :s1a 'x))) (values (notnot (slot-boundp c 's1)) (s1 c) (slot-boundp c 's2))) t y nil) (deftest class-07.6 (let ((c (make-instance 'class-07 :s1a 'y :s1a 'x))) (values (notnot (slot-boundp c 's1)) (s1 c) (slot-boundp c 's2))) t y nil) (deftest class-07.7 (let ((c (make-instance 'class-07 :s2 'a :s1a 'b))) (values (notnot (slot-boundp c 's1)) (notnot (slot-boundp c 's2)) (s1 c) (s2 c))) t t b a) (deftest class-07.8 (let ((c (make-instance 'class-07 :s2 'a :s1a 'b :s2 'x :s1a 'y :s1b 'z))) (values (notnot (slot-boundp c 's1)) (notnot (slot-boundp c 's2)) (s1 c) (s2 c))) t t b a) (deftest class-07.9 (let ((c (make-instance 'class-07 :s1b 'x :s1a 'y))) (values (notnot (slot-boundp c 's1)) (slot-boundp c 's2) (s1 c))) t nil x) (deftest class-07.10 (let ((c (make-instance 'class-07 :s1a 'x :s2 'y :allow-other-keys nil))) (values (s1 c) (s2 c))) x y) (deftest class-07.11 (let ((c (make-instance 'class-07 :s1a 'a :s2 'b :garbage 'z :allow-other-keys t))) (values (s1 c) (s2 c))) a b) (deftest class-07.12 (let ((c (make-instance 'class-07 :s1a 'd :s2 'c :garbage 'z :allow-other-keys t :allow-other-keys nil))) (values (s1 c) (s2 c))) d c) ;;;; (declaim (special *class-08-s2-initvar*)) (defclass class-08 () ((s1 :initform 0) (s2 :initform *class-08-s2-initvar*))) (deftest class-08.1 (let* ((*class-08-s2-initvar* 'x) (c (make-instance 'class-08))) (values (slot-value c 's1) (slot-value c 's2))) 0 x) ;;;; (declaim (special *class-09-s2-initvar*)) (defclass class-09 () ((s1 :initform 0 :initarg :s1) (s2 :initform *class-09-s2-initvar* :initarg :s2))) (deftest class-09.1 (let* ((*class-09-s2-initvar* 'x) (c (make-instance 'class-09))) (values (slot-value c 's1) (slot-value c 's2))) 0 x) (deftest class-09.2 (let* ((*class-09-s2-initvar* 'x) (c (make-instance 'class-09 :s1 1))) (values (slot-value c 's1) (slot-value c 's2))) 1 x) (deftest class-09.3 (let* ((c (make-instance 'class-09 :s2 'a))) (values (slot-value c 's1) (slot-value c 's2))) 0 a) (deftest class-09.4 (let* ((c (make-instance 'class-09 :s2 'a :s1 10 :s1 'bad :s2 'bad))) (values (slot-value c 's1) (slot-value c 's2))) 10 a) ;;;; (declaim (special *class-10-s1-initvar*)) (defclass class-10 () ((s1 :initform (incf *class-10-s1-initvar*) :initarg :s1))) (deftest class-10.1 (let* ((*class-10-s1-initvar* 0) (c (make-instance 'class-10))) (values *class-10-s1-initvar* (slot-value c 's1))) 1 1) (deftest class-10.2 (let* ((*class-10-s1-initvar* 0) (c (make-instance 'class-10 :s1 10))) (values *class-10-s1-initvar* (slot-value c 's1))) 0 10) ;;;; (let ((x 7)) (defclass class-11 () ((s1 :initform x :initarg :s1)))) (deftest class-11.1 (slot-value (make-instance 'class-11) 's1) 7) (deftest class-11.2 (slot-value (make-instance 'class-11 :s1 100) 's1) 100) ;;; (flet ((%f () 'x)) (defclass class-12 () ((s1 :initform (%f) :initarg :s1)))) (deftest class-12.1 (slot-value (make-instance 'class-12) 's1) x) (deftest class-12.2 (slot-value (make-instance 'class-12 :s1 'y) 's1) y) ;;; (defclass class-13 () ((s1 :allocation :class :initarg :s1))) (deftest class-13.1 (let ((c1 (make-instance 'class-13)) (c2 (make-instance 'class-13 :s1 'foo))) (values (slot-value c1 's1) (slot-value c2 's1))) foo foo) ;;; (defclass class-14 () ((s1 :initarg nil :reader s1))) (deftest class-14.1 (let ((c (make-instance 'class-14 nil 'x))) (s1 c)) x) ;;; (defclass class-15 () ((s1 :initarg :allow-other-keys :reader s1))) ;;; Dicussion on comp.lang.lisp convinced me this test was bogus. ;;; The default value of :allow-other-keys specified in 7.1.2 is not ;;; the same as the default value forms, specified by :default-initargs, ;;; that are used to produce the defaulted initialization argument list. ;;; (deftest class-15.1 ;;; (let ((c (make-instance 'class-15))) ;;; (s1 c)) ;;; nil) (deftest class-15.2 (let ((c (make-instance 'class-15 :allow-other-keys nil))) (s1 c)) nil) (deftest class-15.3 (let ((c (make-instance 'class-15 :allow-other-keys t))) (s1 c)) t) (deftest class-15.4 (let ((c (make-instance 'class-15 :allow-other-keys t :allow-other-keys nil))) (s1 c)) t) (deftest class-15.5 (let ((c (make-instance 'class-15 :allow-other-keys nil :allow-other-keys t))) (s1 c)) nil) (deftest class-15.6 (let ((c (make-instance 'class-15 :allow-other-keys t :foo 'bar))) (s1 c)) t) (deftest class-15.7 (let ((c (make-instance 'class-15 :allow-other-keys t :allow-other-keys nil :foo 'bar))) (s1 c)) t) ;;; Tests of :default-initargs (defclass class-16 () ((s1 :initarg :s1)) (:default-initargs :s1 'x)) (deftest class-16.1 (let ((c (make-instance 'class-16))) (slot-value c 's1)) x) (deftest class-16.2 (let ((c (make-instance 'class-16 :s1 'y))) (slot-value c 's1)) y) (deftest class-16.3 (let ((c (make-instance 'class-16 :s1 nil))) (slot-value c 's1)) nil) ;;; (defclass class-17 () ((s1 :initarg :s1 :initform 'foo)) (:default-initargs :s1 'bar)) (deftest class-17.1 (let ((c (make-instance 'class-17))) (slot-value c 's1)) bar) (deftest class-17.2 (let ((c (make-instance 'class-17 :s1 'z))) (slot-value c 's1)) z) (deftest class-17.3 (let ((c (make-instance 'class-17 :s1 nil))) (slot-value c 's1)) nil) ;;; (defclass class-18 () ((s1 :initarg :s1 :initarg :s1b)) (:default-initargs :s1 'x :s1b 'y)) (deftest class-18.1 (let ((c (make-instance 'class-18))) (slot-value c 's1)) x) (deftest class-18.2 (let ((c (make-instance 'class-18 :s1 'z))) (slot-value c 's1)) z) (deftest class-18.3 (let ((c (make-instance 'class-18 :s1 nil))) (slot-value c 's1)) nil) (deftest class-18.4 (let ((c (make-instance 'class-18 :s1b 'z))) (slot-value c 's1)) z) (deftest class-18.5 (let ((c (make-instance 'class-18 :s1b nil))) (slot-value c 's1)) nil) ;;; (declaim (special *class-19-s1-initvar*)) (defclass class-19 () ((s1 :initarg :s1)) (:default-initargs :s1 (setf *class-19-s1-initvar* 'a))) (deftest class-19.1 (let* ((*class-19-s1-initvar* nil) (c (make-instance 'class-19))) (declare (special *class-19-s1-initvar*)) (values (slot-value c 's1) *class-19-s1-initvar*)) a a) (deftest class-19.2 (let* ((*class-19-s1-initvar* nil) (c (make-instance 'class-19 :s1 nil))) (declare (special *class-19-s1-initvar*)) (values (slot-value c 's1) *class-19-s1-initvar*)) nil nil) (deftest class-19.3 (let* ((*class-19-s1-initvar* nil) (c (make-instance 'class-19 :s1 'x))) (declare (special *class-19-s1-initvar*)) (values (slot-value c 's1) *class-19-s1-initvar*)) x nil) ;;; (declaim (special *class-20-s1-initvar-1* *class-20-s1-initvar-2*)) (defclass class-20 () ((s1 :initarg :s1 :initarg :s1b)) (:default-initargs :s1 (setf *class-20-s1-initvar-1* 'a) :s1b (setf *class-20-s1-initvar-2* 'b))) (deftest class-20.1 (let* (*class-20-s1-initvar-1* *class-20-s1-initvar-2* (c (make-instance 'class-20))) (declare (special *class-20-s1-initvar-1* *class-20-s1-initvar-2*)) (values (slot-value c 's1) *class-20-s1-initvar-1* *class-20-s1-initvar-2*)) a a b) (deftest class-20.2 (let* (*class-20-s1-initvar-1* *class-20-s1-initvar-2* (c (make-instance 'class-20 :s1 'x))) (declare (special *class-20-s1-initvar-1* *class-20-s1-initvar-2*)) (values (slot-value c 's1) *class-20-s1-initvar-1* *class-20-s1-initvar-2*)) x nil b) (deftest class-20.3 (let* (*class-20-s1-initvar-1* *class-20-s1-initvar-2* (c (make-instance 'class-20 :s1b 'y))) (declare (special *class-20-s1-initvar-1* *class-20-s1-initvar-2*)) (values (slot-value c 's1) *class-20-s1-initvar-1* *class-20-s1-initvar-2*)) y a nil) ;;; (declaim (special *class-21-s1-initvar-1* *class-21-s1-initvar-2*)) (let ((*class-21-s1-initvar-1* 0) (*class-21-s1-initvar-2* 0)) (defclass class-21 () ((s1 :initarg :s1 :initarg :s1b) (s2 :initarg :s1b :initarg :s2)) (:default-initargs :s1 (incf *class-21-s1-initvar-1*) :s1b (incf *class-21-s1-initvar-2*)))) (deftest class-21.1 (let* ((*class-21-s1-initvar-1* 10) (*class-21-s1-initvar-2* 20) (c (make-instance 'class-21))) (declare (special *class-21-s1-initvar-1* *class-21-s1-initvar-2*)) (values (slot-value c 's1) (slot-value c 's2) *class-21-s1-initvar-1* *class-21-s1-initvar-2*)) 11 21 11 21) (deftest class-21.2 (let* ((*class-21-s1-initvar-1* 10) (*class-21-s1-initvar-2* 20) (c (make-instance 'class-21 :s1 'x))) (declare (special *class-21-s1-initvar-1* *class-21-s1-initvar-2*)) (values (slot-value c 's1) (slot-value c 's2) *class-21-s1-initvar-1* *class-21-s1-initvar-2*)) x 21 10 21) (deftest class-21.3 (let* ((*class-21-s1-initvar-1* 10) (*class-21-s1-initvar-2* 20) (c (make-instance 'class-21 :s1 'x :s1b 'y))) (declare (special *class-21-s1-initvar-1* *class-21-s1-initvar-2*)) (values (slot-value c 's1) (slot-value c 's2) *class-21-s1-initvar-1* *class-21-s1-initvar-2*)) x y 10 20) (deftest class-21.4 (let* ((*class-21-s1-initvar-1* 10) (*class-21-s1-initvar-2* 20) (c (make-instance 'class-21 :s1b 'y))) (declare (special *class-21-s1-initvar-1* *class-21-s1-initvar-2*)) (values (slot-value c 's1) (slot-value c 's2) *class-21-s1-initvar-1* *class-21-s1-initvar-2*)) y y 11 20) (deftest class-21.5 (let* ((*class-21-s1-initvar-1* 10) (*class-21-s1-initvar-2* 20) (c (make-instance 'class-21 :s2 'y))) (declare (special *class-21-s1-initvar-1* *class-21-s1-initvar-2*)) (values (slot-value c 's1) (slot-value c 's2) *class-21-s1-initvar-1* *class-21-s1-initvar-2*)) 11 y 11 21) ;;; Documentation strings (defclass class-22 () ((s1 :documentation "This is slot s1 in class class-22"))) (deftest class-22.1 (notnot-mv (typep (make-instance 'class-22) 'class-22)) t) ;;; We can't portably get at the docstring of slots ;;; (defclass class-23 () (s1 s2 s3) (:documentation "This is class-23 in ansi-tests")) (deftest class-23.1 (notnot-mv (typep (make-instance 'class-23) 'class-23)) t) (deftest class-23.2 (let ((doc (documentation 'class-23 'type))) (or (null doc) (equalt doc "This is class-23 in ansi-tests"))) t) (deftest class-23.3 (let ((doc (documentation (find-class 'class-23) 'type))) (or (null doc) (equalt doc "This is class-23 in ansi-tests"))) t) (deftest class-23.4 (let ((doc (documentation (find-class 'class-23) t))) (or (null doc) (equalt doc "This is class-23 in ansi-tests"))) t) ;;; (defclass class-24 () ((s1 :initarg :allow-other-keys :reader s1)) (:default-initargs :allow-other-keys t)) (deftest class-24.1 (s1 (make-instance 'class-24)) t) (deftest class-24.2 (s1 (make-instance 'class-24 :nonsense t)) t) (deftest class-24.3 (s1 (make-instance 'class-24 :allow-other-keys nil)) nil) (deftest class-24.4 (s1 (make-instance 'class-24 :allow-other-keys 'a :foo t)) a) ;;; (defclass class-25 () ((s1 :initarg :allow-other-keys :reader s1)) (:default-initargs :allow-other-keys nil)) (deftest class-25.1 (s1 (make-instance 'class-25)) nil) (deftest class-25.2 (s1 (make-instance 'class-25 :allow-other-keys t)) t) (deftest class-25.3 (s1 (make-instance 'class-25 :allow-other-keys t :foo nil)) t) (deftest class-25.4 (s1 (make-instance 'class-25 :allow-other-keys t :allow-other-keys nil)) t) (deftest class-25.5 (s1 (make-instance 'class-25 :allow-other-keys t :allow-other-keys nil :foo t)) t) (deftest class-25.6 (s1 (make-instance 'class-25 :allow-other-keys 'foo :allow-other-keys 'bar)) foo) ;;; (defclass class-26 () ((s1-26 :writer (setf s1-26)))) (deftest class-26.1 (let ((c (make-instance 'class-26))) (values (slot-boundp c 's1-26) (setf (s1-26 c) 'x) (slot-value c 's1-26) (typep* #'(setf s1-26) 'generic-function))) nil x x t) ;;; (defclass class-27 () (a (b :initform 10) (c :initarg :c) (d :initarg :d)) (:metaclass standard-class) (:default-initargs :d 17)) (deftest class-27.1 (let ((class (find-class 'class-27))) (values (subtypep* 'class-27 'standard-object) (subtypep* 'class-27 t) (subtypep* 'class-27 (find-class 'standard-object)) (subtypep* 'class-27 (find-class t)) (subtypep* class 'standard-object) (subtypep* class t) (subtypep* class (find-class 'standard-object)) (subtypep* class (find-class t)))) t t t t t t t t) (deftest class-27.2 (let ((c (make-instance 'class-27))) (values (slot-boundp* c 'a) (slot-value c 'b) (slot-boundp* c 'c) (slot-value c 'd))) nil 10 nil 17) (deftest class-27.3 (let ((c (make-instance 'class-27 :c 26 :d 43))) (values (slot-boundp* c 'a) (slot-value c 'b) (slot-value c 'c) (slot-value c 'd))) nil 10 26 43) ;;; (declaim (special *class-28-reset-fn* *class-28-query-fn*)) (declaim (type function *class-28-reset-fn* *class-28-query-fn*)) (let ((x 0) (y 0)) (flet ((%reset (a b) (setf x a y b)) (%query () (list x y))) (setf *class-28-reset-fn* #'%reset *class-28-query-fn* #'%query) (defclass class-28 () ((s1 :initform (incf x) :initarg :s1) (s2 :initarg :s2)) (:default-initargs :s2 (incf y))))) (deftest class-28.1 (let ((class (find-class 'class-28))) (funcall *class-28-reset-fn* 5 10) (list (funcall *class-28-query-fn*) (let ((obj (make-instance 'class-28))) (list (typep* obj 'class-28) (typep* obj class) (eqt (class-of obj) class) (map-slot-value obj '(s1 s2)) (funcall *class-28-query-fn*))))) ((5 10) (t t t (6 11) (6 11)))) (deftest class-28.2 (let ((class (find-class 'class-28))) (funcall *class-28-reset-fn* 5 10) (list (funcall *class-28-query-fn*) (let ((obj (make-instance 'class-28 :s1 17))) (list (typep* obj 'class-28) (typep* obj class) (eqt (class-of obj) class) (map-slot-value obj '(s1 s2)) (funcall *class-28-query-fn*))))) ((5 10) (t t t (17 11) (5 11)))) (deftest class-28.3 (let ((class (find-class 'class-28))) (funcall *class-28-reset-fn* 5 10) (list (funcall *class-28-query-fn*) (let ((obj (make-instance 'class-28 :s2 17))) (list (typep* obj 'class-28) (typep* obj class) (eqt (class-of obj) class) (map-slot-value obj '(s1 s2)) (funcall *class-28-query-fn*))))) ((5 10) (t t t (6 17) (6 10)))) gcl27-2.7.0/ansi-tests/defclass-02.lsp000066400000000000000000000370021454061450500172610ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Apr 25 07:16:57 2003 ;;;; Contains: Tests of DEFCLASS with simple inheritance (in-package :cl-test) ;;; (defclass class-0201 () ((a :initform 'x) (b :allocation :instance) (c :reader class-0201-c))) (defclass class-0202 (class-0201) (d (e :initform 'y) (f :allocation :instance))) (deftest class-0201.1 (let ((c (make-instance 'class-0201))) (values (map-slot-boundp* c '(a b c)) (map-slot-exists-p* c '(a b c)) (slot-value c 'a) (map-typep* c (list 'class-0201 'class-0202 (find-class 'class-0201) (find-class 'class-0202))) (class-name (class-of c)) )) (t nil nil) (t t t) x (t nil t nil) class-0201) (deftest class-0202.1 (let ((c (make-instance 'class-0202))) (values (map-slot-boundp* c '(a b c d e f)) (map-slot-value c '(a e)) (map-typep* c (list 'class-0201 'class-0202 (find-class 'class-0201) (find-class 'class-0202))) (class-name (class-of c)) )) (t nil nil nil t nil) (x y) (t t t t) class-0202) ;;; (defclass class-0203 () ((a :allocation :class) (b :allocation :instance))) (defclass class-0204 (class-0203) (c d)) (deftest class-0203.1 (let ((c1 (make-instance 'class-0203)) (c2 (make-instance 'class-0204))) (values (map-slot-boundp* c1 '(a b)) (map-slot-boundp* c2 '(a b c d)) (setf (slot-value c1 'a) 'x) (map-slot-boundp* c1 '(a b)) (map-slot-boundp* c2 '(a b c d)) (slot-value c1 'a) (slot-value c2 'a) (eqt (slot-makunbound c1 'a) c1) (map-slot-boundp* c1 '(a b)) (map-slot-boundp* c2 '(a b c d)))) (nil nil) (nil nil nil nil) x (t nil) (t nil nil nil) x x t (nil nil) (nil nil nil nil)) (deftest class-0203.2 (let ((c1 (make-instance 'class-0203)) (c2 (make-instance 'class-0204))) (values (map-slot-boundp* c1 '(a b)) (map-slot-boundp* c2 '(a b c d)) (setf (slot-value c1 'a) 'x) (map-slot-boundp* c1 '(a b)) (map-slot-boundp* c2 '(a b c d)) (slot-value c1 'a) (slot-value c2 'a) (eqt (slot-makunbound c2 'a) c2) (map-slot-boundp* c1 '(a b)) (map-slot-boundp* c2 '(a b c d)))) (nil nil) (nil nil nil nil) x (t nil) (t nil nil nil) x x t (nil nil) (nil nil nil nil)) ;;; (defclass class-0205a () ((a :initform 'x) (b :initform 'y) c)) (defclass class-0205b (class-0205a) ((a :initform 'z) b (c :initform 'w))) (deftest class-0205a.1 (let ((c (make-instance 'class-0205a))) (values (slot-value c 'a) (slot-value c 'b) (slot-boundp c 'c))) x y nil) (deftest class-0205b.1 (let ((c (make-instance 'class-0205b))) (map-slot-value c '(a b c))) (z y w)) ;;; (defclass class-0206a () ((a :allocation :instance) (b :allocation :class))) (defclass class-0206b (class-0206a) ((a :allocation :class) (b :allocation :instance))) (deftest class-0206.1 (let ((c1 (make-instance 'class-0206a)) (c2 (make-instance 'class-0206b))) (values (map-slot-boundp* c1 '(a b)) (map-slot-boundp* c2 '(a b)) (setf (slot-value c1 'a) 'x) (setf (slot-value c1 'b) 'y) (map-slot-boundp* c1 '(a b)) (map-slot-boundp* c2 '(a b)) (map-slot-value c1 '(a b)) (progn (slot-makunbound c1 'a) (slot-makunbound c1 'b) (setf (slot-value c2 'a) 'x)) (setf (slot-value c2 'b) 'y) (map-slot-boundp* c1 '(a b)) (map-slot-boundp* c2 '(a b)) (map-slot-value c2 '(a b)) (progn (slot-makunbound c2 'a) (slot-makunbound c2 'b) nil))) (nil nil) (nil nil) x y (t t) (nil nil) (x y) x y (nil nil) (t t) (x y) nil) ;;; ;;; Show shadowing of slots by :allocation (defclass class-0207a () ((a :allocation :class))) (defclass class-0207b (class-0207a) ((a :allocation :instance))) (defclass class-0207c (class-0207b) ((a :allocation :class))) (deftest class-0207.1 (let ((c1 (make-instance 'class-0207a)) (c2 (make-instance 'class-0207b)) (c3 (make-instance 'class-0207c))) (slot-makunbound c1 'a) (slot-makunbound c2 'a) (slot-makunbound c3 'a) (values (setf (slot-value c1 'a) 'x) (slot-boundp* c1 'a) (slot-boundp* c2 'a) (slot-boundp* c3 'a) (slot-value c1 'a) (setf (slot-value c2 'a) 'y) (slot-boundp* c1 'a) (slot-boundp* c2 'a) (slot-boundp* c3 'a) (slot-value c1 'a) (slot-value c2 'a) (setf (slot-value c3 'a) 'z) (slot-boundp* c1 'a) (slot-boundp* c2 'a) (slot-boundp* c3 'a) (slot-value c1 'a) (slot-value c2 'a) (slot-value c3 'a))) x t nil nil x y t t nil x y z t t t x y z) ;;; ;;; Initforms are inherited even if :allocation changes (defclass class-0208a () ((a :allocation :class :initform 'x))) (defclass class-0208b (class-0208a) ((a :allocation :instance))) (deftest class-0208.1 (values (slot-value (make-instance 'class-0208a) 'a) (slot-value (make-instance 'class-0208b) 'a)) x x) ;;; ;;; That was failing when things were reloaded. ;;; Try a test that redefines it (deftest class-redefinition.1 (let* ((cobj1 (eval '(defclass class-0209a () ((a :allocation :class :initform 'x))))) (cobj2 (eval '(defclass class-0209b (class-0209a) ((a :allocation :instance))))) (cobj3 (eval '(defclass class-0209a () ((a :allocation :class :initform 'x))))) (cobj4 (eval '(defclass class-0209b (class-0209a) ((a :allocation :instance)))))) (values (eqt cobj1 cobj3) (eqt cobj2 cobj4) (class-name cobj1) (class-name cobj2) (slot-value (make-instance 'class-0209a) 'a) (slot-value (make-instance 'class-0209b) 'a))) t t class-0209a class-0209b x x) (deftest class-redefinition.2 (let* ( (cobj1 (eval '(defclass class-0210a () ((a :allocation :class))))) (cobj2 (eval '(defclass class-0210b (class-0210a) ((a :allocation :instance))))) (cobj3 (eval '(defclass class-0210c (class-0210b) ((a :allocation :class))))) (dummy (progn (setf (slot-value (make-instance 'class-0210a) 'a) :bad1) (make-instance 'class-0210b) (make-instance 'class-0210c) nil)) (cobj4 (eval '(defclass class-0210a () ((a :allocation :class))))) (cobj5 (eval '(defclass class-0210b (class-0210a) ((a :allocation :instance))))) (cobj6 (eval '(defclass class-0210c (class-0210b) ((a :allocation :class)))))) (list (eqt cobj1 cobj4) (eqt cobj2 cobj5) (eqt cobj3 cobj6) (class-name cobj1) (class-name cobj2) (class-name cobj3) (let ((c1 (make-instance 'class-0210a)) (c2 (make-instance 'class-0210b)) (c3 (make-instance 'class-0210c))) (slot-makunbound c1 'a) (slot-makunbound c2 'a) (slot-makunbound c3 'a) (list (setf (slot-value c1 'a) 'x) (and (slot-boundp* c1 'a) (slot-value c1 'a)) (slot-boundp* c2 'a) (slot-boundp* c3 'a) (setf (slot-value c2 'a) 'y) (and (slot-boundp* c1 'a) (slot-value c1 'a)) (and (slot-boundp* c2 'a) (slot-value c2 'a)) (slot-boundp* c3 'a) (setf (slot-value c3 'a) 'z) (and (slot-boundp* c1 'a) (slot-value c1 'a)) (and (slot-boundp* c2 'a) (slot-value c2 'a)) (and (slot-boundp* c3 'a) (slot-value c3 'a)))))) (t t t class-0210a class-0210b class-0210c (x x nil nil y x y nil z x y z))) ;;; Same as class-redefinition.1, but reverse the order in which ;;; the classes are redefined. (deftest class-redefinition.3 (let* ((cobj1 (eval '(defclass class-redef-03a () ((a :allocation :class :initform 'x))))) (cobj2 (eval '(defclass class-redef-03b (class-redef-03a) ((a :allocation :instance))))) (cobj4 (eval '(defclass class-redef-03b (class-redef-03a) ((a :allocation :instance))))) (cobj3 (eval '(defclass class-redef-03a () ((a :allocation :class :initform 'x)))))) (values (eqt cobj1 cobj3) (eqt cobj2 cobj4) (class-name cobj1) (class-name cobj2) (slot-value (make-instance 'class-redef-03a) 'a) (slot-value (make-instance 'class-redef-03b) 'a))) t t class-redef-03a class-redef-03b x x) ;;; Initforms are inherited even if :allocation changes (defclass class-0211a () ((a :allocation :instance :initform 'x))) (defclass class-0211b (class-0211a) ((a :allocation :class))) (deftest class-0211.1 (values (slot-value (make-instance 'class-0211a) 'a) (slot-value (make-instance 'class-0211b) 'a)) x x) ;;; ;;; Inheritance of :initargs (defclass class-0212a () ((a :initarg :a1))) (defclass class-0212b (class-0212a) ((a :initarg :a2) (b :initarg :b))) (deftest class-0212.1 (let ((c (make-instance 'class-0212a :a1 'x))) (values (typep* c 'class-0212a) (typep* c 'class-0212b) (slot-value c 'a) (slot-exists-p c 'b))) t nil x nil) (deftest class-0212.2 (let ((c (make-instance 'class-0212b :a1 'x))) (values (typep* c 'class-0212a) (typep* c 'class-0212b) (slot-value c 'a) (slot-boundp* c 'b))) t t x nil) (deftest class-0212.3 (let ((c (make-instance 'class-0212b :a2 'x :b 'y))) (values (typep* c 'class-0212a) (typep* c 'class-0212b) (slot-value c 'a) (slot-value c 'b))) t t x y) (deftest class-0212.4 (let ((c (make-instance 'class-0212b :a1 'z :a2 'x :b 'y))) (values (typep* c 'class-0212a) (typep* c 'class-0212b) (slot-value c 'a) (slot-value c 'b))) t t z y) (deftest class-0212.5 (let ((c (make-instance 'class-0212b :a2 'x :b 'y :a1 'z))) (values (typep* c 'class-0212a) (typep* c 'class-0212b) (slot-value c 'a) (slot-value c 'b))) t t x y) ;;; (defclass class-0213a () ((a :initarg :a1))) (defclass class-0213b (class-0213a) (b)) (deftest class-0213.1 (let ((c (make-instance 'class-0213a :a1 'x))) (values (typep* c 'class-0213a) (typep* c 'class-0213b) (slot-value c 'a) (slot-exists-p c 'b))) t nil x nil) (deftest class-0213.2 (let ((c (make-instance 'class-0213b :a1 'x))) (values (typep* c 'class-0213a) (typep* c 'class-0213b) (slot-value c 'a) (slot-boundp* c 'b))) t t x nil) ;;; (defclass class-0214a () ((a :initarg :a1 :allocation :class))) (defclass class-0214b (class-0214a) (b)) (deftest class-0214.1 (let ((c (make-instance 'class-0214a :a1 'x))) (values (typep* c 'class-0214a) (typep* c 'class-0214b) (slot-value c 'a) (slot-exists-p c 'b))) t nil x nil) (deftest class-0214.2 (let ((c (make-instance 'class-0214b :a1 'y))) (values (typep* c 'class-0214a) (typep* c 'class-0214b) (slot-value c 'a) (slot-boundp* c 'b))) t t y nil) ;;; (defclass class-0215a () ((a :initarg :a1 :allocation :instance))) (defclass class-0215b (class-0215a) ((a :allocation :class))) (deftest class-0215.1 (let ((c (make-instance 'class-0215a :a1 'x))) (values (typep* c 'class-0215a) (typep* c 'class-0215b) (slot-value c 'a))) t nil x) (deftest class-0215.2 (let ((c (make-instance 'class-0215b :a1 'y))) (values (typep* c 'class-0215a) (typep* c 'class-0215b) (slot-value c 'a))) t t y) ;;; Tests of defaulted initargs (defclass class-0216a () ((a :initarg :a1) (b :initarg :b1))) (defclass class-0216b (class-0216a) () (:default-initargs :a1 'x)) (deftest class-0216.1 (let ((c (make-instance 'class-0216a))) (values (typep* c 'class-0216a) (typep* c 'class-0216b) (slot-boundp c 'a) (slot-boundp c 'b))) t nil nil nil) (deftest class-0216.2 (let ((c (make-instance 'class-0216b))) (values (typep* c 'class-0216a) (typep* c 'class-0216b) (slot-value c 'a) (slot-boundp c 'b))) t t x nil) ;;; (defclass class-0217a () ((a :initarg :a1) (b :initarg :b1) (c :initarg :c1) (d :initarg :d1)) (:default-initargs :a1 10 :b1 20)) (defclass class-0217b (class-0217a) () (:default-initargs :a1 30 :c1 40)) (deftest class-0217.1 (let ((c (make-instance 'class-0217a))) (values (map-slot-boundp* c '(a b c d)) (map-slot-value c '(a b)))) (t t nil nil) (10 20)) (deftest class-0217.2 (let ((c (make-instance 'class-0217a :a1 'x :c1 'y))) (values (map-slot-boundp* c '(a b c d)) (map-slot-value c '(a b c)))) (t t t nil) (x 20 y)) (deftest class-0217.3 (let ((c (make-instance 'class-0217b))) (values (map-slot-boundp* c '(a b c d)) (map-slot-value c '(a b c)))) (t t t nil) (30 20 40)) (deftest class-0217.4 (let ((c (make-instance 'class-0217b :a1 'x :d1 'y))) (values (map-slot-boundp* c '(a b c d)) (map-slot-value c '(a b c d)))) (t t t t) (x 20 40 y)) ;;; (defclass class-0218a () ((a :initarg :a1)) (:default-initargs :a1 'x)) (defclass class-0218b (class-0218a) ((a :initform 'y))) (deftest class-0218.1 (let ((c (make-instance 'class-0218a))) (slot-value c 'a)) x) (deftest class-0218.2 (let ((c (make-instance 'class-0218b))) (slot-value c 'a)) x) ;;; (declaim (special *class-0219-a-1* *class-0219-a-2*)) (defclass class-0219a () ((a :initarg :a1)) (:default-initargs :a1 (setf *class-0219-a-1* 'x))) (defclass class-0219b () ((a :initarg :a1)) (:default-initargs :a1 (setf *class-0219-a-2* 'y))) (deftest class-0219.1 (let ((*class-0219-a-1* nil)) (values (slot-value (make-instance 'class-0219a) 'a) *class-0219-a-1*)) x x) (deftest class-0219.2 (let ((*class-0219-a-1* nil) (*class-0219-a-2* nil)) (values (slot-value (make-instance 'class-0219b) 'a) *class-0219-a-1* *class-0219-a-2*)) y nil y) ;;; (defclass class-0220a () ((a :type (integer 0 10) :initarg :a))) (defclass class-0220b (class-0220a) ((a :type (integer -5 5)))) (deftest class-0220.1 (slot-value (make-instance 'class-0220a :a 10) 'a) 10) (deftest class-0220.2 (slot-value (make-instance 'class-0220a :a 0) 'a) 0) (deftest class-0220.3 (slot-value (make-instance 'class-0220b :a 0) 'a) 0) (deftest class-0220.4 (slot-value (make-instance 'class-0220b :a 5) 'a) 5) ;;; (defclass class-0221a () (a b c) (:documentation "This is class class-0221a")) (defclass class-0221b (class-0221a) ()) (defclass class-0221c (class-0221a) () (:documentation "This is class class-0221c")) (deftest class-0221.1 (let* ((cl (find-class 'class-0221a)) (doc (documentation cl t))) (or (null doc) (equalt doc "This is class class-0221a"))) t) (deftest class-0221.2 (let* ((cl (find-class 'class-0221b)) (doc (documentation cl t))) doc) nil) (deftest class-0221.3 (let* ((cl (find-class 'class-0221c)) (doc (documentation cl t))) (or (null doc) (equalt doc "This is class class-0221c"))) t) ;;; (defclass class-0222a () ((s1 :reader s1-r :writer s1-w :accessor s1-acc))) (defclass class-0222b (class-0222a) ()) (deftest class-0222.1 (let ((c (make-instance 'class-0222a))) (values (s1-w 'x c) (s1-r c) (s1-acc c) (setf (s1-acc c) 'y) (s1-r c))) x x x y y) (deftest class-0222.2 (let ((c (make-instance 'class-0222b))) (values (s1-w 'x c) (s1-r c) (s1-acc c) (setf (s1-acc c) 'y) (s1-r c))) x x x y y) ;;; (defclass class-0223a () ((s1 :reader s-r :writer s-w :accessor s-acc))) (defclass class-0223b (class-0223a) ((s2 :reader s-r :writer s-w :accessor s-acc))) (deftest class-0223.1 (let ((c (make-instance 'class-0223b))) (values (setf (slot-value c 's1) 'x) (setf (slot-value c 's2) 'y) (s-r c) (s-acc c) (s-w 'z c) (slot-value c 's1) (slot-value c 's2) (s-r c) (s-acc c))) x y y y z x z z z) gcl27-2.7.0/ansi-tests/defclass-03.lsp000066400000000000000000000146751454061450500172750ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 27 16:23:59 2003 ;;;; Contains: Tests of DEFCLASS with more involved inheritance (in-package :cl-test) ;;; (defclass class-0301a () (a b)) (defclass class-0301b () (a c)) (defclass class-0301c (class-0301a class-0301b) (d)) (deftest class-0301.1 (let ((c (make-instance 'class-0301c))) (values (typep* c 'class-0301a) (typep* c 'class-0301b) (typep* c 'class-0301c) (typep* c (find-class 'class-0301a)) (typep* c (find-class 'class-0301b)) (typep* c (find-class 'class-0301c)) (map-slot-boundp* c '(a b c d)) (setf (slot-value c 'a) 'w) (setf (slot-value c 'b) 'x) (setf (slot-value c 'c) 'y) (setf (slot-value c 'd) 'z) (map-slot-boundp* c '(a b c d)) (map-slot-value c '(a b c d)))) t t t t t t (nil nil nil nil) w x y z (t t t t) (w x y z)) ;;; (defclass class-0302a () ((a :initform 'x) b (c :initform 'w))) (defclass class-0302b () ((a :initform 'y) (b :initform 'z))) (defclass class-0302c (class-0302a class-0302b) (a b (c :initform 'v) d)) (deftest class-0302.1 (let ((c (make-instance 'class-0302c))) (values (map-slot-boundp* c '(a b c d)) (map-slot-value c '(a b c)))) (t t t nil) (x z v)) ;;; (defclass class-0303a () ((a :allocation :class) b)) (defclass class-0303b () (a (b :allocation :class))) (defclass class-0303c (class-0303a class-0303b) ()) (deftest class-0303.1 (let ((c1 (make-instance 'class-0303a)) (c2 (make-instance 'class-0303b)) (c3 (make-instance 'class-0303c))) (slot-makunbound c1 'a) (slot-makunbound c2 'b) (values (loop for c in (list c1 c2 c3) collect (map-slot-boundp* c '(a b))) (list (setf (slot-value c1 'a) 'x1) (slot-boundp* c2 'a) (slot-value c3 'a)) (list (setf (slot-value c2 'a) 'x2) (slot-value c1 'a) (slot-value c2 'a) (slot-value c3 'a)) (list (setf (slot-value c3 'a) 'x3) (slot-value c1 'a) (slot-value c2 'a) (slot-value c3 'a)) ;;; (list (setf (slot-value c1 'b) 'y1) (slot-value c1 'b) (slot-boundp* c2 'b) (slot-boundp* c3 'b)) (list (setf (slot-value c2 'b) 'y2) (slot-value c1 'b) (slot-value c2 'b) (slot-boundp c3 'b)) (list (setf (slot-value c3 'b) 'y3) (slot-value c1 'b) (slot-value c2 'b) (slot-value c3 'b)))) ((nil nil) (nil nil) (nil nil)) (x1 nil x1) (x2 x1 x2 x1) (x3 x3 x2 x3) ;; (y1 y1 nil nil) (y2 y1 y2 nil) (y3 y1 y2 y3)) ;;; (defclass class-0304a () ((a :initform 'x))) (defclass class-0304b (class-0304a) ()) (defclass class-0304c (class-0304a) ((a :initform 'y))) (defclass class-0304d (class-0304b class-0304c) ()) (deftest class-0304.1 (slot-value (make-instance 'class-0304d) 'a) y) ;;; (defclass class-0305a () ((a :initarg :a)) (:default-initargs :a 'x)) (defclass class-0305b (class-0305a) ()) (defclass class-0305c (class-0305a) () (:default-initargs :a 'y)) (defclass class-0305d (class-0305b class-0305c) ()) (deftest class-0305.1 (slot-value (make-instance 'class-0305d) 'a) y) ;;; A test showing nonmonotonicity in the CLOS CPL algorithm (defclass class-0306a () ((a :initform nil :reader a-slot))) (defclass class-0306b (class-0306a) ((a :initform 'x))) (defclass class-0306c (class-0306a) ((a :initform 'y))) (defclass class-0306d (class-0306b) ()) (defclass class-0306e (class-0306b) ()) (defclass class-0306f (class-0306d class-0306c) ()) (defclass class-0306g (class-0306e) ()) (defclass class-0306h (class-0306f class-0306g) ()) ;;; Class class-0306c should precede class-0306b in the ;;; CPL for class-0306h, even though it follows it in the CPLs ;;; for the direct superclasses of class-0306h. (deftest class-0306.1 (loop for obj in (mapcar #'make-instance '(class-0306a class-0306b class-0306c class-0306d class-0306e class-0306f class-0306g class-0306h)) collect (slot-value obj 'a)) (nil x y x x x x y)) (deftest class-0306.2 (loop for obj in (mapcar #'make-instance '(class-0306a class-0306b class-0306c class-0306d class-0306e class-0306f class-0306g class-0306h)) collect (a-slot obj)) (nil x y x x x x y)) ;;; A class redefinition test that came up in cmucl (deftest class-0307.1 (progn (setf (find-class 'class-0307a) nil (find-class 'class-0307b) nil) (eval '(defclass class-0307a () ())) (eval '(defclass class-0307b (class-0307a) (a))) (eval '(defclass class-0307a () ((a :initform nil)))) (eval '(defclass class-0307b (class-0307a) ((a :initform 'x)))) (slot-value (make-instance 'class-0307b) 'a)) x) (deftest class-0308.1 (progn (setf (find-class 'class-0308a) nil (find-class 'class-0308b) nil) (eval '(defclass class-0308a () ())) (eval '(defclass class-0308b (class-0308a) (a))) (eval '(defclass class-0308a () ((a :initarg :a)))) (eval '(defclass class-0308b (class-0308a) ())) (slot-value (make-instance 'class-0308b :a 'x) 'a)) x) ;;; More class redefinition tests (deftest class-0309.1 (progn (setf (find-class 'class-0309) nil) (let* ((class1 (eval '(defclass class-0309 () ((a) (b) (c))))) (obj1 (make-instance 'class-0309))) (setf (class-name class1) nil) (let ((class2 (eval '(defclass class-0309 () ((a) (b) (c)))))) (values (eqt (class-of obj1) class1) (eqt class1 class2) (typep* obj1 class1) (typep* obj1 class2))))) t nil t nil) (deftest class-0310.1 (progn (setf (find-class 'class-0310a) nil (find-class 'class-0310b) nil) (let* ((class1 (eval '(defclass class-0310a () ((a) (b) (c))))) (obj1 (make-instance 'class-0310a))) (setf (class-name class1) 'class-0310b) (let ((class2 (eval '(defclass class-0310a () ((a) (b) (c)))))) (values (eqt (class-of obj1) class1) (eqt class1 class2) (typep* obj1 class1) (typep* obj1 class2) (class-name class1) (class-name class2))))) t nil t nil class-0310b class-0310a) (deftest class-0311.1 (progn (setf (find-class 'class-0311) nil) (let* ((class1 (eval '(defclass class-0311 () ((a) (b) (c))))) (obj1 (make-instance 'class-0311))) (setf (find-class 'class-0311) nil) (let ((class2 (eval '(defclass class-0311 () ((a) (b) (c)))))) (values (eqt (class-of obj1) class1) (eqt class1 class2) (typep* obj1 class1) (typep* obj1 class2) (class-name class1) (class-name class2) (eqt (find-class 'class-0311) class1) (eqt (find-class 'class-0311) class2))))) t nil t nil class-0311 class-0311 nil t) gcl27-2.7.0/ansi-tests/defclass-aux.lsp000066400000000000000000000241741454061450500176430ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Mar 24 03:40:24 2003 ;;;; Contains: Auxiliary functions for testing CLOS (in-package :cl-test) (defun make-defclass-test-name (&rest args) (intern (apply #'concatenate 'string (mapcar #'string args)) (find-package :cl-test))) (defparameter *defclass-slot-readers* nil) (defparameter *defclass-slot-writers* nil) (defparameter *defclass-slot-accessors* nil) (defstruct my-class (name nil :type symbol) (direct-superclass-names nil :type list) (slots nil :type list) (default-initargs nil :type list) (metaclass 'standard-class :type symbol) (documentation nil :type (or null string)) ;; Internal fields (preds nil :type list) (succs nil :type list) (count 0 :type integer) (index nil) (min-pred-index 1000000) ) (defstruct my-slot (name nil :type symbol) (has-initform nil :type boolean) initform (initargs nil :type list) (documentation nil :type (or null string)) (readers nil :type list) (writers nil :type list) (accessors nil :type list) (allocation :instance :type (member :instance :class)) (type t) ) (defparameter *my-classes* (make-hash-table) "Hash table mapping names of classes defined using DEFCLASS-WITH-TESTS to their my-class objects.") (defun find-my-class (class-name) (gethash class-name *my-classes*)) ;;; This macro will assume that all the superclasses have already ;;; been defined. Tests will be written with defclass itself ;;; to test forward referenced superclasses (defmacro defclass-with-tests (&whole args class-name superclasses slot-specifiers &rest class-options) (assert (typep class-name '(and (not null) symbol))) (assert (listp superclasses)) (assert (every #'(lambda (x) (typep x '(and (not null) symbol))) superclasses)) (assert (listp slot-specifiers)) (assert (every #'(lambda (s) (or (symbolp s) (and (consp s) (symbolp (car s))))) slot-specifiers)) (assert (every #'(lambda (x) (and (consp x) (member (car x) '(:default-initargs :documentation :metaclass)))) class-options)) (assert (eql (length class-options) (length (remove-duplicates class-options)))) (let* ((default-initargs (rest (assoc :default-initargs class-options))) (metaclass (or (second (assoc :metaclass class-options)) 'standard-class)) (doc (second (assoc :documentation class-options))) (slot-names (loop for slot-spec in slot-specifiers collect (cond ((symbolp slot-spec) slot-spec) (t (assert (consp slot-spec)) (assert (symbolp (car slot-spec))) (car slot-spec))))) (slot-options (loop for slot-spec in slot-specifiers collect (if (consp slot-spec) (cdr slot-spec) nil))) (readers (loop for slot-option in slot-options append (collect-properties slot-option :reader))) (writers (loop for slot-option in slot-options append (collect-properties slot-option :writer))) (accessors (loop for slot-option in slot-options append (collect-properties slot-option :accessor))) (allocations (loop for slot-option in slot-options collect (or (get slot-option :allocation) :instance))) (initargs (loop for slot-option in slot-options collect (collect-properties slot-option :initarg))) (types (loop for slot-option in slot-options collect (collect-properties slot-option :type))) (initforms (loop for slot-option in slot-options collect (collect-properties slot-option :initform))) (class-var-name (intern (concatenate 'string "*CLASS-" (symbol-name class-name) "-RETURNED-BY-DEFCLASS*") (find-package :cl-test))) ) (declare (ignorable readers writers accessors allocations initargs types initforms default-initargs doc)) (assert (loop for e in types always (< (length e) 2))) (assert (loop for e in initforms always (< (length e) 2))) (setf *defclass-slot-readers* (append readers *defclass-slot-readers*)) (setf *defclass-slot-writers* (append writers *defclass-slot-writers*)) (setf *defclass-slot-accessors* (append accessors *defclass-slot-accessors*)) ;;; Store away information about the class and its slots ;;; in a my-class object and associated my-slot objects. (let* ((my-slots (loop for name in slot-names for slot-option in slot-options for readers = (collect-properties slot-option :reader) for writers = (collect-properties slot-option :writer) for accessors = (collect-properties slot-option :accessor) for documentation = (getf slot-option :documentation) for initarg-list in initargs for type-list in types for initform-list in initforms for allocation in allocations collect (make-my-slot :name name :has-initform (notnot initform-list) :initform (first initform-list) :documentation documentation :readers readers :writers writers :accessors accessors :type (if type-list (first type-list) t) ))) (my-class-obj (make-my-class :name class-name :direct-superclass-names superclasses :default-initargs default-initargs :documentation doc :metaclass metaclass :slots my-slots))) (setf (gethash class-name *my-classes*) my-class-obj)) `(progn (declaim (special ,class-var-name)) (report-and-ignore-errors (setq ,class-var-name (defclass ,@(cdr args)))) (deftest ,(make-defclass-test-name class-name "-DEFCLASS-RETURNS-CLASS") (eqt (find-class ',class-name) ,class-var-name) t) (deftest ,(make-defclass-test-name class-name "-IS-IN-ITS-METACLASS") (notnot-mv (typep (find-class ',class-name) ',metaclass)) t) ,@(when (eq metaclass 'standard-class) `((deftest ,(make-defclass-test-name class-name "S-ARE-STANDARD-OBJECTS") (subtypep* ',class-name 'standard-object) t t))) ,@(loop for slot-name in slot-names collect `(deftest ,(make-defclass-test-name class-name "-HAS-SLOT-NAMED-" slot-name) (notnot-mv (slot-exists-p (make-instance ',class-name) ',slot-name)) t)) (deftest ,(make-defclass-test-name class-name "-ALLOCATE-INSTANCE") (defclass-allocate-instance-test ',class-name ',slot-names) nil) ))) (defun defclass-allocate-instance-test (class-name slot-names) (let* ((class (find-class class-name)) (instance (allocate-instance class))) (append (unless (eql (class-of instance) class) (list (list 'not-instance-of class-name))) (loop for slot in slot-names when (slot-boundp instance slot) collect (list 'is-bound slot)) (loop for slot in slot-names unless (equal (multiple-value-list (notnot-mv (slot-exists-p instance slot))) '(t)) collect (list 'does-not-exist slot)) (let ((bad-slot '#:foo)) (when (slot-exists-p instance bad-slot) (list (list 'should-not-exist bad-slot)))) ))) (defmacro generate-slot-tests () "Generate generic tests from the read/writer/accessor functions for slots from defclass-with-tests." (let ((funs (remove-duplicates (append *defclass-slot-readers* *defclass-slot-writers* *defclass-slot-accessors*)))) `(progn (deftest class-readers/writers/accessors-are-generic-functions (loop for sym in ',funs unless (typep (symbol-function sym) 'generic-function) collect sym) nil) (deftest class-accessors-have-generic-setf-functions (append ,@(loop for sym in *defclass-slot-accessors* collect `(and (not (typep (function (setf ,sym)) 'generic-function)) '(,sym)))) nil)))) (defun my-compute-class-precedence-list (class-name) "Compute the class precdence list for classes defined using DEFCLASS-WITH-TESTS." (let ((class-names nil) (class-names-to-consider (list class-name)) classes) ;; Find all classes (loop while class-names-to-consider do (let ((name (pop class-names-to-consider))) (unless (member name class-names) (push name class-names) (let ((my-class (find-my-class name))) (assert my-class) (setq class-names-to-consider (append (my-class-direct-superclass-names my-class) class-names-to-consider)))))) (setq class-names (reverse class-names)) (assert (eq class-name (first class-names))) ;; class-names now contains class-name (which occurs first) and ;; the names of all its superclasses except T (setq classes (mapcar #'find-my-class class-names)) ;; Walk the classes and set the predecessor links in the ;; class precedence DAG (loop for c in classes for dsns = (my-class-direct-superclass-names c) do (let ((pred c)) (loop for superclass-name in dsns for superclass = (find-my-class superclass-name) do (push pred (my-class-preds superclass)) do (pushnew superclass (my-class-succs pred)) do (incf (my-class-count superclass)) do (setq pred superclass)))) ;; The list candidates will contain all the classes ;; for which the count is zero. These are the candidates ;; for selection as the next class in the class precedence list (let ((candidates (loop for c in classes when (zerop (my-class-count c)) collect c)) (n 0) (result nil)) (assert (equal candidates (list (first classes)))) (loop while candidates do (let* ((next (first candidates)) (min-pred-index (my-class-min-pred-index next))) (loop for c in (rest candidates) for c-min-pred-index = (my-class-min-pred-index c) do (cond ((< c-min-pred-index min-pred-index) (setq next c min-pred-index c-min-pred-index)) (t (assert (not (= c-min-pred-index min-pred-index)))))) (setq candidates (remove next candidates)) (setf (my-class-index next) (incf n)) (push next result) (loop for succ in (my-class-succs next) do (decf (my-class-count succ)) do (setf (my-class-min-pred-index succ) (min (my-class-min-pred-index succ) n)) do (when (zerop (my-class-count succ)) (push succ candidates))))) (assert (eql (length result) (length classes))) (setq result (reverse result)) (mapcar #'my-class-name result)))) gcl27-2.7.0/ansi-tests/defclass-errors.lsp000066400000000000000000000100201454061450500203430ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Apr 25 06:59:22 2003 ;;;; Contains: Error case tests for DEFCLASS (in-package :cl-test) ;;; I created some redundant tests by accident. This list of ;;; tests could be reduced in size. (deftest defclass.error.1 (signals-error (defclass erroneous-class.1 () (a b c d b e)) program-error) t) (deftest defclass.error.2 (signals-error (defclass erroneous-class.2 () ((s1 :initarg :foo)) (:default-initargs :foo 1 :foo 2)) program-error) t) (deftest defclass.error.3 (signals-error (defclass erroneous-class.3 () ((s1 :initform 0 :initform 2))) program-error) t) (deftest defclass.error.4 (signals-error (defclass erroneous-class.4 () ((s1 :initform 0 :initform 0))) program-error) t) (deftest defclass.error.5 (signals-error (defclass erroneous-class.5 () ((s1 :type fixnum :type character))) program-error) t) (deftest defclass.error.6 (signals-error (defclass erroneous-class.6 () ((s1 :type t :type t))) program-error) t) (deftest defclass.error.7 (signals-error (defclass erroneous-class.7 () ((s1 :documentation "foo" :documentation "bar"))) program-error) t) (deftest defclass.error.8 (signals-error (defclass erroneous-class.8 () ((s1 :documentation #1="foo" :documentation #1#))) program-error) t) (deftest defclass.error.9 (signals-error (defclass erroneous-class.9 () ((s1 :allocation :class :allocation :instance))) program-error) t) (deftest defclass.error.10 (signals-error (defclass erroneous-class.10 () ((s1 :allocation :class :allocation :class))) program-error) t) (deftest defclass.error.11 (signals-error (defclass erroneous-class.11 () ((s1 :allocation :instance :allocation :instance))) program-error) t) (deftest defclass.error.12 (signals-error (defclass erroneous-class.12 () ((s1 #.(gensym) nil))) program-error) t) (deftest defclass.error.13 (signals-error (defclass erroneous-class.13 () (a b c) (#.(gensym))) program-error) t) (deftest defclass.error.14 (signals-error (defclass defclass-error-14 nil (foo foo)) program-error) t) (deftest defclass.error.15 (signals-error (defclass defclass-error-15 nil (foo (foo))) program-error) t) (deftest defclass.error.16 (signals-error (defclass defclass-error-16 nil ((foo :initarg f1)) (:default-initargs :f1 10 :f1 20)) program-error) t) (deftest defclass.error.17 (signals-error (defclass defclass-error-17 nil ((foo :initform 10 :initform 20 :reader defclass-error-4/foo))) program-error) t) (deftest defclass.error.18 (signals-error (defclass defclass-error-18 nil ((foo :initform 10 :initform 10 :reader defclass-error-5/foo))) program-error) t) (deftest defclass.error.19 (signals-error (defclass defclass-error-19 nil ((foo :initarg f1 :type t :type t :reader defclass-error-6/foo))) program-error) t) (deftest defclass.error.20 (signals-error (defclass defclass-error-20 nil ((foo :initarg f1 :documentation "x" :reader defclass-error-7/foo :documentation "x"))) program-error) t) (deftest defclass.error.21 (signals-error (defclass defclass-error-21 () ((foo #:unknown-slot-option nil))) program-error) t) (deftest defclass.error.22 (let ((option (gentemp "UNKNOWN-OPTION" (symbol-package :foo)))) (eval `(signals-error (defclass defclass-error-22 () (foo bar) (,option nil)) program-error))) t) (deftest defclass.error.23 (loop for cl in *built-in-classes* for name = (class-name cl) unless (or (not name) (handler-case (progn (eval `(defclass ,(gensym) (,name))) nil) (error (c) c))) collect (list cl name)) nil) (deftest defclass.error.24 (loop for cl in *built-in-classes* for name = (class-name cl) unless (or (not name) (handler-case (progn (eval `(defclass ,name ())) nil) (error (c) c))) collect (list cl name)) nil) gcl27-2.7.0/ansi-tests/defclass-forward-reference.lsp000066400000000000000000000071111454061450500224360ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Apr 2 22:53:27 2003 ;;;; Contains: Tests for definitions of classes with forward references (in-package :cl-test) (deftest defclass.forward-ref.1 (let ((c1 (gensym)) (c2 (gensym))) (let ((class1 (eval `(defclass ,c1 (,c2) nil)))) (if (not (typep class1 'class)) 1 (let ((class2 (eval `(defclass ,c2 nil nil)))) (if (not (typep class2 'class)) 2 (let ((i1 (make-instance c1)) (i2 (make-instance c2))) (cond ((not (typep i1 c1)) 3) ((not (typep i1 class1)) 4) ((not (typep i1 c2)) 5) ((not (typep i1 class2)) 6) ((typep i2 c1) 7) ((typep i2 class1) 8) ((not (typep i2 c2)) 9) ((not (typep i2 class2)) 10) (t 'good)))))))) good) (deftest defclass.forward-ref.2 (let ((c1 (gensym)) (c2 (gensym)) (c3 (gensym))) (let ((class1 (eval `(defclass ,c1 (,c2 ,c3) nil)))) (if (not (typep class1 'class)) 1 (let ((class2 (eval `(defclass ,c2 nil nil)))) (if (not (typep class2 'class)) 2 (let ((class3 (eval `(defclass ,c3 nil nil)))) (if (not (typep class3 'class)) 3 (let ((i1 (make-instance c1)) (i2 (make-instance c2)) (i3 (make-instance c3))) (cond ((not (typep i1 c1)) 4) ((not (typep i1 class1)) 5) ((not (typep i1 c2)) 6) ((not (typep i1 class2)) 7) ((not (typep i1 c3)) 8) ((not (typep i1 class3)) 9) ((typep i2 c1) 10) ((typep i2 class1) 11) ((typep i3 c1) 12) ((typep i3 class1) 13) ((not (typep i2 c2)) 14) ((not (typep i2 class2)) 15) ((not (typep i3 c3)) 16) ((not (typep i3 class3)) 17) ((typep i2 c3) 18) ((typep i2 class3) 19) ((typep i3 c2) 20) ((typep i3 class2) 21) (t 'good)))))))))) good) (deftest defclass.forward-ref.3 (let ((c1 (gensym)) (c2 (gensym)) (c3 (gensym))) (let ((class1 (eval `(defclass ,c1 (,c2) nil)))) (if (not (typep class1 'class)) 1 (let ((class2 (eval `(defclass ,c2 (,c3) nil)))) (if (not (typep class2 'class)) 2 (let ((class3 (eval `(defclass ,c3 nil nil)))) (if (not (typep class3 'class)) 3 (let ((i1 (make-instance c1)) (i2 (make-instance c2)) (i3 (make-instance c3))) (cond ((not (typep i1 c1)) 4) ((not (typep i1 class1)) 5) ((not (typep i1 c2)) 6) ((not (typep i1 class2)) 7) ((not (typep i1 c3)) 8) ((not (typep i1 class3)) 9) ((typep i2 c1) 10) ((typep i2 class1) 11) ((typep i3 c1) 12) ((typep i3 class1) 13) ((not (typep i2 c2)) 14) ((not (typep i2 class2)) 15) ((not (typep i3 c3)) 16) ((not (typep i3 class3)) 17) ((not (typep i2 c3)) 18) ((not (typep i2 class3)) 19) ((typep i3 c2) 20) ((typep i3 class2) 21) (t 'good)))))))))) good) (deftest defclass.forward-ref.4 (block nil (let ((c1 (gensym)) (c2 (gensym)) (c3 (gensym)) (c4 (gensym)) (c5 (gensym))) (unless (typep (eval `(defclass ,c4 nil nil)) 'class) (return 1)) (unless (typep (eval `(defclass ,c5 nil nil)) 'class) (return 2)) (unless (typep (eval `(defclass ,c1 (,c2 ,c3) nil)) 'class) (return 3)) (unless (typep (eval `(defclass ,c2 (,c4 ,c5) nil)) 'class) (return 4)) (handler-case (eval `(progn (defclass ,c3 (,c5 ,c4) nil) (make-instance ',c1))) (error () :good)))) :good) gcl27-2.7.0/ansi-tests/defclass.lsp000066400000000000000000000006641454061450500170460ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Mar 24 03:39:54 2003 ;;;; Contains: Tests of DEFCLASS (in-package :cl-test) (defclass-with-tests defclass-1 nil nil) (defclass-with-tests defclass-2 nil (slot1 slot2 slot3)) (defclass-with-tests defclass-3 (defclass-1) nil) (defclass-with-tests defclass-4 (defclass-1 defclass-2) (slot1 slot4)) ;;; At end, generate slot tests (generate-slot-tests) ;; a macro gcl27-2.7.0/ansi-tests/defconstant.lsp000066400000000000000000000027631454061450500175740ustar00rootroot00000000000000;-*- 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 ;;; (signals-error (defconstant) program-error) ;;; t) ;;; ;;; (deftest defconstant.error.2 ;;; (signals-error (defconstant +ignorable-constant-name+) program-error) ;;; t) ;;; ;;; (deftest defconstant.error.3 ;;; (signals-error (defconstant +ignorable-constant-name2+ nil ;;; "This is a docstring" ;;; "This is an unnecessary extra argument.") ;;; program-error) ;;; t) (deftest defconstant.error.1 (signals-error (funcall (macro-function 'defconstant)) program-error) t) (deftest defconstant.error.2 (signals-error (funcall (macro-function 'defconstant) '(defconstant +nonexistent-constant+ 0)) program-error) t) (deftest defconstant.error.3 (signals-error (funcall (macro-function 'defconstant) '(defconstant +nonexistent-constant+ 0) nil nil) program-error) t) gcl27-2.7.0/ansi-tests/defgeneric-method-combination-and.lsp000066400000000000000000000134021454061450500236650ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 24 21:31:55 2003 ;;;; Contains: Tests of DEFGENERIC with :method-combination AND (in-package :cl-test) (declaim (special *x*)) (compile-and-load "defgeneric-method-combination-aux.lsp") (deftest defgeneric-method-combination.and.1 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.and.1 (x) (:method-combination and) (:method and ((x integer)) (push 4 *x*) t) (:method and ((x rational)) (push 3 *x*) nil) (:method and ((x number)) (push 2 *x*) t) (:method and ((x t)) (push 1 *x*) 'a))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (nil (3 4)) (nil (3)) (a (1 2)) (a (1))) (deftest defgeneric-method-combination.and.2 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.and.2 (x) (:method-combination and :most-specific-first) (:method and ((x integer)) (push 4 *x*) t) (:method and ((x rational)) (push 3 *x*) nil) (:method and ((x number)) (push 2 *x*) t) (:method and ((x t)) (push 1 *x*) 'a))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (nil (3 4)) (nil (3)) (a (1 2)) (a (1))) (deftest defgeneric-method-combination.and.3 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.and.3 (x) (:method-combination and :most-specific-last) (:method and ((x integer)) (push 4 *x*) t) (:method and ((x rational)) (push 3 *x*) nil) (:method and ((x number)) (push 2 *x*) 'a) (:method and ((x t)) (push 1 *x*) t))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (nil (3 2 1)) (nil (3 2 1)) (a (2 1)) (t (1))) (deftest defgeneric-method-combination.and.4 (let ((fn (eval '(defgeneric dg-mc.and.4 (x) (:method-combination and) (:method and ((x integer)) t) (:method :around ((x rational)) 'foo) (:method and ((x number)) nil) (:method and ((x symbol)) t) (:method and ((x t)) 'a))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) foo foo nil a a) (deftest defgeneric-method-combination.and.5 (let ((fn (eval '(defgeneric dg-mc.and.5 (x) (:method-combination and) (:method and ((x integer)) nil) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method and ((x number)) 'a) (:method and ((x symbol)) 'b) (:method and ((x t)) 'c))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) (foo nil) (foo c) c c c) (deftest defgeneric-method-combination.and.6 (let ((fn (eval '(defgeneric dg-mc.and.6 (x) (:method-combination and) (:method and ((x integer)) 'a) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method :around ((x real)) (list 'bar (call-next-method))) (:method and ((x number)) nil) (:method and ((x symbol)) 'c) (:method and ((x t)) 'd))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn #c(1.0 2.0)) (funcall fn 'x) (funcall fn '(a b c)))) (foo (bar nil)) (foo (bar nil)) (bar nil) nil d d) (deftest defgeneric-method-combination.and.7 (let ((fn (eval '(defgeneric dg-mc.and.7 (x) (:method-combination and) (:method and ((x dgmc-class-04)) 'c) (:method and ((x dgmc-class-03)) 'b) (:method and ((x dgmc-class-02)) nil) (:method and ((x dgmc-class-01)) 'a))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) (funcall fn (make-instance 'dgmc-class-02)) (funcall fn (make-instance 'dgmc-class-03)) (funcall fn (make-instance 'dgmc-class-04)))) a nil a nil) (deftest defgeneric-method-combination.and.8 (let ((fn (eval '(defgeneric dg-mc.and.8 (x) (:method-combination and) (:method and ((x (eql 1000))) 'a) (:method :around ((x symbol)) (values)) (:method :around ((x integer)) (values 'a 'b 'c)) (:method :around ((x complex)) (call-next-method)) (:method :around ((x number)) (values 1 2 3 4 5 6)) (:method and ((x t)) 'b))))) (declare (type generic-function fn)) (values (multiple-value-list (funcall fn 'a)) (multiple-value-list (funcall fn 10)) (multiple-value-list (funcall fn #c(9 8))) (multiple-value-list (funcall fn '(a b c))))) () (a b c) (1 2 3 4 5 6) (b)) (deftest defgeneric-method-combination.and.9 (handler-case (let ((fn (eval '(defgeneric dg-mc.and.9 (x) (:method-combination and))))) (declare (type generic-function fn)) (funcall fn 'x)) (error () :error)) :error) (deftest defgeneric-method-combination.and.10 (progn (eval '(defgeneric dg-mc.and.10 (x) (:method-combination and) (:method ((x t)) t))) (handler-case (dg-mc.and.10 'a) (error () :error))) :error) (deftest defgeneric-method-combination.and.11 (progn (eval '(defgeneric dg-mc.and.11 (x) (:method-combination and) (:method nonsense ((x t)) t))) (handler-case (dg-mc.and.11 0) (error () :error))) :error) (deftest defgeneric-method-combination.and.12 (let ((fn (eval '(defgeneric dg-mc.and.12 (x) (:method-combination and) (:method :around ((x t)) t) (:method and ((x integer)) x))))) (declare (type generic-function fn)) (handler-case (funcall fn 'x) (error () :error))) :error) gcl27-2.7.0/ansi-tests/defgeneric-method-combination-append.lsp000066400000000000000000000160741454061450500244020ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 24 21:31:55 2003 ;;;; Contains: Tests of DEFGENERIC with :method-combination APPEND (in-package :cl-test) (declaim (special *x*)) (compile-and-load "defgeneric-method-combination-aux.lsp") (deftest defgeneric-method-combination.append.1 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.append.1 (x) (:method-combination append) (:method append ((x integer)) (car (push '(d) *x*))) (:method append ((x rational)) (car (push '(c) *x*))) (:method append ((x number)) (car (push '(b) *x*))) (:method append ((x t)) (car (push '(a) *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) ((d c b a) ((a) (b) (c) (d))) ((c b a) ((a) (b) (c))) ((b a) ((a) (b))) ((a) ((a)))) (deftest defgeneric-method-combination.append.2 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.append.2 (x) (:method-combination append :most-specific-first) (:method append ((x integer)) (car (push '(d) *x*))) (:method append ((x rational)) (car (push '(c) *x*))) (:method append ((x number)) (car (push '(b) *x*))) (:method append ((x t)) (car (push '(a) *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) ((d c b a) ((a) (b) (c) (d))) ((c b a) ((a) (b) (c))) ((b a) ((a) (b))) ((a) ((a)))) (deftest defgeneric-method-combination.append.3 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.append.3 (x) (:method-combination append :most-specific-last) (:method append ((x integer)) (car (push '(d) *x*))) (:method append ((x rational)) (car (push '(c) *x*))) (:method append ((x number)) (car (push '(b) *x*))) (:method append ((x t)) (car (push '(a) *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) ((a b c d) ((d) (c) (b) (a))) ((a b c) ((c) (b) (a))) ((a b) ((b) (a))) ((a) ((a)))) (deftest defgeneric-method-combination.append.4 (let ((fn (eval '(defgeneric dg-mc.fun.append.4 (x) (:method-combination append) (:method append ((x integer)) '(a b)) (:method :around ((x rational)) 'foo) (:method append ((x number)) '(c d)) (:method append ((x symbol)) '(e f)) (:method append ((x t)) '(g h)))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) foo foo (c d g h) (e f g h) (g h)) (deftest defgeneric-method-combination.append.5 (let ((fn (eval '(defgeneric dg-mc.fun.append.5 (x) (:method-combination append) (:method append ((x integer)) '(a)) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method append ((x number)) '(b)) (:method append ((x symbol)) '(c)) (:method append ((x t)) 'd))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) (foo (a b . d)) (foo (b . d)) (b . d) (c . d) d) (deftest defgeneric-method-combination.append.6 (let ((fn (eval '(defgeneric dg-mc.fun.append.6 (x) (:method-combination append) (:method append ((x integer)) '(a)) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method :around ((x real)) (list 'bar (call-next-method))) (:method append ((x number)) '(b)) (:method append ((x symbol)) '(c)) (:method append ((x t)) '(d)))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn #c(1.0 2.0)) (funcall fn 'x) (funcall fn '(a b c)))) (foo (bar (a b d))) (foo (bar (b d))) (bar (b d)) (b d) (c d) (d)) (deftest defgeneric-method-combination.append.7 (let ((fn (eval '(defgeneric dg-mc.fun.append.7 (x) (:method-combination append) (:method append ((x dgmc-class-04)) '(a)) (:method append ((x dgmc-class-03)) '(b)) (:method append ((x dgmc-class-02)) '(c)) (:method append ((x dgmc-class-01)) '(d)))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) (funcall fn (make-instance 'dgmc-class-02)) (funcall fn (make-instance 'dgmc-class-03)) (funcall fn (make-instance 'dgmc-class-04)))) (d) (c d) (b d) (a c b d)) (deftest defgeneric-method-combination.append.8 (let ((fn (eval '(defgeneric dg-mc.append.8 (x) (:method-combination append) (:method append ((x (eql 1000))) '(a)) (:method :around ((x symbol)) (values)) (:method :around ((x integer)) (values 'a 'b 'c)) (:method :around ((x complex)) (call-next-method)) (:method :around ((x number)) (values 1 2 3 4 5 6)) (:method append ((x t)) '(b)))))) (declare (type generic-function fn)) (values (multiple-value-list (funcall fn 'a)) (multiple-value-list (funcall fn 10)) (multiple-value-list (funcall fn #c(9 8))) (multiple-value-list (funcall fn '(a b c))))) () (a b c) (1 2 3 4 5 6) ((b))) (deftest defgeneric-method-combination.append.9 (handler-case (let ((fn (eval '(defgeneric dg-mc.append.9 (x) (:method-combination append))))) (declare (type generic-function fn)) (funcall fn '(a))) (error () :error)) :error) (deftest defgeneric-method-combination.append.10 (progn (eval '(defgeneric dg-mc.append.10 (x) (:method-combination append) (:method ((x t)) '(a)))) (handler-case (dg-mc.append.10 'x) (error () :error))) :error) (deftest defgeneric-method-combination.append.11 (progn (eval '(defgeneric dg-mc.append.11 (x) (:method-combination append) (:method nonsense ((x t)) '(a)))) (handler-case (dg-mc.append.11 0) (error () :error))) :error) (deftest defgeneric-method-combination.append.12 (let ((fn (eval '(defgeneric dg-mc.append.12 (x) (:method-combination append) (:method :around ((x t)) '(a)) (:method append ((x integer)) x))))) (declare (type generic-function fn)) (handler-case (funcall fn '(b)) (error () :error))) :error) (deftest defgeneric-method-combination.append.13 (progn (eval '(defgeneric dg-mc.append.13 (x) (:method-combination append) (:method append ((x dgmc-class-01)) (list 'foo)) (:method append ((x dgmc-class-02)) (list 'bar)) (:method nonsense ((x dgmc-class-03)) (list 'bad)))) (values (dg-mc.append.13 (make-instance 'dgmc-class-01)) (dg-mc.append.13 (make-instance 'dgmc-class-02)) (handler-case (dg-mc.append.13 (make-instance 'dgmc-class-03)) (error () :caught)) (handler-case (dg-mc.append.13 (make-instance 'dgmc-class-04)) (error () :caught)) (handler-case (dg-mc.append.13 (make-instance 'dgmc-class-07)) (error () :caught)))) (foo) (bar foo) :caught :caught :caught) gcl27-2.7.0/ansi-tests/defgeneric-method-combination-aux.lsp000066400000000000000000000007761454061450500237320ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed May 28 14:02:42 2003 ;;;; Contains: Class definitions for defgeneric-method-combination-*.lsp (in-package :cl-test) (defclass dgmc-class-01 () ()) (defclass dgmc-class-02 (dgmc-class-01) ()) (defclass dgmc-class-03 (dgmc-class-01) ()) (defclass dgmc-class-04 (dgmc-class-02 dgmc-class-03) ()) (defclass dgmc-class-05 (dgmc-class-04) ()) (defclass dgmc-class-06 (dgmc-class-04) ()) (defclass dgmc-class-07 (dgmc-class-05 dgmc-class-06) ()) gcl27-2.7.0/ansi-tests/defgeneric-method-combination-list.lsp000066400000000000000000000141151454061450500241000ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 24 21:31:55 2003 ;;;; Contains: Tests of DEFGENERIC with :method-combination LIST (in-package :cl-test) (declaim (special *x*)) (compile-and-load "defgeneric-method-combination-aux.lsp") (deftest defgeneric-method-combination.list.1 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.list.1 (x) (:method-combination list) (:method list ((x integer)) (car (push 'd *x*))) (:method list ((x rational)) (car (push 'c *x*))) (:method list ((x number)) (car (push 'b *x*))) (:method list ((x t)) (car (push 'a *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) ((d c b a) (a b c d)) ((c b a) (a b c)) ((b a) (a b)) ((a) (a))) (deftest defgeneric-method-combination.list.2 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.list.2 (x) (:method-combination list :most-specific-first) (:method list ((x integer)) (car (push 'd *x*))) (:method list ((x rational)) (car (push 'c *x*))) (:method list ((x number)) (car (push 'b *x*))) (:method list ((x t)) (car (push 'a *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) ((d c b a) (a b c d)) ((c b a) (a b c)) ((b a) (a b)) ((a) (a))) (deftest defgeneric-method-combination.list.3 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.list.3 (x) (:method-combination list :most-specific-last) (:method list ((x integer)) (car (push 'd *x*))) (:method list ((x rational)) (car (push 'c *x*))) (:method list ((x number)) (car (push 'b *x*))) (:method list ((x t)) (car (push 'a *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) ((a b c d) (d c b a)) ((a b c) (c b a)) ((a b) (b a)) ((a) (a))) (deftest defgeneric-method-combination.list.4 (let ((fn (eval '(defgeneric dg-mc.fun.list.4 (x) (:method-combination list) (:method list ((x integer)) '(a b)) (:method :around ((x rational)) 'foo) (:method list ((x number)) '(c d)) (:method list ((x symbol)) '(e f)) (:method list ((x t)) '(g h)))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) foo foo ((c d) (g h)) ((e f) (g h)) ((g h))) (deftest defgeneric-method-combination.list.5 (let ((fn (eval '(defgeneric dg-mc.fun.list.5 (x) (:method-combination list) (:method list ((x integer)) 'a) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method list ((x number)) 'b) (:method list ((x symbol)) 'c) (:method list ((x t)) 'd))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) (foo (a b d)) (foo (b d)) (b d) (c d) (d)) (deftest defgeneric-method-combination.list.6 (let ((fn (eval '(defgeneric dg-mc.fun.list.6 (x) (:method-combination list) (:method list ((x integer)) 'a) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method :around ((x real)) (list 'bar (call-next-method))) (:method list ((x number)) 'b) (:method list ((x symbol)) 'c) (:method list ((x t)) 'd))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn #c(1.0 2.0)) (funcall fn 'x) (funcall fn '(a b c)))) (foo (bar (a b d))) (foo (bar (b d))) (bar (b d)) (b d) (c d) (d)) (deftest defgeneric-method-combination.list.7 (let ((fn (eval '(defgeneric dg-mc.fun.list.7 (x) (:method-combination list) (:method list ((x dgmc-class-04)) 'a) (:method list ((x dgmc-class-03)) 'b) (:method list ((x dgmc-class-02)) 'c) (:method list ((x dgmc-class-01)) 'd))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) (funcall fn (make-instance 'dgmc-class-02)) (funcall fn (make-instance 'dgmc-class-03)) (funcall fn (make-instance 'dgmc-class-04)))) (d) (c d) (b d) (a c b d)) (deftest defgeneric-method-combination.list.8 (let ((fn (eval '(defgeneric dg-mc.list.8 (x) (:method-combination list) (:method list ((x (eql 1000))) 'a) (:method :around ((x symbol)) (values)) (:method :around ((x integer)) (values 'a 'b 'c)) (:method :around ((x complex)) (call-next-method)) (:method :around ((x number)) (values 1 2 3 4 5 6)) (:method list ((x t)) 'b))))) (declare (type generic-function fn)) (values (multiple-value-list (funcall fn 'a)) (multiple-value-list (funcall fn 10)) (multiple-value-list (funcall fn #c(9 8))) (multiple-value-list (funcall fn '(a b c))))) () (a b c) (1 2 3 4 5 6) ((b))) (deftest defgeneric-method-combination.list.9 (handler-case (let ((fn (eval '(defgeneric dg-mc.list.9 (x) (:method-combination list))))) (declare (type generic-function fn)) (funcall fn (list 'a))) (error () :error)) :error) (deftest defgeneric-method-combination.list.10 (progn (eval '(defgeneric dg-mc.list.10 (x) (:method-combination list) (:method ((x t)) (list 'a)))) (handler-case (dg-mc.list.10 'a) (error () :error))) :error) (deftest defgeneric-method-combination.list.11 (progn (eval '(defgeneric dg-mc.list.11 (x) (:method-combination list) (:method nonsense ((x t)) (list 'a)))) (handler-case (dg-mc.list.11 0) (error () :error))) :error) (deftest defgeneric-method-combination.list.12 (let ((fn (eval '(defgeneric dg-mc.list.12 (x) (:method-combination list) (:method :around ((x t)) (list 'a)) (:method list ((x integer)) x))))) (declare (type generic-function fn)) (handler-case (funcall fn (list 'b)) (error () :error))) :error) gcl27-2.7.0/ansi-tests/defgeneric-method-combination-max.lsp000066400000000000000000000134021454061450500237100ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 24 21:31:55 2003 ;;;; Contains: Tests of DEFGENERIC with :method-combination MAX (in-package :cl-test) (declaim (special *x*)) (compile-and-load "defgeneric-method-combination-aux.lsp") (deftest defgeneric-method-combination.max.1 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.max.1 (x) (:method-combination max) (:method max ((x integer)) (car (push 8 *x*))) (:method max ((x rational)) (car (push 4 *x*))) (:method max ((x number)) (car (push 2 *x*))) (:method max ((x t)) (car (push 1 *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (8 (1 2 4 8)) (4 (1 2 4)) (2 (1 2)) (1 (1))) (deftest defgeneric-method-combination.max.2 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.max.2 (x) (:method-combination max :most-specific-first) (:method max ((x integer)) (car (push 8 *x*))) (:method max ((x rational)) (car (push 4 *x*))) (:method max ((x number)) (car (push 2 *x*))) (:method max ((x t)) (car (push 1 *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (8 (1 2 4 8)) (4 (1 2 4)) (2 (1 2)) (1 (1))) (deftest defgeneric-method-combination.max.3 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.max.3 (x) (:method-combination max :most-specific-last) (:method max ((x integer)) (car (push 8 *x*))) (:method max ((x rational)) (car (push 4 *x*))) (:method max ((x number)) (car (push 2 *x*))) (:method max ((x t)) (car (push 1 *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (8 (8 4 2 1)) (4 (4 2 1)) (2 (2 1)) (1 (1))) (deftest defgeneric-method-combination.max.4 (let ((fn (eval '(defgeneric dg-mc.max.4 (x) (:method-combination max) (:method max ((x integer)) 4) (:method :around ((x rational)) 'foo) (:method max ((x number)) 3) (:method max ((x symbol)) 5) (:method max ((x t)) 1))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) foo foo 3 5 1) (deftest defgeneric-method-combination.max.5 (let ((fn (eval '(defgeneric dg-mc.max.5 (x) (:method-combination max) (:method max ((x integer)) 5) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method max ((x number)) 5/2) (:method max ((x symbol)) 4) (:method max ((x t)) 1.0))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) (foo 5) (foo 5/2) 5/2 4 1.0) (deftest defgeneric-method-combination.max.6 (let ((fn (eval '(defgeneric dg-mc.max.6 (x) (:method-combination max) (:method max ((x integer)) 9) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method :around ((x real)) (list 'bar (call-next-method))) (:method max ((x number)) 4) (:method max ((x symbol)) 6) (:method max ((x t)) 1))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn #c(1.0 2.0)) (funcall fn 'x) (funcall fn '(a b c)))) (foo (bar 9)) (foo (bar 4)) (bar 4) 4 6 1) (deftest defgeneric-method-combination.max.7 (let ((fn (eval '(defgeneric dg-mc.max.7 (x) (:method-combination max) (:method max ((x dgmc-class-04)) 4) (:method max ((x dgmc-class-03)) 3) (:method max ((x dgmc-class-02)) 5) (:method max ((x dgmc-class-01)) 1))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) (funcall fn (make-instance 'dgmc-class-02)) (funcall fn (make-instance 'dgmc-class-03)) (funcall fn (make-instance 'dgmc-class-04)))) 1 5 3 5) (deftest defgeneric-method-combination.max.8 (let ((fn (eval '(defgeneric dg-mc.max.8 (x) (:method-combination max) (:method max ((x (eql 1000))) 4) (:method :around ((x symbol)) (values)) (:method :around ((x integer)) (values 'a 'b 'c)) (:method :around ((x complex)) (call-next-method)) (:method :around ((x number)) (values 1 2 3 4 5 6)) (:method max ((x t)) 1))))) (declare (type generic-function fn)) (values (multiple-value-list (funcall fn 'a)) (multiple-value-list (funcall fn 10)) (multiple-value-list (funcall fn #c(9 8))) (multiple-value-list (funcall fn '(a b c))))) () (a b c) (1 2 3 4 5 6) (1)) (deftest defgeneric-method-combination.max.9 (handler-case (let ((fn (eval '(defgeneric dg-mc.max.9 (x) (:method-combination max))))) (declare (type generic-function fn)) (funcall fn (list 'a))) (error () :error)) :error) (deftest defgeneric-method-combination.max.10 (progn (eval '(defgeneric dg-mc.max.10 (x) (:method-combination max) (:method ((x t)) 0))) (handler-case (dg-mc.max.10 'a) (error () :error))) :error) (deftest defgeneric-method-combination.max.11 (progn (eval '(defgeneric dg-mc.max.11 (x) (:method-combination max) (:method nonsense ((x t)) 0))) (handler-case (dg-mc.max.11 0) (error () :error))) :error) (deftest defgeneric-method-combination.max.12 (let ((fn (eval '(defgeneric dg-mc.max.12 (x) (:method-combination max) (:method :around ((x t)) 1) (:method max ((x integer)) x))))) (declare (type generic-function fn)) (handler-case (funcall fn 'a) (error () :error))) :error) gcl27-2.7.0/ansi-tests/defgeneric-method-combination-min.lsp000066400000000000000000000133711454061450500237130ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 24 21:31:55 2003 ;;;; Contains: Tests of DEFGENERIC with :method-combination MIN (in-package :cl-test) (declaim (special *x*)) (compile-and-load "defgeneric-method-combination-aux.lsp") (deftest defgeneric-method-combination.min.1 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.min.1 (x) (:method-combination min) (:method min ((x integer)) (car (push 1 *x*))) (:method min ((x rational)) (car (push 2 *x*))) (:method min ((x number)) (car (push 3 *x*))) (:method min ((x t)) (car (push 4 *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (1 (4 3 2 1)) (2 (4 3 2)) (3 (4 3)) (4 (4))) (deftest defgeneric-method-combination.min.2 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.min.2 (x) (:method-combination min :most-specific-first) (:method min ((x integer)) (car (push 1 *x*))) (:method min ((x rational)) (car (push 2 *x*))) (:method min ((x number)) (car (push 3 *x*))) (:method min ((x t)) (car (push 4 *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (1 (4 3 2 1)) (2 (4 3 2)) (3 (4 3)) (4 (4))) (deftest defgeneric-method-combination.min.3 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.min.3 (x) (:method-combination min :most-specific-last) (:method min ((x integer)) (car (push 1 *x*))) (:method min ((x rational)) (car (push 2 *x*))) (:method min ((x number)) (car (push 3 *x*))) (:method min ((x t)) (car (push 4 *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (1 (1 2 3 4)) (2 (2 3 4)) (3 (3 4)) (4 (4))) (deftest defgeneric-method-combination.min.4 (let ((fn (eval '(defgeneric dg-mc.min.4 (x) (:method-combination min) (:method min ((x integer)) 1) (:method :around ((x rational)) 'foo) (:method min ((x number)) 2) (:method min ((x symbol)) 3) (:method min ((x t)) 4))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) foo foo 2 3 4) (deftest defgeneric-method-combination.min.5 (let ((fn (eval '(defgeneric dg-mc.min.5 (x) (:method-combination min) (:method min ((x integer)) 1) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method min ((x number)) 2) (:method min ((x symbol)) 4) (:method min ((x t)) 8))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) (foo 1) (foo 2) 2 4 8) (deftest defgeneric-method-combination.min.6 (let ((fn (eval '(defgeneric dg-mc.min.6 (x) (:method-combination min) (:method min ((x integer)) 1) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method :around ((x real)) (list 'bar (call-next-method))) (:method min ((x number)) 2) (:method min ((x symbol)) 4) (:method min ((x t)) 8))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn #c(1.0 2.0)) (funcall fn 'x) (funcall fn '(a b c)))) (foo (bar 1)) (foo (bar 2)) (bar 2) 2 4 8) (deftest defgeneric-method-combination.min.7 (let ((fn (eval '(defgeneric dg-mc.min.7 (x) (:method-combination min) (:method min ((x dgmc-class-04)) 1) (:method min ((x dgmc-class-03)) 2) (:method min ((x dgmc-class-02)) 4) (:method min ((x dgmc-class-01)) 8))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) (funcall fn (make-instance 'dgmc-class-02)) (funcall fn (make-instance 'dgmc-class-03)) (funcall fn (make-instance 'dgmc-class-04)))) 8 4 2 1) (deftest defgeneric-method-combination.min.8 (let ((fn (eval '(defgeneric dg-mc.min.8 (x) (:method-combination min) (:method min ((x (eql 1000))) 0) (:method :around ((x symbol)) (values)) (:method :around ((x integer)) (values 'a 'b 'c)) (:method :around ((x complex)) (call-next-method)) (:method :around ((x number)) (values 1 2 3 4 5 6)) (:method min ((x t)) 1))))) (declare (type generic-function fn)) (values (multiple-value-list (funcall fn 'a)) (multiple-value-list (funcall fn 10)) (multiple-value-list (funcall fn #c(9 8))) (multiple-value-list (funcall fn '(a b c))))) () (a b c) (1 2 3 4 5 6) (1)) (deftest defgeneric-method-combination.min.9 (handler-case (let ((fn (eval '(defgeneric dg-mc.min.9 (x) (:method-combination min))))) (declare (type generic-function fn)) (funcall fn (list 'a))) (error () :error)) :error) (deftest defgeneric-method-combination.min.10 (progn (eval '(defgeneric dg-mc.min.10 (x) (:method-combination min) (:method ((x t)) 0))) (handler-case (dg-mc.min.10 'a) (error () :error))) :error) (deftest defgeneric-method-combination.min.11 (progn (eval '(defgeneric dg-mc.min.11 (x) (:method-combination min) (:method nonsense ((x t)) 0))) (handler-case (dg-mc.min.11 0) (error () :error))) :error) (deftest defgeneric-method-combination.min.12 (let ((fn (eval '(defgeneric dg-mc.min.12 (x) (:method-combination min) (:method :around ((x t)) 1) (:method min ((x integer)) x))))) (declare (type generic-function fn)) (handler-case (funcall fn 'a) (error () :error))) :error) gcl27-2.7.0/ansi-tests/defgeneric-method-combination-nconc.lsp000066400000000000000000000151041454061450500242240ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 24 21:31:55 2003 ;;;; Contains: Tests of DEFGENERIC with :method-combination NCONC (in-package :cl-test) (declaim (special *x*)) (compile-and-load "defgeneric-method-combination-aux.lsp") (deftest defgeneric-method-combination.nconc.1 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.nconc.1 (x) (:method-combination nconc) (:method nconc ((x integer)) (copy-list (car (push '(d) *x*)))) (:method nconc ((x rational)) (copy-list (car (push '(c) *x*)))) (:method nconc ((x number)) (copy-list (car (push '(b) *x*)))) (:method nconc ((x t)) (copy-list (car (push '(a) *x*)))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) ((d c b a) ((a) (b) (c) (d))) ((c b a) ((a) (b) (c))) ((b a) ((a) (b))) ((a) ((a)))) (deftest defgeneric-method-combination.nconc.2 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.nconc.2 (x) (:method-combination nconc :most-specific-first) (:method nconc ((x integer)) (copy-list (car (push '(d) *x*)))) (:method nconc ((x rational)) (copy-list (car (push '(c) *x*)))) (:method nconc ((x number)) (copy-list (car (push '(b) *x*)))) (:method nconc ((x t)) (copy-list (car (push '(a) *x*)))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) ((d c b a) ((a) (b) (c) (d))) ((c b a) ((a) (b) (c))) ((b a) ((a) (b))) ((a) ((a)))) (deftest defgeneric-method-combination.nconc.3 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.nconc.3 (x) (:method-combination nconc :most-specific-last) (:method nconc ((x integer)) (copy-list (car (push '(d) *x*)))) (:method nconc ((x rational)) (copy-list (car (push '(c) *x*)))) (:method nconc ((x number)) (copy-list (car (push '(b) *x*)))) (:method nconc ((x t)) (copy-list (car (push '(a) *x*)))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) ((a b c d) ((d) (c) (b) (a))) ((a b c) ((c) (b) (a))) ((a b) ((b) (a))) ((a) ((a)))) (deftest defgeneric-method-combination.nconc.4 (let ((fn (eval '(defgeneric dg-mc.fun.nconc.4 (x) (:method-combination nconc) (:method nconc ((x integer)) (list 'a 'b)) (:method :around ((x rational)) 'foo) (:method nconc ((x number)) (list 'c 'd)) (:method nconc ((x symbol)) (list 'e 'f)) (:method nconc ((x t)) (list 'g 'h)))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) foo foo (c d g h) (e f g h) (g h)) (deftest defgeneric-method-combination.nconc.5 (let ((fn (eval '(defgeneric dg-mc.fun.nconc.5 (x) (:method-combination nconc) (:method nconc ((x integer)) (list 'a)) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method nconc ((x number)) (list 'b)) (:method nconc ((x symbol)) (list 'c)) (:method nconc ((x t)) (cons 'd 'e)))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) (foo (a b d . e)) (foo (b d . e)) (b d . e) (c d . e) (d . e)) (deftest defgeneric-method-combination.nconc.6 (let ((fn (eval '(defgeneric dg-mc.fun.nconc.6 (x) (:method-combination nconc) (:method nconc ((x integer)) (list 'a)) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method :around ((x real)) (list 'bar (call-next-method))) (:method nconc ((x number)) (list 'b)) (:method nconc ((x symbol)) (list 'c)) (:method nconc ((x t)) (list 'd)))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn #c(1.0 2.0)) (funcall fn 'x) (funcall fn '(a b c)))) (foo (bar (a b d))) (foo (bar (b d))) (bar (b d)) (b d) (c d) (d)) (deftest defgeneric-method-combination.nconc.7 (let ((fn (eval '(defgeneric dg-mc.fun.nconc.7 (x) (:method-combination nconc) (:method nconc ((x dgmc-class-04)) (list 'a)) (:method nconc ((x dgmc-class-03)) (list 'b)) (:method nconc ((x dgmc-class-02)) (list 'c)) (:method nconc ((x dgmc-class-01)) (list 'd)))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) (funcall fn (make-instance 'dgmc-class-02)) (funcall fn (make-instance 'dgmc-class-03)) (funcall fn (make-instance 'dgmc-class-04)))) (d) (c d) (b d) (a c b d)) (deftest defgeneric-method-combination.nconc.8 (let ((fn (eval '(defgeneric dg-mc.nconc.8 (x) (:method-combination nconc) (:method nconc ((x (eql 1000))) (list 'a)) (:method :around ((x symbol)) (values)) (:method :around ((x integer)) (values 'a 'b 'c)) (:method :around ((x complex)) (call-next-method)) (:method :around ((x number)) (values 1 2 3 4 5 6)) (:method nconc ((x t)) (list 'b)))))) (declare (type generic-function fn)) (values (multiple-value-list (funcall fn 'a)) (multiple-value-list (funcall fn 10)) (multiple-value-list (funcall fn #c(9 8))) (multiple-value-list (funcall fn '(a b c))))) () (a b c) (1 2 3 4 5 6) ((b))) (deftest defgeneric-method-combination.nconc.9 (handler-case (let ((fn (eval '(defgeneric dg-mc.nconc.9 (x) (:method-combination nconc))))) (declare (type generic-function fn)) (funcall fn (list 'a))) (error () :error)) :error) (deftest defgeneric-method-combination.nconc.10 (progn (eval '(defgeneric dg-mc.nconc.10 (x) (:method-combination nconc) (:method ((x t)) (list 'a)))) (handler-case (dg-mc.nconc.10 'a) (error () :error))) :error) (deftest defgeneric-method-combination.nconc.11 (progn (eval '(defgeneric dg-mc.nconc.11 (x) (:method-combination nconc) (:method nonsense ((x t)) (list 'a)))) (handler-case (dg-mc.nconc.11 0) (error () :error))) :error) (deftest defgeneric-method-combination.nconc.12 (let ((fn (eval '(defgeneric dg-mc.nconc.12 (x) (:method-combination nconc) (:method :around ((x t)) (list 'a)) (:method nconc ((x integer)) x))))) (declare (type generic-function fn)) (handler-case (funcall fn (list 'b)) (error () :error))) :error) gcl27-2.7.0/ansi-tests/defgeneric-method-combination-or.lsp000066400000000000000000000132631454061450500235500ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 24 21:31:55 2003 ;;;; Contains: Tests of DEFGENERIC with :method-combination OR (in-package :cl-test) (declaim (special *x*)) (compile-and-load "defgeneric-method-combination-aux.lsp") (deftest defgeneric-method-combination.or.1 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.or.1 (x) (:method-combination or) (:method or ((x integer)) (push 4 *x*) nil) (:method or ((x rational)) (push 3 *x*) nil) (:method or ((x number)) (push 2 *x*) nil) (:method or ((x t)) (push 1 *x*) 'a))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (a (1 2 3 4)) (a (1 2 3)) (a (1 2)) (a (1))) (deftest defgeneric-method-combination.or.2 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.or.2 (x) (:method-combination or :most-specific-first) (:method or ((x integer)) (push 4 *x*) nil) (:method or ((x rational)) (push 3 *x*) 'a) (:method or ((x number)) (push 2 *x*) nil) (:method or ((x t)) (push 1 *x*) 'b))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (a (3 4)) (a (3)) (b (1 2)) (b (1))) (deftest defgeneric-method-combination.or.3 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.or.3 (x) (:method-combination or :most-specific-last) (:method or ((x integer)) (push 4 *x*) 'a) (:method or ((x rational)) (push 3 *x*) nil) (:method or ((x number)) (push 2 *x*) nil) (:method or ((x t)) (push 1 *x*) nil))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (a (4 3 2 1)) (nil (3 2 1)) (nil (2 1)) (nil (1))) (deftest defgeneric-method-combination.or.4 (let ((fn (eval '(defgeneric dg-mc.or.4 (x) (:method-combination or) (:method or ((x integer)) nil) (:method :around ((x rational)) 'foo) (:method or ((x number)) 'b) (:method or ((x symbol)) nil) (:method or ((x t)) 'a))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) foo foo b a a) (deftest defgeneric-method-combination.or.5 (let ((fn (eval '(defgeneric dg-mc.or.5 (x) (:method-combination or) (:method or ((x integer)) 'a) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method or ((x number)) nil) (:method or ((x symbol)) 'b) (:method or ((x t)) 'c))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) (foo a) (foo c) c b c) (deftest defgeneric-method-combination.or.6 (let ((fn (eval '(defgeneric dg-mc.or.6 (x) (:method-combination or) (:method or ((x integer)) 'a) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method :around ((x real)) (list 'bar (call-next-method))) (:method or ((x number)) 'b) (:method or ((x symbol)) 'c) (:method or ((x t)) 'd))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn #c(1.0 2.0)) (funcall fn 'x) (funcall fn '(a b c)))) (foo (bar a)) (foo (bar b)) (bar b) b c d) (deftest defgeneric-method-combination.or.7 (let ((fn (eval '(defgeneric dg-mc.or.7 (x) (:method-combination or) (:method or ((x dgmc-class-04)) nil) (:method or ((x dgmc-class-03)) nil) (:method or ((x dgmc-class-02)) 'b) (:method or ((x dgmc-class-01)) 'c))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) (funcall fn (make-instance 'dgmc-class-02)) (funcall fn (make-instance 'dgmc-class-03)) (funcall fn (make-instance 'dgmc-class-04)))) c b c b) (deftest defgeneric-method-combination.or.8 (let ((fn (eval '(defgeneric dg-mc.or.8 (x) (:method-combination or) (:method or ((x (eql 1000))) 'a) (:method :around ((x symbol)) (values)) (:method :around ((x integer)) (values 'a 'b 'c)) (:method :around ((x complex)) (call-next-method)) (:method :around ((x number)) (values 1 2 3 4 5 6)) (:method or ((x t)) 'b))))) (declare (type generic-function fn)) (values (multiple-value-list (funcall fn 'a)) (multiple-value-list (funcall fn 10)) (multiple-value-list (funcall fn #c(9 8))) (multiple-value-list (funcall fn '(a b c))))) () (a b c) (1 2 3 4 5 6) (b)) (deftest defgeneric-method-combination.or.9 (handler-case (let ((fn (eval '(defgeneric dg-mc.or.9 (x) (:method-combination or))))) (declare (type generic-function fn)) (funcall fn (list 'a))) (error () :error)) :error) (deftest defgeneric-method-combination.or.10 (progn (eval '(defgeneric dg-mc.or.10 (x) (:method-combination or) (:method ((x t)) 0))) (handler-case (dg-mc.or.10 'a) (error () :error))) :error) (deftest defgeneric-method-combination.or.11 (progn (eval '(defgeneric dg-mc.or.11 (x) (:method-combination or) (:method nonsense ((x t)) 0))) (handler-case (dg-mc.or.11 0) (error () :error))) :error) (deftest defgeneric-method-combination.or.12 (let ((fn (eval '(defgeneric dg-mc.or.12 (x) (:method-combination or) (:method :around ((x t)) t) (:method or ((x integer)) x))))) (declare (type generic-function fn)) (handler-case (funcall fn 'a) (error () :error))) :error) gcl27-2.7.0/ansi-tests/defgeneric-method-combination-plus.lsp000066400000000000000000000132241454061450500241100ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 24 21:31:55 2003 ;;;; Contains: Tests of DEFGENERIC with :method-combination + (in-package :cl-test) (declaim (special *x*)) (compile-and-load "defgeneric-method-combination-aux.lsp") (deftest defgeneric-method-combination.+.1 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.plus.1 (x) (:method-combination +) (:method + ((x integer)) (car (push 8 *x*))) (:method + ((x rational)) (car (push 4 *x*))) (:method + ((x number)) (car (push 2 *x*))) (:method + ((x t)) (car (push 1 *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (15 (1 2 4 8)) (7 (1 2 4)) (3 (1 2)) (1 (1))) (deftest defgeneric-method-combination.+.2 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.plus.2 (x) (:method-combination + :most-specific-first) (:method + ((x integer)) (car (push 8 *x*))) (:method + ((x rational)) (car (push 4 *x*))) (:method + ((x number)) (car (push 2 *x*))) (:method + ((x t)) (car (push 1 *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (15 (1 2 4 8)) (7 (1 2 4)) (3 (1 2)) (1 (1))) (deftest defgeneric-method-combination.+.3 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.plus.3 (x) (:method-combination + :most-specific-last) (:method + ((x integer)) (car (push 8 *x*))) (:method + ((x rational)) (car (push 4 *x*))) (:method + ((x number)) (car (push 2 *x*))) (:method + ((x t)) (car (push 1 *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (15 (8 4 2 1)) (7 (4 2 1)) (3 (2 1)) (1 (1))) (deftest defgeneric-method-combination.+.4 (let ((fn (eval '(defgeneric dg-mc.plus.4 (x) (:method-combination +) (:method + ((x integer)) 1) (:method :around ((x rational)) 'foo) (:method + ((x number)) 1) (:method + ((x symbol)) 2) (:method + ((x t)) 4))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) foo foo 5 6 4) (deftest defgeneric-method-combination.+.5 (let ((fn (eval '(defgeneric dg-mc.plus.5 (x) (:method-combination +) (:method + ((x integer)) 1) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method + ((x number)) 2) (:method + ((x symbol)) 4) (:method + ((x t)) 8))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) (foo 11) (foo 10) 10 12 8) (deftest defgeneric-method-combination.+.6 (let ((fn (eval '(defgeneric dg-mc.plus.6 (x) (:method-combination +) (:method + ((x integer)) 1) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method :around ((x real)) (list 'bar (call-next-method))) (:method + ((x number)) 2) (:method + ((x symbol)) 4) (:method + ((x t)) 8))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn #c(1.0 2.0)) (funcall fn 'x) (funcall fn '(a b c)))) (foo (bar 11)) (foo (bar 10)) (bar 10) 10 12 8) (deftest defgeneric-method-combination.+.7 (let ((fn (eval '(defgeneric dg-mc.plus.7 (x) (:method-combination +) (:method + ((x dgmc-class-04)) 1) (:method + ((x dgmc-class-03)) 2) (:method + ((x dgmc-class-02)) 4) (:method + ((x dgmc-class-01)) 8))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) (funcall fn (make-instance 'dgmc-class-02)) (funcall fn (make-instance 'dgmc-class-03)) (funcall fn (make-instance 'dgmc-class-04)))) 8 12 10 15) (deftest defgeneric-method-combination.+.8 (let ((fn (eval '(defgeneric dg-mc.plus.8 (x) (:method-combination +) (:method + ((x (eql 1000))) 1) (:method :around ((x symbol)) (values)) (:method :around ((x integer)) (values 'a 'b 'c)) (:method :around ((x complex)) (call-next-method)) (:method :around ((x number)) (values 1 2 3 4 5 6)) (:method + ((x t)) 1))))) (declare (type generic-function fn)) (values (multiple-value-list (funcall fn 'a)) (multiple-value-list (funcall fn 10)) (multiple-value-list (funcall fn #c(9 8))) (multiple-value-list (funcall fn '(a b c))))) () (a b c) (1 2 3 4 5 6) (1)) (deftest defgeneric-method-combination.+.9 (handler-case (let ((fn (eval '(defgeneric dg-mc.+.9 (x) (:method-combination +))))) (declare (type generic-function fn)) (funcall fn (list 'a))) (error () :error)) :error) (deftest defgeneric-method-combination.+.10 (progn (eval '(defgeneric dg-mc.+.10 (x) (:method-combination +) (:method ((x t)) 0))) (handler-case (dg-mc.+.10 'a) (error () :error))) :error) (deftest defgeneric-method-combination.+.11 (progn (eval '(defgeneric dg-mc.+.11 (x) (:method-combination +) (:method nonsense ((x t)) 0))) (handler-case (dg-mc.+.11 0) (error () :error))) :error) (deftest defgeneric-method-combination.+.12 (let ((fn (eval '(defgeneric dg-mc.+.12 (x) (:method-combination +) (:method :around ((x t)) 1) (:method + ((x integer)) x))))) (declare (type generic-function fn)) (handler-case (funcall fn 'a) (error () :error))) :error) gcl27-2.7.0/ansi-tests/defgeneric-method-combination-progn.lsp000066400000000000000000000203031454061450500242460ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 24 21:31:55 2003 ;;;; Contains: Tests of DEFGENERIC with :method-combination OR (in-package :cl-test) (declaim (special *x*)) (compile-and-load "defgeneric-method-combination-aux.lsp") (deftest defgeneric-method-combination.progn.1 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.progn.1 (x) (:method-combination progn) (:method progn ((x integer)) (push 4 *x*) nil) (:method progn ((x rational)) (push 3 *x*) nil) (:method progn ((x number)) (push 2 *x*) nil) (:method progn ((x t)) (push 1 *x*) 'a))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (a (1 2 3 4)) (a (1 2 3)) (a (1 2)) (a (1))) (deftest defgeneric-method-combination.progn.2 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.progn.2 (x) (:method-combination progn :most-specific-first) (:method progn ((x integer)) (push 4 *x*) 'a) (:method progn ((x rational)) (push 3 *x*) 'b) (:method progn ((x number)) (push 2 *x*) 'c) (:method progn ((x t)) (push 1 *x*) 'd))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (d (1 2 3 4)) (d (1 2 3)) (d (1 2)) (d (1))) (deftest defgeneric-method-combination.progn.3 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.progn.3 (x) (:method-combination progn :most-specific-last) (:method progn ((x integer)) (push 4 *x*) 'a) (:method progn ((x rational)) (push 3 *x*) 'b) (:method progn ((x number)) (push 2 *x*) 'c) (:method progn ((x t)) (push 1 *x*) 'd))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (a (4 3 2 1)) (b (3 2 1)) (c (2 1)) (d (1))) (deftest defgeneric-method-combination.progn.4 (let ((fn (eval '(defgeneric dg-mc.progn.4 (x) (:method-combination progn) (:method progn ((x integer)) 'd) (:method :around ((x rational)) 'foo) (:method progn ((x number)) 'b) (:method progn ((x symbol)) 'c) (:method progn ((x t)) 'a))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) foo foo a a a) (deftest defgeneric-method-combination.progn.4a (let ((fn (eval '(defgeneric dg-mc.progn.4a (x) (:method-combination progn :most-specific-last) (:method progn ((x integer)) 'd) (:method :around ((x rational)) 'foo) (:method progn ((x number)) 'b) (:method progn ((x symbol)) 'c) (:method progn ((x t)) 'a))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) foo foo b c a) (deftest defgeneric-method-combination.progn.5 (let ((fn (eval '(defgeneric dg-mc.progn.5 (x) (:method-combination progn) (:method progn ((x integer)) 'a) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method progn ((x number)) nil) (:method progn ((x symbol)) 'b) (:method progn ((x t)) 'c))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) (foo c) (foo c) c c c) (deftest defgeneric-method-combination.progn.5a (let ((fn (eval '(defgeneric dg-mc.progn.5a (x) (:method-combination progn :most-specific-last) (:method progn ((x integer)) 'a) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method progn ((x number)) 'e) (:method progn ((x symbol)) 'b) (:method progn ((x t)) 'c))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) (foo a) (foo e) e b c) (deftest defgeneric-method-combination.progn.6 (let ((fn (eval '(defgeneric dg-mc.progn.6 (x) (:method-combination progn) (:method progn ((x integer)) 'a) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method :around ((x real)) (list 'bar (call-next-method))) (:method progn ((x number)) 'b) (:method progn ((x symbol)) 'c) (:method progn ((x t)) 'd))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn #c(1.0 2.0)) (funcall fn 'x) (funcall fn '(a b c)))) (foo (bar d)) (foo (bar d)) (bar d) d d d) (deftest defgeneric-method-combination.progn.6a (let ((fn (eval '(defgeneric dg-mc.progn.6a (x) (:method-combination progn :most-specific-last) (:method progn ((x integer)) 'a) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method :around ((x real)) (list 'bar (call-next-method))) (:method progn ((x number)) 'b) (:method progn ((x symbol)) 'c) (:method progn ((x t)) 'd))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn #c(1.0 2.0)) (funcall fn 'x) (funcall fn '(a b c)))) (foo (bar a)) (foo (bar b)) (bar b) b c d) (deftest defgeneric-method-combination.progn.7 (let ((fn (eval '(defgeneric dg-mc.progn.7 (x) (:method-combination progn) (:method progn ((x dgmc-class-04)) 'a) (:method progn ((x dgmc-class-03)) 'b) (:method progn ((x dgmc-class-02)) 'c) (:method progn ((x dgmc-class-01)) 'd))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) (funcall fn (make-instance 'dgmc-class-02)) (funcall fn (make-instance 'dgmc-class-03)) (funcall fn (make-instance 'dgmc-class-04)))) d d d d) (deftest defgeneric-method-combination.progn.7a (let ((fn (eval '(defgeneric dg-mc.progn.7a (x) (:method-combination progn :most-specific-last) (:method progn ((x dgmc-class-04)) 'a) (:method progn ((x dgmc-class-03)) 'b) (:method progn ((x dgmc-class-02)) 'c) (:method progn ((x dgmc-class-01)) 'd))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) (funcall fn (make-instance 'dgmc-class-02)) (funcall fn (make-instance 'dgmc-class-03)) (funcall fn (make-instance 'dgmc-class-04)))) d c b a) (deftest defgeneric-method-combination.progn.8 (let ((fn (eval '(defgeneric dg-mc.progn.8 (x) (:method-combination progn) (:method progn ((x (eql 1000))) 'a) (:method :around ((x symbol)) (values)) (:method :around ((x integer)) (values 'a 'b 'c)) (:method :around ((x complex)) (call-next-method)) (:method :around ((x number)) (values 1 2 3 4 5 6)) (:method progn ((x t)) 'b))))) (declare (type generic-function fn)) (values (multiple-value-list (funcall fn 'a)) (multiple-value-list (funcall fn 10)) (multiple-value-list (funcall fn #c(9 8))) (multiple-value-list (funcall fn '(a b c))))) () (a b c) (1 2 3 4 5 6) (b)) (deftest defgeneric-method-combination.progn.9 (handler-case (let ((fn (eval '(defgeneric dg-mc.progn.9 (x) (:method-combination progn))))) (declare (type generic-function fn)) (funcall fn (list 'a))) (error () :error)) :error) (deftest defgeneric-method-combination.progn.10 (progn (eval '(defgeneric dg-mc.progn.10 (x) (:method-combination progn) (:method ((x t)) 0))) (handler-case (dg-mc.progn.10 'a) (error () :error))) :error) (deftest defgeneric-method-combination.progn.11 (progn (eval '(defgeneric dg-mc.progn.11 (x) (:method-combination progn) (:method nonsense ((x t)) 0))) (handler-case (dg-mc.progn.11 0) (error () :error))) :error) (deftest defgeneric-method-combination.progn.12 (let ((fn (eval '(defgeneric dg-mc.progn.12 (x) (:method-combination progn) (:method :around ((x t)) 'a) (:method progn ((x integer)) x))))) (declare (type generic-function fn)) (handler-case (funcall fn 'b) (error () :error))) :error) gcl27-2.7.0/ansi-tests/defgeneric.lsp000066400000000000000000000546671454061450500173710ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 17 20:55:50 2003 ;;;; Contains: Tests of DEFGENERIC (in-package :cl-test) ;;; Various error cases (defun defgeneric-testfn-01 (x) x) (deftest defgeneric.error.1 ;; Cannot make ordinary functions generic (let* ((name 'defgeneric-testfn-01) (fn (symbol-function name))) (if (not (typep fn 'generic-function)) (handler-case (progn (eval `(defgeneric ,name ())) :bad) (program-error () :good)) :good)) :good) (defmacro defgeneric-testmacro-02 (x) x) (deftest defgeneric.error.2 ;; Cannot make macros generic (let* ((name 'defgeneric-testmacro-02)) (handler-case (progn (eval `(defgeneric ,name ())) :bad) (program-error () :good))) :good) (deftest defgeneric.error.3 ;; Cannot make special operators generic (loop for name in *cl-special-operator-symbols* for result = (handler-case (progn (eval `(defgeneric ,name ())) t) (program-error () nil)) when result collect name) nil) (deftest defgeneric.error.4 (signals-error (defgeneric defgeneric-error-fn.4 (x y) (:argument-precedence-order x y x)) program-error) t) (deftest defgeneric.error.5 (signals-error (defgeneric defgeneric-error-fn.5 (x) (:documentation "some documentation") (:documentation "illegally repeated documentation")) program-error) t) (deftest defgeneric.error.6 (signals-error (defgeneric defgeneric-error-fn.6 (x) (unknown-option nil)) program-error) t) (deftest defgeneric.error.7 (handler-case (progn (eval '(defgeneric defgeneric-error-fn.7 (x y) (:method ((x t)) x))) :bad) (error () :good)) :good) (deftest defgeneric.error.8 (signals-error (defgeneric defgeneric-error-fn.8 (x y) (:argument-precedence-order x)) program-error) t) ;;; Non-congruent methods cause defgeneric to signal an error (deftest defgeneric.error.9 (handler-case (progn (eval '(defgeneric defgeneric-error-fn.9 (x) (:method ((x t)(y t)) t))) :bad) (error () :good)) :good) (deftest defgeneric.error.10 (handler-case (progn (eval '(defgeneric defgeneric-error-fn.10 (x &optional y) (:method ((x t)) t))) :bad) (error () :good)) :good) (deftest defgeneric.error.11 (handler-case (progn (eval '(defgeneric defgeneric-error-fn.11 (x &optional y) (:method (x &optional y z) t))) :bad) (error () :good)) :good) (deftest defgeneric.error.12 (handler-case (progn (eval '(defgeneric defgeneric-error-fn.12 (x &rest y) (:method (x) t))) :bad) (error () :good)) :good) (deftest defgeneric.error.13 (handler-case (progn (eval '(defgeneric defgeneric-error-fn.13 (x) (:method (x &rest y) t))) :bad) (error () :good)) :good) (deftest defgeneric.error.14 (handler-case (progn (eval '(defgeneric defgeneric-error-fn.14 (x &key) (:method (x) t))) :bad) (error () :good)) :good) (deftest defgeneric.error.15 (handler-case (progn (eval '(defgeneric defgeneric-error-fn.15 (x &key y) (:method (x) t))) :bad) (error () :good)) :good) (deftest defgeneric.error.16 (handler-case (progn (eval '(defgeneric defgeneric-error-fn.16 (x) (:method (x &key) t))) :bad) (error () :good)) :good) (deftest defgeneric.error.17 (handler-case (progn (eval '(defgeneric defgeneric-error-fn.17 (x) (:method (x &key foo) t))) :bad) (error () :good)) :good) (deftest defgeneric.error.18 (handler-case (progn (eval '(defgeneric defgeneric-error-fn.18 (x &key foo) (:method (x &key) t))) :bad) (error () :good)) :good) (deftest defgeneric.error.19 (handler-case (progn (eval '(defgeneric defgeneric-error-fn.19 (x &key foo) (:method (x &key bar) t))) :bad) (error () :good)) :good) ;;; A close reading of the rules for keyword arguments to ;;; generic functions convinced me that the following two ;;; error tests are necessary. See sections 7.6.5 of the CLHS. (deftest defgeneric.error.20 (signals-error (let ((fn (defgeneric defgeneric-error-fn.20 (x &key) (:method ((x number) &key foo) (list x foo)) (:method ((x symbol) &key bar) (list x bar))))) (funcall fn 1 :bar 'a)) program-error) t) (deftest defgeneric.error.21 (signals-error (let ((fn (defgeneric defgeneric-error-fn.21 (x &key) (:method ((x number) &key foo &allow-other-keys) (list x foo)) (:method ((x symbol) &key bar) (list x bar))))) (funcall fn 'x :foo 'a)) program-error) t) ;;; (deftest defgeneric.error.22 (progn (defgeneric defgeneric-error-fn.22 (x)) (defmethod defgeneric-error-fn.22 ((x t)) nil) (handler-case (eval '(defgeneric defgeneric-error-fn.22 (x y))) (error () :good))) :good) ;;; Non error cases (deftest defgeneric.1 (let ((fn (eval '(defgeneric defgeneric.fun.1 (x y z) (:method ((x t) (y t) (z t)) (list x y z)))))) (declare (type function fn)) (values (typep* fn 'generic-function) (typep* fn 'standard-generic-function) (funcall fn 'a 'b 'c) (apply fn 1 2 3 nil) (apply fn (list 4 5 6)) (mapcar fn '(1 2) '(3 4) '(5 6)) (defgeneric.fun.1 'd 'e 'f))) t t (a b c) (1 2 3) (4 5 6) ((1 3 5) (2 4 6)) (d e f)) (deftest defgeneric.2 (let ((fn (eval '(defgeneric defgeneric.fun.2 (x y z) (:documentation "boo!") (:method ((x t) (y t) (z t)) (vector x y z)))))) (declare (type function fn)) (values (typep* fn 'generic-function) (typep* fn 'standard-generic-function) (funcall fn 'a 'b 'c) (defgeneric.fun.2 'd 'e 'f) (let ((doc (documentation fn t))) (or (not doc) (and (stringp doc) (string=t doc "boo!")))) (let ((doc (documentation fn 'function))) (or (not doc) (and (stringp doc) (string=t doc "boo!")))) (setf (documentation fn t) "foo") (let ((doc (documentation fn t))) (or (not doc) (and (stringp doc) (string=t doc "foo")))) (setf (documentation fn 'function) "bar") (let ((doc (documentation fn t))) (or (not doc) (and (stringp doc) (string=t doc "bar")))))) t t #(a b c) #(d e f) t t "foo" t "bar" t) (deftest defgeneric.3 (let ((fn (eval '(defgeneric defgeneric.fun.3 (x y) (:method ((x t) (y symbol)) (list x y)) (:method ((x symbol) (y t)) (list y x)))))) (declare (type function fn)) (values (typep* fn 'generic-function) (typep* fn 'standard-generic-function) (funcall fn 1 'a) (funcall fn 'b 2) (funcall fn 'a 'b))) t t (1 a) (2 b) (b a)) (deftest defgeneric.4 (let ((fn (eval '(defgeneric defgeneric.fun.4 (x y) (:argument-precedence-order y x) (:method ((x t) (y symbol)) (list x y)) (:method ((x symbol) (y t)) (list y x)))))) (declare (type function fn)) (values (typep* fn 'generic-function) (typep* fn 'standard-generic-function) (funcall fn 1 'a) (funcall fn 'b 2) (funcall fn 'a 'b))) t t (1 a) (2 b) (a b)) (deftest defgeneric.5 (let ((fn (eval '(defgeneric defgeneric.fun.5 () (:method () (values)))))) (declare (type function fn)) (values (typep* fn 'generic-function) (typep* fn 'standard-generic-function) (multiple-value-list (funcall fn)) (multiple-value-list (defgeneric.fun.5)) (multiple-value-list (apply fn nil)))) t t nil nil nil) (deftest defgeneric.6 (let ((fn (eval '(defgeneric defgeneric.fun.6 () (:method () (values 'a 'b 'c)))))) (declare (type function fn)) (values (typep* fn 'generic-function) (typep* fn 'standard-generic-function) (multiple-value-list (funcall fn)) (multiple-value-list (defgeneric.fun.6)) (multiple-value-list (apply fn nil)))) t t (a b c) (a b c) (a b c)) (deftest defgeneric.7 (let ((fn (eval '(defgeneric defgeneric.fun.7 () (:method () (return-from defgeneric.fun.7 'a) 'b))))) (declare (type function fn)) (values (typep* fn 'generic-function) (typep* fn 'standard-generic-function) (multiple-value-list (funcall fn)) (multiple-value-list (defgeneric.fun.7)) (multiple-value-list (apply fn nil)))) t t (a) (a) (a)) (deftest defgeneric.8 (let ((fn (eval '(defgeneric defgeneric.fun.8 (x &optional y z) (:method ((x number) &optional y z) (list x y z)) (:method ((p symbol) &optional q r) (list r q p)))))) (declare (type function fn)) (values (typep* fn 'generic-function) (typep* fn 'standard-generic-function) (multiple-value-list (funcall fn 1)) (multiple-value-list (funcall fn 1 2)) (multiple-value-list (funcall fn 1 2 3)) (multiple-value-list (defgeneric.fun.8 'a)) (multiple-value-list (defgeneric.fun.8 'a 'b)) (multiple-value-list (defgeneric.fun.8 'a 'b 'c)) (multiple-value-list (apply fn '(x y z))))) t t ((1 nil nil)) ((1 2 nil)) ((1 2 3)) ((nil nil a)) ((nil b a)) ((c b a)) ((z y x))) (deftest defgeneric.9 (let ((fn (eval '(defgeneric defgeneric.fun.9 (x &optional y z) (:method ((x number) &optional (y 10) (z 20)) (list x y z)) (:method ((p symbol) &optional (q 's) (r 't)) (list r q p)))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 2) (funcall fn 1 2 3) (funcall fn 'a) (funcall fn 'a 'b) (funcall fn 'a 'b 'c))) (1 10 20) (1 2 20) (1 2 3) (t s a) (t b a) (c b a)) (deftest defgeneric.10 (let ((fn (eval '(defgeneric defgeneric.fun.10 (x &rest y) (:method ((x number) &key foo) (list x foo)))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 :foo 'a) (defgeneric.fun.10 5/3 :foo 'x :foo 'y) (defgeneric.fun.10 10 :bar t :allow-other-keys t) (defgeneric.fun.10 20 :allow-other-keys nil :foo 'x))) (1 nil) (1 a) (5/3 x) (10 nil) (20 x)) (deftest defgeneric.11 (let ((fn (eval '(defgeneric defgeneric.fun.11 (x &key) (:method ((x number) &key foo) (list x foo)))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 :foo 'a) (defgeneric.fun.11 5/3 :foo 'x :foo 'y) (defgeneric.fun.11 11 :bar t :allow-other-keys t) (defgeneric.fun.11 20 :allow-other-keys nil :foo 'x))) (1 nil) (1 a) (5/3 x) (11 nil) (20 x)) (deftest defgeneric.12 (let ((fn (eval '(defgeneric defgeneric.fun.12 (x &key foo bar baz) (:method ((x number) &rest y) (list x y)))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 :foo 'a) (defgeneric.fun.12 5/3 :foo 'x :foo 'y :bar 'z) (defgeneric.fun.12 11 :zzz t :allow-other-keys t) (defgeneric.fun.12 20 :allow-other-keys nil :foo 'x))) (1 nil) (1 (:foo a)) (5/3 (:foo x :foo y :bar z)) (11 (:zzz t :allow-other-keys t)) (20 (:allow-other-keys nil :foo x))) (deftest defgeneric.13 (let ((fn (eval '(defgeneric defgeneric.fun.13 (x &key) (:method ((x number) &key foo) (list x foo)) (:method ((x symbol) &key bar) (list x bar)))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 'a) (funcall fn 1 :foo 2) ;; (funcall fn 1 :foo 2 :bar 3) ;; (funcall fn 1 :bar 4) ;; (funcall fn 'a :foo 'b) (funcall fn 'a :bar 'b) ;; (funcall fn 'a :foo 'c :bar 'b) )) (1 nil) (a nil) (1 2) ;; (1 2) ;; (1 nil) ;; (a nil) (a b) ;; (a b) ) (deftest defgeneric.14 (let ((fn (eval '(defgeneric defgeneric.fun.14 (x &key &allow-other-keys) (:method ((x number) &key foo) (list x foo)) (:method ((x symbol) &key bar) (list x bar)))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 'a) (funcall fn 1 :foo 2) (funcall fn 1 :foo 2 :bar 3) (funcall fn 1 :bar 4) (funcall fn 'a :foo 'b) (funcall fn 'a :bar 'b) (funcall fn 'a :foo 'c :bar 'b) (funcall fn 1 :baz 10) (funcall fn 'a :baz 10) (funcall fn 1 :allow-other-keys nil :baz 'a) (funcall fn 'a :allow-other-keys nil :baz 'b) )) (1 nil) (a nil) (1 2) (1 2) (1 nil) (a nil) (a b) (a b) (1 nil) (a nil) (1 nil) (a nil)) (deftest defgeneric.15 (let ((fn (eval '(defgeneric defgeneric.fun.15 (x &key) (:method ((x number) &key foo &allow-other-keys) (list x foo)) (:method ((x symbol) &key bar) (list x bar)))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 'a) (funcall fn 1 :foo 2) (funcall fn 1 :foo 2 :bar 3) (funcall fn 1 :bar 4) (funcall fn 'a :allow-other-keys t :foo 'b) (funcall fn 'a :bar 'b) (funcall fn 'a :foo 'c :bar 'b :allow-other-keys t) (funcall fn 1 :baz 10) ;; (funcall fn 'a :baz 10) (funcall fn 1 :allow-other-keys nil :baz 'a) ;; (funcall fn 'a :allow-other-keys nil :baz 'b) )) (1 nil) (a nil) (1 2) (1 2) (1 nil) (a nil) (a b) (a b) (1 nil) ;; (a nil) (1 nil) ;; (a nil) ) (deftest defgeneric.16 (let ((fn (eval '(defgeneric defgeneric.fun.16 (x &key) (:method ((x number) &key (foo 'a)) (list x foo)) (:method ((x symbol) &key foo) (list x foo)))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 :foo nil) (funcall fn 1 :foo 2) (funcall fn 'x) (funcall fn 'x :foo nil) (funcall fn 'x :foo 'y))) (1 a) (1 nil) (1 2) (x nil) (x nil) (x y)) (deftest defgeneric.17 (let ((fn (eval '(defgeneric defgeneric.fun.17 (x &key) (:method ((x number) &key (foo 'a foo-p)) (list x foo (notnot foo-p))) (:method ((x symbol) &key foo) (list x foo)))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 :foo nil) (funcall fn 1 :foo 2) (funcall fn 'x) (funcall fn 'x :foo nil) (funcall fn 'x :foo 'y))) (1 a nil) (1 nil t) (1 2 t) (x nil) (x nil) (x y)) (deftest defgeneric.18 (let ((fn (eval '(defgeneric defgeneric.fun.18 (x &optional y) (:method ((x number) &optional (y 'a)) (list x y)) (:method ((x symbol) &optional (z nil z-p)) (list x z (notnot z-p))))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 nil) (funcall fn 1 2) (funcall fn 'x) (funcall fn 'x nil) (funcall fn 'x 'y))) (1 a) (1 nil) (1 2) (x nil nil) (x nil t) (x y t)) (deftest defgeneric.19 (let ((fn (eval '(defgeneric defgeneric.fun.19 (x &key) (:method ((x number) &key ((:bar foo) 'a foo-p)) (list x foo (notnot foo-p))))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 :bar nil) (funcall fn 1 :bar 2))) (1 a nil) (1 nil t) (1 2 t)) (deftest defgeneric.20 (let ((fn (eval '(defgeneric defgeneric.fun.20 (x &optional y z) (:method ((x number) &optional (y (1+ x) y-p) (z (if y-p (1+ y) (+ x 10)) z-p)) (list x y (notnot y-p) z (notnot z-p))))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 5) (funcall fn 1 5 9))) (1 2 nil 11 nil) (1 5 t 6 nil) (1 5 t 9 t)) (deftest defgeneric.21 (let ((fn (eval '(defgeneric defgeneric.fun.21 (x &key) (:method ((x number) &key (y (1+ x) y-p) (z (if y-p (1+ y) (+ x 10)) z-p)) (list x y (notnot y-p) z (notnot z-p))))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 :y 5) (funcall fn 1 :y 5 :z 9) (funcall fn 1 :z 8) (funcall fn 1 :z 8 :y 4))) (1 2 nil 11 nil) (1 5 t 6 nil) (1 5 t 9 t) (1 2 nil 8 t) (1 4 t 8 t)) (deftest defgeneric.22 (let ((fn (eval '(defgeneric defgeneric.fun.22 (x &key) (:method ((x number) &key ((:allow-other-keys y))) (list x y)))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 :allow-other-keys nil) (funcall fn 1 :allow-other-keys t) (funcall fn 1 :foo 'x :allow-other-keys t :bar 'y) (funcall fn 1 :allow-other-keys t :foo 'x) (funcall fn 1 :allow-other-keys nil :allow-other-keys t) (funcall fn 1 :foo 'x :allow-other-keys t :allow-other-keys nil) (funcall fn 1 :allow-other-keys t 'foo 'y :allow-other-keys nil) (funcall fn 1 :allow-other-keys t :allow-other-keys nil '#:foo 'z))) (1 nil) (1 nil) (1 t) (1 t) (1 t) (1 nil) (1 t) (1 t) (1 t)) (deftest defgeneric.23 (let ((fn (eval '(defgeneric defgeneric.fun.23 (x) (:method ((x number) &aux (y (1+ x))) (list x y)) (:method ((x symbol) &aux (z (list x))) (list x z)))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 'a))) (1 2) (a (a))) (deftest defgeneric.24 (let ((fn (eval '(defgeneric defgeneric.fun.24 (x) (:method ((x number) &aux (y (1+ x)) (z (1+ y))) (list x y z)) (:method ((x symbol) &aux (y (list x)) (z (list x y))) (list x y z)))))) (values (funcall fn 1) (funcall fn 'a))) (1 2 3) (a (a) (a (a)))) (deftest defgeneric.25 (let ((fn (eval '(defgeneric defgeneric.fun.25 (x &optional y &key) (:method ((x symbol) &optional (y 'd y-p) &key ((:foo bar) (list x y) bar-p) &aux (z (list x y (notnot y-p) bar (notnot bar-p)))) z))))) (declare (type function fn)) (values (funcall fn 'a) (funcall fn 'a 'b) (funcall fn 'a 'b :foo 'c))) (a d nil (a d) nil) (a b t (a b) nil) (a b t c t)) (deftest defgeneric.26 (let ((fn (eval '(defgeneric defgeneric.fun.26 (x) (declare (optimize (safety 3))) (:method ((x symbol)) x) (declare (optimize (debug 3))))))) (declare (type function fn)) (funcall fn 'a)) a) #| (when (subtypep (class-of (find-class 'standard-method)) 'standard-class) (defclass substandard-method (standard-method) ()) (deftest defgeneric.27 (let ((fn (eval '(defgeneric defgeneric.fun.27 (x y) (:method-class substandard-method) (:method ((x number) (y number)) (+ x y)) (:method ((x string) (y string)) (concatenate 'string x y)))))) (declare (type function fn)) (values (funcall fn 1 2) (funcall fn "1" "2"))) 3 "12")) |# (deftest defgeneric.28 (let ((fn (eval '(defgeneric defgeneric.fun.28 (x &key) (:method ((x integer) &key foo) (list x foo)) (:method ((x number) &key bar) (list x bar)) (:method ((x t) &key baz) (list x baz)))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 :foo 'a) (funcall fn 1 :bar 'b) (funcall fn 1 :baz 'c) (funcall fn 1 :bar 'b :baz 'c) (funcall fn 1 :foo 'a :bar 'b) (funcall fn 1 :foo 'a :baz 'c) (funcall fn 1 :foo 'a :bar 'b :baz 'c) (funcall fn 5/3) (funcall fn 5/3 :bar 'b) (funcall fn 5/3 :baz 'c) (funcall fn 5/3 :bar 'b :baz 'c) (funcall fn 'x) (funcall fn 'x :baz 'c) )) (1 nil) (1 a) (1 nil) (1 nil) (1 nil) (1 a) (1 a) (1 a) (5/3 nil) (5/3 b) (5/3 nil) (5/3 b) (x nil) (x c)) (defclass defgeneric.29.class.1 () ()) (defclass defgeneric.29.class.2 () ()) (defclass defgeneric.29.class.3 (defgeneric.29.class.1 defgeneric.29.class.2) ()) (deftest defgeneric.29 (let ((fn (eval '(defgeneric defgeneric.fun.29 (x &key) (:method ((x defgeneric.29.class.1) &key foo) foo) (:method ((x defgeneric.29.class.2) &key bar) bar))))) (declare (type function fn)) (let ((x (make-instance 'defgeneric.29.class.3))) (values (funcall fn x) (funcall fn x :foo 'a) (funcall fn x :bar 'b) (funcall fn x :foo 'a :bar 'b) (funcall fn x :bar 'b :foo 'a)))) nil a nil a a) ;;; I'm not sure this one is proper ;;; Added :metaclass at prompting of Martin Simmons (when (subtypep (class-of (find-class 'standard-generic-function)) 'standard-class) (defclass substandard-generic-function (standard-generic-function) () (:metaclass #.(class-name (class-of (find-class 'standard-generic-function))))) (deftest defgeneric.30 (let ((fn (eval '(defgeneric defgeneric.fun.29 (x) (:generic-function-class substandard-generic-function) (:method ((x symbol)) 1) (:method ((x integer)) 2))))) (declare (type function fn)) (values (typep* fn 'substandard-generic-function) (typep* fn 'standard-generic-function) (typep* fn 'generic-function) (typep* fn 'function) (funcall fn 'a) (funcall fn 1) (defgeneric.fun.29 'x) (defgeneric.fun.29 12345678901234567890))) t t t t 1 2 1 2)) (deftest defgeneric.31 (progn (defgeneric defgeneric.fun.31 (x) (:method ((x t)) t)) (defgeneric defgeneric.fun.31 (x y) (:method ((x t) (y t)) (list x y))) (defgeneric.fun.31 'a 'b)) (a b)) (deftest defgeneric.32 (progn (defgeneric defgeneric.fun.32 (x) (:method ((x symbol)) :bad)) (defgeneric defgeneric.fun.32 (x) (:method ((x t)) :good)) (defgeneric.fun.32 'x)) :good) (deftest defgeneric.33 (let ((fn (eval '(defgeneric (setf defgeneric.fun.33) (x y &rest args) (:method (x (y cons) &rest args) (assert (null args)) (setf (car y) x)) (:method (x (y array) &rest args) (setf (apply #'aref y args) x)))))) (declare (type function fn)) (values (let ((z (list 'a 'b))) (list (setf (defgeneric.fun.33 z) 'c) z)) (let ((a (make-array '(10) :initial-element nil))) (list (setf (defgeneric.fun.33 a 5) 'd) a)))) (c (c b)) (d #(nil nil nil nil nil d nil nil nil nil))) (deftest defgeneric.34 (let ((fn (eval '(defgeneric #:defgeneric.fun.34 (x) (:method ((x t)) (list x :good)))))) (funcall fn 10)) (10 :good)) (deftest defgeneric.35 (let ((fn (eval '(defgeneric defgeneric.fun.35 (x) (:method ((x (eql 'a))) (declare (optimize (speed 0))) "FOO" (declare (optimize (safety 3))) x))))) (declare (type function fn)) (values (funcall fn 'a) (let ((method (first (compute-applicable-methods fn '(a))))) (and method (let ((doc (documentation method t))) (list (or (null doc) (equalt doc "FOO")) (setf (documentation method t) "BAR") (let ((doc (documentation method t))) (or (null doc) (equalt doc "BAR"))) )))))) a (t "BAR" t)) gcl27-2.7.0/ansi-tests/define-compiler-macro.lsp000066400000000000000000000121451454061450500214200ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 12:33:02 2003 ;;;; Contains: Tests of DEFINE-COMPILER-MACRO (in-package :cl-test) ;;; Need to add non-error tests (deftest define-compiler-macro.error.1 (signals-error (funcall (macro-function 'define-compiler-macro)) program-error) t) (deftest define-compiler-macro.error.2 (signals-error (funcall (macro-function 'define-compiler-macro) '(definee-compiler-macro nonexistent-function ())) program-error) t) (deftest define-compiler-macro.error.3 (signals-error (funcall (macro-function 'define-compiler-macro) '(definee-compiler-macro nonexistent-function ()) nil nil) program-error) t) ;;; Non-error tests (deftest define-compiler-macro.1 (let* ((sym (gensym)) (macro-def-form `(define-compiler-macro ,sym (x y) (declare (special *x*)) (setf *x* t) `(+ ,x ,y 1))) (fun-def-form `(defun ,sym (x y) (+ x y 1)))) (values (equalt (list sym) (multiple-value-list (eval fun-def-form))) (equalt (list sym) (multiple-value-list (eval macro-def-form))) (notnot (typep (compiler-macro-function sym) 'function)) (eval `(,sym 6 19)) (let ((fn (compile nil `(lambda (a b) (,sym a b))))) (let ((*x* nil)) (declare (special *x*)) (list (funcall fn 12 123) *x*))))) t t t 26 (136 nil)) (deftest define-compiler-macro.2 (let* ((sym (gensym)) (macro-def-form `(define-compiler-macro ,sym (&whole form &rest args) (declare (special *x*) (ignore args)) (setf *x* t) (return-from ,sym form))) (fun-def-form `(defun ,sym (x) x))) (values (equalt (list sym) (multiple-value-list (eval fun-def-form))) (equalt (list sym) (multiple-value-list (eval macro-def-form))) (notnot (typep (compiler-macro-function sym) 'function)) (eval `(,sym 'a)) (let ((fn (compile nil `(lambda (a) (,sym a))))) (let ((*x* nil)) (declare (special *x*)) (list (funcall fn 'b) *x*))))) t t t a (b nil)) (deftest define-compiler-macro.3 (let* ((sym (gensym)) (macro-def-form `(define-compiler-macro ,sym (&whole form &rest args) (declare (special *x*) (ignore args)) (setf *x* t) (return-from ,sym form))) (ordinary-macro-def-form `(defmacro ,sym (x) x))) (values (equalt (list sym) (multiple-value-list (eval ordinary-macro-def-form))) (equalt (list sym) (multiple-value-list (eval macro-def-form))) (notnot (typep (compiler-macro-function sym) 'function)) (eval `(,sym 'a)) (let ((fn (compile nil `(lambda (a) (,sym a))))) (let ((*x* nil)) (declare (special *x*)) (list (funcall fn 'b) *x*))))) t t t a (b nil)) ;;; Compiler macros on setf functions (deftest define-compiler-macro.4 (let* ((sym (gensym)) (fun-def-form `(defun ,sym (x) (car x))) (setf-fun-def-form `(defun (setf ,sym) (newval x) (setf (car x) newval))) (setf-compiler-macro-def-form `(define-compiler-macro (setf ,sym) (newval x) (declare (special *x*)) (setf *x* t) (return-from ,sym `(setf (car ,x) ,newval))))) (values (equalt (list sym) (multiple-value-list (eval fun-def-form))) (equalt `((setf ,sym)) (multiple-value-list (eval setf-fun-def-form))) (equalt `((setf ,sym)) (multiple-value-list (eval setf-compiler-macro-def-form))) (notnot (typep (compiler-macro-function `(setf ,sym)) 'function)) (eval `(,sym (list 'a 'b))) (eval `(let ((arg (list 1 2))) (list (setf (,sym arg) 'z) arg))) (let ((fn (compile nil `(lambda (u v) (setf (,sym u) v))))) (let ((*x* nil) (arg (list 1 2))) (declare (special *x*)) (list (funcall fn arg 'y) arg))))) t t t t a (z (z 2)) (y (y 2))) ;;; Test of documentation (deftest define-compiler-macro.5 (let* ((sym (gensym)) (form `(define-compiler-macro ,sym (x) "DCM.5" x)) (form2 `(defun ,sym (x) "DCM.5-WRONG" x))) (eval form) (eval form2) (or (documentation sym 'compiler-macro) "DCM.5")) "DCM.5") (deftest define-compiler-macro.6 (let* ((sym (gensym)) (form `(define-compiler-macro ,sym (x) "DCM.6" x)) (form2 `(defun ,sym (x) "DCM.6-WRONG" x))) (eval form2) (eval form) (or (documentation sym 'compiler-macro) "DCM.6")) "DCM.6") ;;; NOTINLINE turns off a compiler macro (deftest define-compiler-macro.7 (let* ((sym (gensym)) (form `(define-compiler-macro ,sym (x y) (declare (special *x*)) (setf *x* :bad) `(list ,x ,y))) (form2 `(defun ,sym (x y) (list x y)))) (eval form) (eval form2) (compile sym) (let ((*x* :good)) (declare (special *x*)) (values (funcall (compile nil `(lambda (a b) (declare (notinline ,sym)) (,sym a b))) 5 11) *x*))) (5 11) :good) (deftest define-compiler-macro.8 (let* ((sym (gensym)) (form `(define-compiler-macro ,sym (x y) (declare (special *x*)) (setf *x* :bad) `(list ,x ,y))) (form2 `(defmacro ,sym (x y) `(list ,x ,y)))) (eval form) (eval form2) (let ((*x* :good)) (declare (special *x*)) (values (funcall (compile nil `(lambda (a b) (declare (notinline ,sym)) (,sym a b))) 7 23) *x*))) (7 23) :good) gcl27-2.7.0/ansi-tests/define-condition-aux.lsp000066400000000000000000000056061454061450500212740ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 9 05:40:13 2003 ;;;; Contains: Auxiliary functions for testing DEFINE-CONDITION (in-package :cl-test) (defun make-def-cond-name (name &rest suffixes) (intern (apply #'concatenate 'string (string name) "/" (mapcar #'string suffixes)) :cl-test)) (defmacro define-condition-with-tests (name-symbol parents slot-specs &rest options) "Create a condition and some associated tests." (assert (symbolp name-symbol)) (dolist (parent parents) (assert (symbolp parent))) (let ((name (symbol-name name-symbol))) `(eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (eval '(define-condition ,name-symbol ,parents ,slot-specs ,@options))) ,@(loop for parent in (adjoin 'condition parents) collect `(deftest ,(make-def-cond-name name "IS-SUBTYPE-OF/" parent) (subtypep* ',name-symbol ',parent) t t)) ,@(loop for parent in (adjoin 'condition parents) collect `(deftest ,(make-def-cond-name name "IS-SUBTYPE-OF-2/" parent) (check-all-subtypep ',name-symbol ',parent) nil)) ,@(loop for parent in (adjoin 'condition parents) collect `(deftest ,(make-def-cond-name name "IS-NOT-SUPERTYPE-OF/" parent) (subtypep* ',parent ',name-symbol) nil t)) ,@(loop for parent in (adjoin 'condition parents) collect `(deftest ,(make-def-cond-name name "IS-A/" parent) (let ((c (make-condition ',name-symbol))) (notnot-mv (typep c ',parent))) t)) ,@(loop for parent in (adjoin 'condition parents) collect `(deftest ,(make-def-cond-name name "IS-SUBCLASS-OF/" parent) (subtypep* (find-class ',name-symbol) (find-class ',parent)) t t)) ,@(loop for parent in (adjoin 'condition parents) collect `(deftest ,(make-def-cond-name name "IS-NOT-SUPERCLASS-OF/" parent) (subtypep* (find-class ',parent) (find-class ',name-symbol)) nil t)) ,@(loop for parent in (adjoin 'condition parents) collect `(deftest ,(make-def-cond-name name "IS-A-MEMBER-OF-CLASS/" parent) (let ((c (make-condition ',name-symbol))) (notnot-mv (typep c (find-class ',parent)))) t)) (deftest ,(make-def-cond-name name "HANDLER-CASE-1") (let ((c (make-condition ',name-symbol))) (handler-case (normally (signal c)) (,name-symbol (c1) (eqt c c1)))) t) (deftest ,(make-def-cond-name name "HANDLER-CASE-2") (let ((c (make-condition ',name-symbol))) (handler-case (normally (signal c)) (condition (c1) (eqt c c1)))) t) ,@(unless (some #'(lambda (ct) (subtypep ct 'error)) parents) `((deftest ,(make-def-cond-name name "HANDLER-CASE-3") (let ((c (make-condition ',name-symbol))) (handler-case (normally (signal c)) (error () nil) (,name-symbol (c2) (eqt c c2)))) t))) ))) gcl27-2.7.0/ansi-tests/define-condition.lsp000066400000000000000000000504261454061450500205010ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 8 22:38:53 2003 ;;;; Contains: Tests of DEFINE-CONDITION (part 1) (in-package :cl-test) ;;; (define-condition-with-tests condition-1 nil nil) (define-condition-with-tests condition-2 (condition) nil) #-gcl (define-condition-with-tests #:condition-3 nil nil) (define-condition-with-tests condition-4 nil ((slot1 :initarg :slot1 :reader condition-4/slot-1) (slot2 :initarg :slot2 :reader condition-4/slot-2))) (deftest condition-4-slots.1 (let ((c (make-condition 'condition-4 :slot1 'a :slot2 'b))) (and (typep c 'condition-4) (eqlt (condition-4/slot-1 c) 'a) (eqlt (condition-4/slot-2 c) 'b))) t) (define-condition-with-tests condition-5 nil ((slot1 :initarg :slot1 :initform 'x :reader condition-5/slot-1) (slot2 :initarg :slot2 :initform 'y :reader condition-5/slot-2))) (deftest condition-5-slots.1 (let ((c (make-condition 'condition-5 :slot1 'a :slot2 'b))) (and (typep c 'condition-5) (eqlt (condition-5/slot-1 c) 'a) (eqlt (condition-5/slot-2 c) 'b))) t) (deftest condition-5-slots.2 (let ((c (make-condition 'condition-5 :slot1 'a))) (and (typep c 'condition-5) (eqlt (condition-5/slot-1 c) 'a) (eqlt (condition-5/slot-2 c) 'y))) t) (deftest condition-5-slots.3 (let ((c (make-condition 'condition-5 :slot2 'b))) (and (typep c 'condition-5) (eqlt (condition-5/slot-1 c) 'x) (eqlt (condition-5/slot-2 c) 'b))) t) (deftest condition-5-slots.4 (let ((c (make-condition 'condition-5))) (and (typep c 'condition-5) (eqlt (condition-5/slot-1 c) 'x) (eqlt (condition-5/slot-2 c) 'y))) t) (define-condition-with-tests condition-6 nil ((slot1 :initarg :slot1 :initarg :both-slots :initform 'x :reader condition-6/slot-1) (slot2 :initarg :slot2 :initarg :both-slots :initform 'y :reader condition-6/slot-2))) (deftest condition-6-slots.1 (let ((c (make-condition 'condition-6 :both-slots 'a))) (and (typep c 'condition-6) (eqlt (condition-6/slot-1 c) 'a) (eqlt (condition-6/slot-2 c) 'a))) t) (deftest condition-6-slots.2 (let ((c (make-condition 'condition-6))) (and (typep c 'condition-6) (eqlt (condition-6/slot-1 c) 'x) (eqlt (condition-6/slot-2 c) 'y))) t) (deftest condition-6-slots.3 (let ((c (make-condition 'condition-6 :slot1 'a :both-slots 'b))) (and (typep c 'condition-6) (eqlt (condition-6/slot-1 c) 'a) (eqlt (condition-6/slot-2 c) 'b))) t) (deftest condition-6-slots.4 (let ((c (make-condition 'condition-6 :slot2 'b :both-slots 'a))) (and (typep c 'condition-6) (eqlt (condition-6/slot-1 c) 'a) (eqlt (condition-6/slot-2 c) 'b))) t) (deftest condition-6-slots.5 (let ((c (make-condition 'condition-6 :both-slots 'a :slot1 'c :slot2 'd))) (and (typep c 'condition-6) (eqlt (condition-6/slot-1 c) 'a) (eqlt (condition-6/slot-2 c) 'a))) t) (define-condition-with-tests condition-7 nil ((s :initarg :i1 :initarg :i2 :reader condition-7/s))) (deftest condition-7-slots.1 (let ((c (make-condition 'condition-7 :i1 'a))) (and (typep c 'condition-7) (eqlt (condition-7/s c) 'a))) t) (deftest condition-7-slots.2 (let ((c (make-condition 'condition-7 :i2 'a))) (and (typep c 'condition-7) (eqlt (condition-7/s c) 'a))) t) (deftest condition-7-slots.3 (let ((c (make-condition 'condition-7 :i1 'a :i2 'b))) (and (typep c 'condition-7) (eqlt (condition-7/s c) 'a))) t) (deftest condition-7-slots.4 (let ((c (make-condition 'condition-7 :i2 'a :i1 'b))) (and (typep c 'condition-7) (eqlt (condition-7/s c) 'a))) t) (defparameter *condition-8-counter* 0) (define-condition-with-tests condition-8 nil ((s :initarg :i1 :initform (incf *condition-8-counter*) :reader condition-8/s))) (deftest condition-8-slots.1 (let ((*condition-8-counter* 100)) (declare (special *condition-8-counter*)) (values (condition-8/s (make-condition 'condition-8)) *condition-8-counter*)) 101 101) (define-condition-with-tests condition-9 nil ((s1 :initarg :i1 :initform 15 :reader condition-9/s1) (s2 :initarg :i2 :initform 37 :reader condition-9/s2))) (deftest condition-9-slots.1 (let ((c (make-condition 'condition-9))) (values (notnot (typep c 'condition-9)) (condition-9/s1 c) (condition-9/s2 c))) t 15 37) (deftest condition-9-slots.2 (let ((c (make-condition 'condition-9 :i1 3))) (values (notnot (typep c 'condition-9)) (condition-9/s1 c) (condition-9/s2 c))) t 3 37) (deftest condition-9-slots.3 (let ((c (make-condition 'condition-9 :i2 3))) (values (notnot (typep c 'condition-9)) (condition-9/s1 c) (condition-9/s2 c))) t 15 3) (deftest condition-9-slots.4 (let ((c (make-condition 'condition-9 :i2 3 :i2 8))) (values (notnot (typep c 'condition-9)) (condition-9/s1 c) (condition-9/s2 c))) t 15 3) (deftest condition-9-slots.5 (let ((c (make-condition 'condition-9 :i1 3 :i2 8))) (values (notnot (typep c 'condition-9)) (condition-9/s1 c) (condition-9/s2 c))) t 3 8) (deftest condition-9-slots.6 (let ((c (make-condition 'condition-9 :i1 3 :i2 8 :i1 100 :i2 500))) (values (notnot (typep c 'condition-9)) (condition-9/s1 c) (condition-9/s2 c))) t 3 8) ;;; (define-condition-with-tests condition-10 nil ;;; ((s1 :initarg :i1 :writer condition-10/s1-w :reader condition-10/s1-r))) ;;; ;;; (deftest condition-10-slots.1 ;;; (let ((c (make-condition 'condition-10 :i1 11))) ;;; (condition-10/s1-r c)) ;;; 11) ;;; ;;; (deftest condition-10-slots.2 ;;; (let ((c (make-condition 'condition-10 :i1 11))) ;;; (condition-10/s1-w 17 c)) ;;; 17) ;;; ;;; (deftest condition-10-slots.3 ;;; (let ((c (make-condition 'condition-10 :i1 11))) ;;; (condition-10/s1-w 107 c) ;;; (condition-10/s1-r c)) ;;; 107) ;;; ;;; (define-condition-with-tests condition-11 nil ;;; ((s1 :initarg :i1 :writer (setf condition-11/w) :reader condition-11/r))) ;;; ;;; (deftest condition-11-slots.1 ;;; (let ((c (make-condition 'condition-11 :i1 11))) ;;; (condition-11/r c)) ;;; 11) ;;; ;;; (deftest condition-11-slots.2 ;;; (let ((c (make-condition 'condition-11 :i1 11))) ;;; (setf (condition-11/w c) 17)) ;;; 17) ;;; ;;; (deftest condition-11-slots.3 ;;; (let ((c (make-condition 'condition-11 :i1 11))) ;;; (setf (condition-11/w c) 117) ;;; (condition-11/r c)) ;;; 117) ;;; ;;; (deftest condition-11-slots.4 ;;; (let ((c (make-condition 'condition-11 :i1 11))) ;;; (values ;;; (funcall #'(setf condition-11/w) 117 c) ;;; (condition-11/r c))) ;;; 117 117) ;;; The condition-12 and condition-13 tests have been removed. Duane Rettig ;;; convincingly argued that the feature being tested (non-symbol ;;; slot names) remains in the standard only because of editing errors. ;;; (define-condition-with-tests condition-12 nil ;;; (((slot1) :initarg :slot1 :reader condition-12/slot-1) ;;; ((slot2) :initarg :slot2 :reader condition-12/slot-2))) ;;; ;;; (deftest condition-12-slots.1 ;;; (let ((c (make-condition 'condition-12 :slot1 'a :slot2 'b))) ;;; (and (typep c 'condition-12) ;;; (eqlt (condition-12/slot-1 c) 'a) ;;; (eqlt (condition-12/slot-2 c) 'b))) ;;; t) ;;; ;;; (define-condition-with-tests condition-13 nil ;;; (((slot1 10) :initarg :slot1 :reader condition-13/slot-1))) ;;; ;;; (deftest condition-13-slots.1 ;;; (let ((c (make-condition 'condition-13))) ;;; (and (typep c 'condition-13) ;;; (condition-13/slot-1 c))) ;;; 10) (define-condition-with-tests condition-14 nil ((s1 :initarg :i1 :type fixnum :reader condition-14/s1) (s2 :initarg :i2 :type t :reader condition-14/s2))) (deftest condition-14-slots.1 (let ((c (make-condition 'condition-14 :i1 10))) (and (typep c 'condition-14) (condition-14/s1 c))) 10) (deftest condition-14-slots.2 (let ((c (make-condition 'condition-14 :i2 'a))) (and (typep c 'condition-14) (condition-14/s2 c))) a) (deftest condition-14-slots.3 (let ((c (make-condition 'condition-14 :i1 10 :i2 'h))) (and (typep c 'condition-14) (eqlt (condition-14/s1 c) 10) (condition-14/s2 c))) h) (define-condition-with-tests condition-15 nil ((s1 :type nil))) (define-condition-with-tests condition-16 nil ((slot1)) (:report "The report for condition-16")) (deftest condition-16-report.1 (let ((*print-escape* nil) (c (make-condition 'condition-16))) (with-output-to-string (s) (print-object c s))) "The report for condition-16") (defun condition-17-report (c s) (format s "condition-17: ~A" (condition-17/s c))) (define-condition-with-tests condition-17 nil ((s :initarg :i1 :reader condition-17/s )) (:report condition-17-report)) (deftest condition-17-report.1 (let ((*print-escape* nil) (c (make-condition 'condition-17 :i1 1234))) (with-output-to-string (s) (print-object c s))) "condition-17: 1234") (define-condition-with-tests condition-18 nil ((s :initarg :i1 :reader condition-18/s )) (:report (lambda (c s) (format s "condition-18: ~A" (condition-18/s c))))) (deftest condition-18-report.1 (let ((*print-escape* nil) (c (make-condition 'condition-18 :i1 4321))) (with-output-to-string (s) (print-object c s))) "condition-18: 4321") ;;; ;;; Tests of :default-initargs ;;; ;;; There is an inconsistency in the ANSI spec. DEFINE-CONDITION ;;; says that in (:default-initargs . ), is a list of pairs. ;;; However, DEFCLASS says it's a list whose alternate elements ;;; are initargs and initforms. I have taken the second interpretation. ;;; (define-condition-with-tests condition-19 nil ((s1 :reader condition-19/s1 :initarg :i1) (s2 :reader condition-19/s2 :initarg :i2)) (:default-initargs :i1 10 :i2 20)) (deftest condition-19-slots.1 (let ((c (make-condition 'condition-19))) (values (notnot (typep c 'condition-19)) (condition-19/s1 c) (condition-19/s2 c))) t 10 20) (deftest condition-19-slots.2 (let ((c (make-condition 'condition-19 :i1 'a))) (values (notnot (typep c 'condition-19)) (condition-19/s1 c) (condition-19/s2 c))) t a 20) (deftest condition-19-slots.3 (let ((c (make-condition 'condition-19 :i2 'a))) (values (notnot (typep c 'condition-19)) (condition-19/s1 c) (condition-19/s2 c))) t 10 a) (deftest condition-19-slots.4 (let ((c (make-condition 'condition-19 :i1 'x :i2 'y))) (values (notnot (typep c 'condition-19)) (condition-19/s1 c) (condition-19/s2 c))) t x y) (deftest condition-19-slots.5 (let ((c (make-condition 'condition-19 :i2 'y :i1 'x))) (values (notnot (typep c 'condition-19)) (condition-19/s1 c) (condition-19/s2 c))) t x y) (defparameter *condition-20/s1-val* 0) (defparameter *condition-20/s2-val* 0) (define-condition-with-tests condition-20 nil ((s1 :reader condition-20/s1 :initarg :i1) (s2 :reader condition-20/s2 :initarg :i2)) (:default-initargs :i1 (incf *condition-20/s1-val*) :i2 (incf *condition-20/s2-val*))) (deftest condition-20-slots.1 (let ((*condition-20/s1-val* 0) (*condition-20/s2-val* 10)) (declare (special *condition-20/s1-val* *condition-20/s2-val*)) (let ((c (make-condition 'condition-20))) (values (notnot (typep c 'condition-20)) (condition-20/s1 c) (condition-20/s2 c) *condition-20/s1-val* *condition-20/s2-val*))) t 1 11 1 11) (deftest condition-20-slots.2 (let ((*condition-20/s1-val* 0) (*condition-20/s2-val* 10)) (declare (special *condition-20/s1-val* *condition-20/s2-val*)) (let ((c (make-condition 'condition-20 :i1 'x))) (values (notnot (typep c 'condition-20)) (condition-20/s1 c) (condition-20/s2 c) *condition-20/s1-val* *condition-20/s2-val*))) t x 11 0 11) (deftest condition-20-slots.3 (let ((*condition-20/s1-val* 0) (*condition-20/s2-val* 10)) (declare (special *condition-20/s1-val* *condition-20/s2-val*)) (let ((c (make-condition 'condition-20 :i2 'y))) (values (notnot (typep c 'condition-20)) (condition-20/s1 c) (condition-20/s2 c) *condition-20/s1-val* *condition-20/s2-val*))) t 1 y 1 10) (deftest condition-20-slots.4 (let ((*condition-20/s1-val* 0) (*condition-20/s2-val* 10)) (declare (special *condition-20/s1-val* *condition-20/s2-val*)) (let ((c (make-condition 'condition-20 :i2 'y :i1 'x))) (values (notnot (typep c 'condition-20)) (condition-20/s1 c) (condition-20/s2 c) *condition-20/s1-val* *condition-20/s2-val*))) t x y 0 10) ;;;;;;;;; tests of inheritance (define-condition-with-tests condition-21 (condition-4) nil) (deftest condition-21-slots.1 (let ((c (make-condition 'condition-21 :slot1 'a :slot2 'b))) (and (typep c 'condition-4) (typep c 'condition-21) (eqlt (condition-4/slot-1 c) 'a) (eqlt (condition-4/slot-2 c) 'b))) t) (define-condition-with-tests condition-22 (condition-4) ((slot3 :initarg :slot3 :reader condition-22/slot-3) (slot4 :initarg :slot4 :reader condition-22/slot-4))) (deftest condition-22-slots.1 (let ((c (make-condition 'condition-22 :slot1 'a :slot2 'b :slot3 'c :slot4 'd))) (and (typep c 'condition-4) (typep c 'condition-22) (eqlt (condition-4/slot-1 c) 'a) (eqlt (condition-4/slot-2 c) 'b) (eqlt (condition-22/slot-3 c) 'c) (eqlt (condition-22/slot-4 c) 'd) )) t) (define-condition-with-tests condition-23 (condition-5) nil) (deftest condition-23-slots.1 (let ((c (make-condition 'condition-23 :slot1 'a :slot2 'b))) (and (typep c 'condition-5) (typep c 'condition-23) (eqlt (condition-5/slot-1 c) 'a) (eqlt (condition-5/slot-2 c) 'b) )) t) (deftest condition-23-slots.2 (let ((c (make-condition 'condition-23 :slot1 'a))) (and (typep c 'condition-5) (typep c 'condition-23) (eqlt (condition-5/slot-1 c) 'a) (eqlt (condition-5/slot-2 c) 'y) )) t) (deftest condition-23-slots.3 (let ((c (make-condition 'condition-23 :slot2 'b))) (and (typep c 'condition-5) (typep c 'condition-23) (eqlt (condition-5/slot-1 c) 'x) (eqlt (condition-5/slot-2 c) 'b) )) t) (deftest condition-23-slots.4 (let ((c (make-condition 'condition-23))) (and (typep c 'condition-5) (typep c 'condition-23) (eqlt (condition-5/slot-1 c) 'x) (eqlt (condition-5/slot-2 c) 'y) )) t) (define-condition-with-tests condition-24 (condition-5) nil (:default-initargs :slot1 'z)) (deftest condition-24-slots.1 (let ((c (make-condition 'condition-24))) (and (typep c 'condition-5) (typep c 'condition-24) (eqlt (condition-5/slot-1 c) 'z) (eqlt (condition-5/slot-2 c) 'y) )) t) (deftest condition-24-slots.2 (let ((c (make-condition 'condition-24 :slot1 'a))) (and (typep c 'condition-5) (typep c 'condition-24) (eqlt (condition-5/slot-1 c) 'a) (eqlt (condition-5/slot-2 c) 'y) )) t) (deftest condition-24-slots.3 (let ((c (make-condition 'condition-24 :slot2 'a))) (and (typep c 'condition-5) (typep c 'condition-24) (eqlt (condition-5/slot-1 c) 'z) (eqlt (condition-5/slot-2 c) 'a) )) t) (deftest condition-24-slots.4 (let ((c (make-condition 'condition-24 :slot1 'b :slot2 'a))) (and (typep c 'condition-5) (typep c 'condition-24) (eqlt (condition-5/slot-1 c) 'b) (eqlt (condition-5/slot-2 c) 'a) )) t) ;;; Multiple inheritance (define-condition-with-tests condition-25a nil ((s1 :initarg :s1 :initform 'a :reader condition-25a/s1))) (define-condition-with-tests condition-25b nil ((s2 :initarg :s2 :initform 'b :reader condition-25b/s2))) (define-condition-with-tests condition-25 (condition-25a condition-25b) ((s3 :initarg :s3 :initform 'c :reader condition-25/s3))) (deftest condition-25-slots.1 (let ((c (make-condition 'condition-25))) (and (typep c 'condition-25a) (typep c 'condition-25b) (typep c 'condition-25) (eqlt (condition-25a/s1 c) 'a) (eqlt (condition-25b/s2 c) 'b) (eqlt (condition-25/s3 c) 'c))) t) (deftest condition-25-slots.2 (let ((c (make-condition 'condition-25 :s1 'x))) (and (typep c 'condition-25a) (typep c 'condition-25b) (typep c 'condition-25) (eqlt (condition-25a/s1 c) 'x) (eqlt (condition-25b/s2 c) 'b) (eqlt (condition-25/s3 c) 'c))) t) (deftest condition-25-slots.3 (let ((c (make-condition 'condition-25 :s2 'x))) (and (typep c 'condition-25a) (typep c 'condition-25b) (typep c 'condition-25) (eqlt (condition-25a/s1 c) 'a) (eqlt (condition-25b/s2 c) 'x) (eqlt (condition-25/s3 c) 'c))) t) (deftest condition-25-slots.4 (let ((c (make-condition 'condition-25 :s3 'x))) (and (typep c 'condition-25a) (typep c 'condition-25b) (typep c 'condition-25) (eqlt (condition-25a/s1 c) 'a) (eqlt (condition-25b/s2 c) 'b) (eqlt (condition-25/s3 c) 'x))) t) (deftest condition-25-slots.5 (let ((c (make-condition 'condition-25 :s3 'z :s2 'y :s1 'x))) (and (typep c 'condition-25a) (typep c 'condition-25b) (typep c 'condition-25) (eqlt (condition-25a/s1 c) 'x) (eqlt (condition-25b/s2 c) 'y) (eqlt (condition-25/s3 c) 'z))) t) ;;; (define-condition-with-tests condition-26a nil ((s1 :initarg :s1 :initform 'a :reader condition-26a/s1))) (define-condition-with-tests condition-26b (condition-26a) nil) (define-condition-with-tests condition-26c (condition-26a) nil) (define-condition-with-tests condition-26 (condition-26b condition-26c) nil) (deftest condition-26-slots.1 (let ((c (make-condition 'condition-26))) (and (typep c 'condition-26a) (typep c 'condition-26b) (typep c 'condition-26c) (typep c 'condition-26) (eqlt (condition-26a/s1 c) 'a))) t) (deftest condition-26-slots.2 (let ((c (make-condition 'condition-26 :s1 'x))) (and (typep c 'condition-26a) (typep c 'condition-26b) (typep c 'condition-26c) (typep c 'condition-26) (eqlt (condition-26a/s1 c) 'x))) t) ;;; Test that a slot reader is truly a generic function (define-condition-with-tests condition-27a nil ((s0 :initarg :s0 :initform 10 :reader condition-27a/s0) (s1 :initarg :s1 :initform 'a :reader condition-27/s1))) (define-condition-with-tests condition-27b nil ((s1 :initarg :s1 :initform 'a :reader condition-27/s1) (s2 :initarg :s2 :initform 16 :reader condition-27b/s2))) (deftest condition-27-slots.1 (let ((c (make-condition 'condition-27a))) (and (typep c 'condition-27a) (not (typep c 'condition-27b)) (eqlt (condition-27/s1 c) 'a))) t) (deftest condition-27-slots.2 (let ((c (make-condition 'condition-27b))) (and (typep c 'condition-27b) (not (typep c 'condition-27a)) (eqlt (condition-27/s1 c) 'a))) t) (deftest condition-27-reader-is-generic (notnot-mv (typep #'condition-27/s1 'generic-function)) t) ;;; More inheritance ;;; These test that condition slots are inherited like CLOS ;;; slots. It's not entirely clear to me if the standard ;;; demands this (one of the issues does, but that issue wasn't ;;; fully integrated into the standard.) #| (define-condition-with-tests condition-28a nil ((s1 :initarg :i1 :initform 'x :reader condition-28a/s1))) (define-condition-with-tests condition-28 (condition-28a) ((s1 :initarg :i1a :reader condition-28/s1))) (deftest condition-28-slots.1 (let ((c (make-condition 'condition-28))) (and (typep c 'condition-28a) (typep c 'condition-28) (eqlt (condition-28a/s1 c) 'x) (eqlt (condition-28/s1 c) 'x))) t) (deftest condition-28-slots.2 (let ((c (make-condition 'condition-28 :i1 'z))) (and (typep c 'condition-28a) (typep c 'condition-28) (eqlt (condition-28a/s1 c) 'z) (eqlt (condition-28/s1 c) 'z))) t) (deftest condition-28-slots.3 (let ((c (make-condition 'condition-28 :i1a 'w))) (and (typep c 'condition-28a) (typep c 'condition-28) (eqlt (condition-28a/s1 c) 'w) (eqlt (condition-28/s1 c) 'w))) t) (deftest condition-28-slots.4 (let ((c (make-condition 'condition-28 :i1 'y :i1a 'w))) (and (typep c 'condition-28a) (typep c 'condition-28) (eqlt (condition-28a/s1 c) 'y) (eqlt (condition-28/s1 c) 'y))) t) (deftest condition-28-slots.5 (let ((c (make-condition 'condition-28 :i1a 'y :i1 'w))) (and (typep c 'condition-28a) (typep c 'condition-28) (eqlt (condition-28a/s1 c) 'y) (eqlt (condition-28/s1 c) 'y))) t) |# ;;; Documentation ;;; Pitman says this should have been in the spec, but it isn't really ;;; (define-condition-with-tests condition-29 nil ;;; ((s1 :initarg :i1 :initform 'x ;;; :documentation "This is slot s1 in condition condition-29"))) (define-condition-with-tests condition-30 nil ((s1 :initarg :i1 :initform 'x)) (:documentation "This is class condition-30")) gcl27-2.7.0/ansi-tests/define-method-combination-long-form.lsp000066400000000000000000000241441454061450500241670ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jul 13 08:26:41 2003 ;;;; Contains: Tests of DEFINE-METHOD-COMBINATION (long form) (in-package :cl-test) (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defparameter *dmc-long-01* (define-method-combination mc-long-01 nil nil))) (report-and-ignore-errors (defgeneric dmc-long-gf-01 (x y) (:method-combination mc-long-01))) ) (deftest define-method-combination-long.01.1 (eqt *dmc-long-01* 'mc-long-01) t) ;;; The list of method groups specifiers for this method combination ;;; is empty, so no methods are valid. (deftest define-method-combination-long.01.2 (progn (eval '(defmethod dmc-long-gf-01 ((x t) (y t)) :foo)) (handler-case (eval '(dmc-long-gf-01 'a 'b)) (error () :caught))) :caught) ;;; A single method group with the * method group specifier (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defparameter *dmc-long-02* (define-method-combination mc-long-02 nil ((method-list *)) `(vector ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list))))) (report-and-ignore-errors (defgeneric dmc-long-gf-02 (x y) (:method-combination mc-long-02))) ) (deftest define-method-combination-long.02.1 (eqt *dmc-long-02* 'mc-long-02) t) (deftest define-method-combination-long.02.2 (progn (eval '(defmethod dmc-long-gf-02 ((x (eql 1)) (y integer)) 'a)) (eval '(defmethod dmc-long-gf-02 ((x integer) (y (eql 2))) 'b)) (eval '(defmethod dmc-long-gf-02 ((x integer) (y integer)) 'z)) (values (dmc-long-gf-02 0 0) (dmc-long-gf-02 1 0) (dmc-long-gf-02 0 2) (dmc-long-gf-02 1 2))) #(z) #(a z) #(b z) #(a b z)) (deftest define-method-combination-long.02.3 (signals-error (dmc-long-gf-02 nil nil) error) t) ;;; Same, but with :order parameter. ;;; Also, :description with a format string (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defparameter *dmc-long-03* (define-method-combination mc-long-03 nil ((method-list * :order :most-specific-first :description "This method has qualifiers ~A" )) `(vector ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list))))) (report-and-ignore-errors (defgeneric dmc-long-gf-03 (x y) (:method-combination mc-long-03))) ) (deftest define-method-combination-long.03.1 (eqt *dmc-long-03* 'mc-long-03) t) (deftest define-method-combination-long.03.2 (progn (eval '(defmethod dmc-long-gf-03 ((x (eql 1)) (y integer)) 'a)) (eval '(defmethod dmc-long-gf-03 ((x integer) (y (eql 2))) 'b)) (eval '(defmethod dmc-long-gf-03 ((x integer) (y integer)) 'z)) (values (dmc-long-gf-03 0 0) (dmc-long-gf-03 1 0) (dmc-long-gf-03 0 2) (dmc-long-gf-03 1 2))) #(z) #(a z) #(b z) #(a b z)) (deftest define-method-combination-long.03.3 (signals-error (dmc-long-gf-03 nil nil) error) t) ;;; Same, but with :order parameter :most-specific-last ;;; (and testing that the :order parameter is evaluated) (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defparameter *dmc-long-04* (let ((order :most-specific-last)) (define-method-combination mc-long-04 nil ((method-list * :order order)) `(vector ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list)))))) (report-and-ignore-errors (defgeneric dmc-long-gf-04 (x y) (:method-combination mc-long-04))) ) (deftest define-method-combination-long.04.1 (eqt *dmc-long-04* 'mc-long-04) t) (deftest define-method-combination-long.04.2 (progn (eval '(defmethod dmc-long-gf-04 ((x (eql 1)) (y integer)) 'a)) (eval '(defmethod dmc-long-gf-04 ((x integer) (y (eql 2))) 'b)) (eval '(defmethod dmc-long-gf-04 ((x integer) (y integer)) 'z)) (values (dmc-long-gf-04 0 0) (dmc-long-gf-04 1 0) (dmc-long-gf-04 0 2) (dmc-long-gf-04 1 2))) #(z) #(z a) #(z b) #(z b a)) (deftest define-method-combination-long.04.3 (signals-error (dmc-long-gf-04 nil nil) error) t) ;;; Empty qualifier list (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defparameter *dmc-long-05* (define-method-combination mc-long-05 nil ((method-list nil) (ignored-methods *)) (declare (ignorable ignored-methods)) `(vector ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list))))) (report-and-ignore-errors (defgeneric dmc-long-gf-05 (x y) (:method-combination mc-long-05))) ) (deftest define-method-combination-long.05.1 (eqt *dmc-long-05* 'mc-long-05) t) (deftest define-method-combination-long.05.2 (progn (eval '(defmethod dmc-long-gf-05 ((x (eql 1)) (y integer)) 'a)) (eval '(defmethod dmc-long-gf-05 ((x integer) (y (eql 2))) 'b)) (eval '(defmethod dmc-long-gf-05 ((x integer) (y integer)) 'z)) (eval '(defmethod dmc-long-gf-05 foo ((x t) (y t)) 'bad)) (values (dmc-long-gf-05 nil nil) (dmc-long-gf-05 0 0) (dmc-long-gf-05 1 0) (dmc-long-gf-05 0 2) (dmc-long-gf-05 1 2))) #() #(z) #(a z) #(b z) #(a b z)) ;;; :required (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defparameter *dmc-long-06* (define-method-combination mc-long-06 nil ((method-list nil :required t) (ignored-methods *)) (declare (ignorable ignored-methods)) `(vector ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list))))) (report-and-ignore-errors (defgeneric dmc-long-gf-06 (x y) (:method-combination mc-long-06))) ) (deftest define-method-combination-long.06.1 (eqt *dmc-long-06* 'mc-long-06) t) (deftest define-method-combination-long.06.2 (progn (eval '(defmethod dmc-long-gf-06 ((x (eql 1)) (y integer)) 'a)) (eval '(defmethod dmc-long-gf-06 ((x integer) (y (eql 2))) 'b)) (eval '(defmethod dmc-long-gf-06 ((x integer) (y integer)) 'z)) (eval '(defmethod dmc-long-gf-06 foo ((x t) (y t)) 'bad)) (values (dmc-long-gf-06 0 0) (dmc-long-gf-06 1 0) (dmc-long-gf-06 0 2) (dmc-long-gf-06 1 2))) #(z) #(a z) #(b z) #(a b z)) (deftest define-method-combination-long.06.3 (signals-error-always (dmc-long-gf-06 nil nil) error) t t) ;;; Non-empty lambda lists (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defparameter *dmc-long-07* (define-method-combination mc-long-07 (p1 p2) ((method-list *)) `(vector ',p1 ',p2 ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list))))) (report-and-ignore-errors (defgeneric dmc-long-gf-07 (x y) (:method-combination mc-long-07 1 2))) ) (deftest define-method-combination-long.07.1 (eqt *dmc-long-07* 'mc-long-07) t) (deftest define-method-combination-long.07.2 (progn (eval '(defmethod dmc-long-gf-07 ((x (eql 1)) (y integer)) 'a)) (eval '(defmethod dmc-long-gf-07 ((x integer) (y (eql 2))) 'b)) (eval '(defmethod dmc-long-gf-07 ((x integer) (y integer)) 'z)) (values (dmc-long-gf-07 0 0) (dmc-long-gf-07 1 0) (dmc-long-gf-07 0 2) (dmc-long-gf-07 1 2))) #(1 2 z) #(1 2 a z) #(1 2 b z) #(1 2 a b z)) (deftest define-method-combination-long.07.3 (signals-error (dmc-long-gf-07 nil) error) t) (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defparameter *dmc-long-08* (define-method-combination mc-long-08 (p1 &optional p2 p3) ((method-list *)) `(vector ',p1 ',p2 ',p3 ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list))))) (report-and-ignore-errors (defgeneric dmc-long-gf-08 (x y) (:method-combination mc-long-08 1 2))) ) (deftest define-method-combination-long.08.1 (eqt *dmc-long-08* 'mc-long-08) t) (deftest define-method-combination-long.08.2 (progn (eval '(defmethod dmc-long-gf-08 ((x (eql 1)) (y integer)) 'a)) (eval '(defmethod dmc-long-gf-08 ((x integer) (y (eql 2))) 'b)) (eval '(defmethod dmc-long-gf-08 ((x integer) (y integer)) 'z)) (values (dmc-long-gf-08 0 0) (dmc-long-gf-08 1 0) (dmc-long-gf-08 0 2) (dmc-long-gf-08 1 2))) #(1 2 nil z) #(1 2 nil a z) #(1 2 nil b z) #(1 2 nil a b z)) (deftest define-method-combination-long.08.3 (signals-error (dmc-long-gf-08 nil) error) t) (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defparameter *dmc-long-09* (define-method-combination mc-long-09 (p1 &key p2 p3) ((method-list *)) `(vector ',p1 ',p2 ',p3 ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list))))) (report-and-ignore-errors (defgeneric dmc-long-gf-09 (x y) (:method-combination mc-long-09 1 :p3 3))) ) (deftest define-method-combination-long.09.1 (eqt *dmc-long-09* 'mc-long-09) t) (deftest define-method-combination-long.09.2 (progn (eval '(defmethod dmc-long-gf-09 ((x (eql 1)) (y integer)) 'a)) (eval '(defmethod dmc-long-gf-09 ((x integer) (y (eql 2))) 'b)) (eval '(defmethod dmc-long-gf-09 ((x integer) (y integer)) 'z)) (values (dmc-long-gf-09 0 0) (dmc-long-gf-09 1 0) (dmc-long-gf-09 0 2) (dmc-long-gf-09 1 2))) #(1 nil 3 z) #(1 nil 3 a z) #(1 nil 3 b z) #(1 nil 3 a b z)) (deftest define-method-combination-long.09.3 (signals-error (dmc-long-gf-09 nil) error) t) (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defparameter *dmc-long-10* (define-method-combination mc-long-10 (p1 &rest p2) ((method-list *)) `(vector ',p1 ',p2 ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list))))) (report-and-ignore-errors (defgeneric dmc-long-gf-10 (x y) (:method-combination mc-long-10 1 2 3 4))) ) (deftest define-method-combination-long.10.1 (eqt *dmc-long-10* 'mc-long-10) t) (deftest define-method-combination-long.10.2 (progn (eval '(defmethod dmc-long-gf-10 ((x (eql 1)) (y integer)) 'a)) (eval '(defmethod dmc-long-gf-10 ((x integer) (y (eql 2))) 'b)) (eval '(defmethod dmc-long-gf-10 ((x integer) (y integer)) 'z)) (values (dmc-long-gf-10 0 0) (dmc-long-gf-10 1 0) (dmc-long-gf-10 0 2) (dmc-long-gf-10 1 2))) #(1 (2 3 4) z) #(1 (2 3 4) a z) #(1 (2 3 4) b z) #(1 (2 3 4) a b z)) (deftest define-method-combination-long.10.3 (signals-error (dmc-long-gf-10 nil) error) t) gcl27-2.7.0/ansi-tests/define-method-combination.lsp000066400000000000000000000120561454061450500222700ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jun 15 10:49:39 2003 ;;;; Contains: Tests of DEFINE-METHOD-COMBINATION (in-package :cl-test) (defclass dmc-class-01a () ()) (defclass dmc-class-01b (dmc-class-01a) ()) (defclass dmc-class-01c (dmc-class-01a) ()) (defclass dmc-class-01d (dmc-class-01b dmc-class-01c) ()) (defclass dmc-class-01e (dmc-class-01c dmc-class-01b) ()) (defclass dmc-class-01f (dmc-class-01d) ()) (defclass dmc-class-01g (dmc-class-01a) ()) (defclass dmc-class-01h (dmc-class-01f dmc-class-01g) ()) (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defvar *dmc-times* (define-method-combination times :documentation "Multiplicative method combination, version 1" :operator *)) (defgeneric dmc-gf-01 (x) (:method-combination times)) (defmethod dmc-gf-01 times ((x integer)) 2) (defmethod dmc-gf-01 times ((x rational)) 3) (defmethod dmc-gf-01 times ((x real)) 5) (defmethod dmc-gf-01 times ((x number)) 7) (defmethod dmc-gf-01 times ((x complex)) 11) )) (deftest define-method-combination-01.1 (values (dmc-gf-01 1) (dmc-gf-01 1/2) (dmc-gf-01 1.0) (dmc-gf-01 #c(1 2))) 210 105 35 77) (deftest define-method-combination-01.2 (handler-case (eval '(locally (declare (optimize (safety 3))) (dmc-gf-01 'x))) (error () :good)) :good) (deftest define-method-combination-01.3 *dmc-times* times) (deftest define-method-combination-01.4 (let ((doc (documentation *dmc-times* 'method-combination))) (or (null doc) (equalt doc "Multiplicative method combination, version 1"))) t) (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defgeneric dmc-gf-02 (x) (:method-combination times)) (defmethod dmc-gf-02 times ((x integer)) 2) (defmethod dmc-gf-02 :around ((x rational)) (1- (call-next-method))) (defmethod dmc-gf-02 times ((x real)) 3) (defmethod dmc-gf-02 times ((x number)) 5) (defmethod dmc-gf-02 :around ((x (eql 1.0s0))) 1) )) (deftest define-method-combination-02.1 (values (dmc-gf-02 1) (dmc-gf-02 1/3) (dmc-gf-02 1.0s0) (dmc-gf-02 13.0) (dmc-gf-02 #c(1 2))) 29 14 1 15 5) (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defgeneric dmc-gf-03 (x) (:method-combination times)))) (deftest define-method-combination-03.1 (prog1 (handler-case (progn (eval '(defmethod dmc-gf-03 ((x integer)) t)) (eval '(dmc-gf-03 1)) :bad) (error () :good)) (dolist (meth (compute-applicable-methods #'dmc-gf-03 (list 1))) (remove-method #'dmc-gf-03 meth))) :good) (deftest define-method-combination-03.2 (prog1 (handler-case (progn (eval '(defmethod dmc-gf-03 :before ((x cons)) t)) (eval '(dmc-gf-03 (cons 'a 'b))) :bad) (error () :good)) (dolist (meth (compute-applicable-methods #'dmc-gf-03 (list '(a)))) (remove-method #'dmc-gf-03 meth))) :good) (deftest define-method-combination-03.3 (prog1 (handler-case (progn (eval '(defmethod dmc-gf-03 :after ((x symbol)) t)) (eval '(dmc-gf-03 'a)) :bad) (error () :good)) (dolist (meth (compute-applicable-methods #'dmc-gf-03 (list 'a))) (remove-method #'dmc-gf-03 meth))) :good) (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (define-method-combination times2 :operator * :identity-with-one-argument t) (defgeneric dmc-gf-04 (x) (:method-combination times2)) (defmethod dmc-gf-04 times2 ((x dmc-class-01b)) 2) (defmethod dmc-gf-04 times2 ((x dmc-class-01c)) 3) (defmethod dmc-gf-04 times2 ((x dmc-class-01d)) 5) (defmethod dmc-gf-04 times2 ((x symbol)) nil) )) (deftest define-method-combination-04.1 (dmc-gf-04 (make-instance 'dmc-class-01h)) 30) (deftest define-method-combination-04.2 (dmc-gf-04 (make-instance 'dmc-class-01e)) 6) (deftest define-method-combination-04.3 (dmc-gf-04 'a) nil) (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defvar *dmc-times-5* (define-method-combination times-5 :operator *)))) (deftest define-method-combination-05.1 (let* ((doc1 (setf (documentation *dmc-times-5* 'method-combination) "foo")) (doc2 (documentation *dmc-times-5* 'method-combination))) (values doc1 (or (null doc2) (equalt doc2 "foo")))) "foo" t) ;; Operator name defaults to the method combination name. (eval-when (:load-toplevel :compile-toplevel :execute) (defun times-7 (&rest args) (apply #'* args)) (report-and-ignore-errors (defvar *dmc-times-7* (define-method-combination times-7)) (defgeneric dmc-gf-07 (x) (:method-combination times)) (defmethod dmc-gf-07 times ((x integer)) 2) (defmethod dmc-gf-07 times ((x rational)) 3) (defmethod dmc-gf-07 times ((x real)) 5) (defmethod dmc-gf-07 times ((x number)) 7) (defmethod dmc-gf-07 times ((x complex)) 11) )) (deftest define-method-combination-07.1 (values (dmc-gf-07 1) (dmc-gf-07 1/2) (dmc-gf-07 1.0) (dmc-gf-07 #c(1 2))) 210 105 35 77) gcl27-2.7.0/ansi-tests/define-modify-macro.lsp000066400000000000000000000051471454061450500211010ustar00rootroot00000000000000;-*- 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 ;;; (signals-error (define-modify-macro) program-error) ;;; t) ;;; ;;; (deftest define-modify-macro.error.2 ;;; (signals-error (define-modify-macro dfm-error-1) program-error) ;;; t) ;;; ;;; (deftest define-modify-macro.error.3 ;;; (signals-error (define-modify-macro dfm-error-2 ()) program-error) ;;; t) ;;; ;;; (deftest define-modify-macro.error.4 ;;; (signals-error (define-modify-macro dfm-error-2 () nil "Documentation" ;;; "extra illegal argument") ;;; program-error) ;;; t) (def-macro-test define-modify-macro.error.1 (define-modify-macro nonexistent-modify-macro () foo)) ;;; Documentation tests (deftest define-modify-macro.documentation.1 (let ((sym (gensym))) (eval `(define-modify-macro ,sym (&optional (delta 1)) +)) (values (documentation sym 'function) (documentation (macro-function sym) 'function) (documentation (macro-function sym) t))) nil nil nil) (deftest define-modify-macro.documentation.2 (let ((sym (gensym)) (doc "DMM-DOC")) (eval `(define-modify-macro ,sym (&optional (delta 1)) + ,doc)) (values (equalt doc (or (documentation sym 'function) doc)) (equalt doc (or (documentation (macro-function sym) 'function) doc)) (equalt doc (or (documentation (macro-function sym) t) doc)))) t t t) gcl27-2.7.0/ansi-tests/define-setf-expander.lsp000066400000000000000000000063031454061450500212530ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 17:19:35 2003 ;;;; Contains: Tests of DEFINE-SETF-EXPANDER (in-package :cl-test) (def-macro-test define-setf-expander.error.1 (define-setf-expander nonexistent-access-fn (x))) ;;; Non-error tests (defun my-car (x) (car x)) (ignore-errors (defparameter *define-setf-expander-vals.1* (multiple-value-list (define-setf-expander my-car (place &environment env) (multiple-value-bind (temps vals stores set-form get-form) (get-setf-expansion place env) (declare (ignore stores set-form)) (let ((store (gensym)) (temp (gensym))) (values `(,@temps ,temp) `(,@vals ,get-form) `(,store) `(progn (rplaca ,temp ,store) ,store) `(my-car ,temp)))))))) (deftest define-setf-expander.1 *define-setf-expander-vals.1* (my-car)) (deftest define-setf-expander.2 (let ((a (list 'x 'y))) (values (copy-list a) (my-car a) (setf (my-car a) 'z) a)) (x y) x z (z y)) (deftest define-setf-expander.3 (multiple-value-bind (temps vals stores set get) (get-setf-expansion '(my-car x)) (values (and (listp temps) (notnot (every #'symbolp temps))) (notnot (listp vals)) (and (listp stores) (= (length stores) 1) (notnot (every #'symbolp stores))) (equalt get `(my-car ,(second (second set)))))) t t t t) (deftest define-setf-expander.4 (let ((a (list (list 1)))) (values (copy-tree a) (my-car (my-car a)) (setf (my-car (my-car a)) 2) a)) ((1)) 1 2 ((2))) (defun my-assoc (key alist) (loop for pair in alist when (and (consp pair) (eql key (car pair))) return pair)) (ignore-errors (define-setf-expander my-assoc (key place &environment env) (multiple-value-bind (temps vals stores set-form get-form) (get-setf-expansion place env) (let ((store (gensym)) (key-temp (gensym)) (pair-temp (gensym)) (place-temp (gensym))) (return-from my-assoc (values `(,@temps ,key-temp ,place-temp ,pair-temp) `(,@vals ,key ,get-form (my-assoc ,key-temp ,place-temp)) `(,store) `(if (null ,pair-temp) (let ((,(car stores) (cons (cons ,key-temp ,store) ,place-temp))) ,set-form ,store) (setf (cdr ,pair-temp) ,store)) `(cdr ,pair-temp))))))) (deftest define-setf-expander.5 (let ((x nil)) (values (copy-tree x) (setf (my-assoc 'foo x) 1) (copy-tree x) (setf (my-assoc 'foo x) 2) (copy-tree x) (setf (my-assoc 'bar x) 3) (copy-tree x))) nil 1 ((foo . 1)) 2 ((foo . 2)) 3 ((bar . 3) (foo . 2))) (deftest define-setf-expander.6 (let ((n (gensym)) (doc "D-S-EX.6")) (assert (null (documentation n 'setf))) (assert (eql (eval `(define-setf-expander ,n () ,doc (values nil nil nil nil nil))) n)) (or (documentation n 'setf) doc)) "D-S-EX.6") (deftest define-setf-expander.7 (let ((n (gensym)) (doc "D-S-EX.7")) (assert (null (documentation n 'setf))) (assert (eql (eval `(define-setf-expander ,n () (values nil nil nil nil nil))) n)) (assert (null (documentation n 'setf))) (values (setf (documentation n 'setf) doc) (or (documentation n 'setf) doc))) "D-S-EX.7" "D-S-EX.7") gcl27-2.7.0/ansi-tests/define-symbol-macro.lsp000066400000000000000000000012531454061450500211110ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 12:55:05 2003 ;;;; Contains: Tests of DEFINE-SYMBOL-MACRO (in-package :cl-test) (deftest define-symbol-macro.error.1 (signals-error (funcall (macro-function 'define-symbol-macro)) program-error) t) (deftest define-symbol-macro.error.2 (signals-error (funcall (macro-function 'define-symbol-macro) '(define-symbol-macro nonexistent-symbol-macro nil)) program-error) t) (deftest define-symbol-macro.error.3 (signals-error (funcall (macro-function 'define-symbol-macro) '(define-symbol-macro nonexistent-symbol-macro nil) nil nil) program-error) t) gcl27-2.7.0/ansi-tests/defmacro.lsp000066400000000000000000000211731454061450500170400ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 12:35:24 2003 ;;;; Contains: Tests of DEFMACRO (in-package :cl-test) (deftest defmacro.error.1 (signals-error (funcall (macro-function 'defmacro)) program-error) t) (deftest defmacro.error.2 (signals-error (funcall (macro-function 'defmacro) '(defmacro nonexistent-macro ())) program-error) t) (deftest defmacro.error.3 (signals-error (funcall (macro-function 'defmacro) '(defmacro nonexistent-macro ()) nil nil) program-error) t) ;;; FIXME ;;; Need to add non-error tests (deftest defmacro.1 (progn (assert (eq (defmacro defmacro.1-macro (x y) `(list 1 ,x 2 ,y 3)) 'defmacro.1-macro)) (assert (macro-function 'defmacro.1-macro)) (eval `(defmacro.1-macro 'a 'b))) (1 a 2 b 3)) (deftest defmacro.2 (progn (assert (eq (defmacro defmacro.2-macro (x y) (return-from defmacro.2-macro `(cons ,x ,y))) 'defmacro.2-macro)) (assert (macro-function 'defmacro.2-macro)) (eval `(defmacro.2-macro 'a 'b))) (a . b)) ;;; The macro function is defined in the lexical environment in which ;;; the defmacro form occurs. (deftest defmacro.3 (let (fn) (let ((x 0)) (setq fn #'(lambda (n) (setq x n))) (defmacro defmacro.3-macro () `',x)) (values (eval '(defmacro.3-macro)) (funcall fn 'a) (eval '(defmacro.3-macro)))) 0 a a) ;;; Declarations are allowed. ;;; Free special declarations do not apply to the forms ;;; in the lambda list (deftest defmacro.4 (let ((y :good)) (assert (eq (defmacro defmacro.4-macro (&optional (x y)) (declare (special y)) x) 'defmacro.4-macro)) (let ((y :bad)) (declare (special y)) (values (macroexpand-1 '(defmacro.4-macro))))) :good) (deftest defmacro.5 (progn (assert (eq (defmacro defmacro.5-macro () (declare) (declare) "a doc string" (declare) t) 'defmacro.5-macro)) (eval `(defmacro.5-macro))) t) ;;; &whole argument, top level (deftest defmacro.6 (progn (defmacro defmacro.6-macro (&whole w arg) `(list ',w ',arg)) (eval `(defmacro.6-macro x))) ((defmacro.6-macro x) x)) ;;; &whole argument in destructuring (deftest defmacro.7 (progn (defmacro defmacro.7-macro (arg1 (&whole w arg2)) `(list ',w ',arg1 ',arg2)) (eval `(defmacro.7-macro x (y)))) ((y) x y)) ;;; keyword parameters (deftest defmacro.8 (progn (defmacro defmacro.8-macro (&key foo bar) `(list ',foo ',bar)) (mapcar #'eval '((defmacro.8-macro :foo x) (defmacro.8-macro :bar y) (defmacro.8-macro :bar a :foo b) (defmacro.8-macro :bar a :foo b :bar c)))) ((x nil) (nil y) (b a) (b a))) ;;; keyword parameters with default value (deftest defmacro.9 (progn (defmacro defmacro.9-macro (&key (foo 1) (bar 2)) `(list ',foo ',bar)) (mapcar #'eval '((defmacro.9-macro :foo x) (defmacro.9-macro :bar y) (defmacro.9-macro :foo nil) (defmacro.9-macro :bar nil) (defmacro.9-macro :bar a :foo b) (defmacro.9-macro :bar a :foo b :bar c)))) ((x 2) (1 y) (nil 2) (1 nil) (b a) (b a))) ;;; keyword parameters with supplied-p parameter (deftest defmacro.10 (progn (defmacro defmacro.10-macro (&key (foo 1 foo-p) (bar 2 bar-p)) `(list ',foo ,(notnot foo-p) ',bar ,(notnot bar-p))) (mapcar #'eval '((defmacro.10-macro) (defmacro.10-macro :foo x) (defmacro.10-macro :bar y) (defmacro.10-macro :foo nil) (defmacro.10-macro :bar nil) (defmacro.10-macro :foo x :bar y) (defmacro.10-macro :bar y :foo x) (defmacro.10-macro :bar a :bar b) (defmacro.10-macro :foo a :foo b)))) ((1 nil 2 nil) (x t 2 nil) (1 nil y t) (nil t 2 nil) (1 nil nil t) (x t y t) (x t y t) (1 nil a t) (a t 2 nil))) ;;; key arguments in destructuring (deftest defmacro.11 (progn (defmacro defmacro.11-macro ((&key foo bar)) `(list ',foo ',bar)) (mapcar #'eval '((defmacro.11-macro nil) (defmacro.11-macro (:foo x)) (defmacro.11-macro (:bar y)) (defmacro.11-macro (:foo x :bar y :foo z)) (defmacro.11-macro (:bar y :bar z :foo x))))) ((nil nil) (x nil) (nil y) (x y) (x y))) ;;; key arguments in destructuring and defaults (deftest defmacro.12 (progn (let ((foo-default 1) (bar-default 2)) (defmacro defmacro.12-macro ((&key (foo foo-default) (bar bar-default))) `(list ',foo ',bar))) (mapcar #'eval '((defmacro.12-macro nil) (defmacro.12-macro (:foo x)) (defmacro.12-macro (:bar y)) (defmacro.12-macro (:foo x :bar y :foo z)) (defmacro.12-macro (:bar y :bar z :foo x))))) ((1 2) (x 2) (1 y) (x y) (x y))) ;;; key arguments in destructuring and supplied-p parameter (deftest defmacro.13 (progn (let ((foo-default 1) (bar-default 2)) (defmacro defmacro.13-macro ((&key (foo foo-default foo-p) (bar bar-default bar-p))) `(list ',foo ,(notnot foo-p) ',bar ,(notnot bar-p)))) (mapcar #'eval '((defmacro.13-macro nil) (defmacro.13-macro (:foo x)) (defmacro.13-macro (:bar y)) (defmacro.13-macro (:foo nil :bar nil :foo 4 :bar 14)) (defmacro.13-macro (:foo 1 :bar 2)) (defmacro.13-macro (:foo x :bar y :foo z)) (defmacro.13-macro (:bar y :bar z :foo x))))) ((1 nil 2 nil) (x t 2 nil) (1 nil y t) (nil t nil t) (1 t 2 t) (x t y t) (x t y t))) ;;; rest parameter (deftest defmacro.14 (progn (defmacro defmacro.14-macro (foo &rest bar) `(list ',foo ',bar)) (mapcar #'eval '((defmacro.14-macro x) (defmacro.14-macro x y) (defmacro.14-macro x y z)))) ((x nil) (x (y)) (x (y z)))) ;;; rest parameter with destructuring (deftest defmacro.15 (progn (defmacro defmacro.15-macro (foo &rest (bar . baz)) `(list ',foo ',bar ',baz)) (eval '(defmacro.15-macro x y z))) (x y (z))) ;;; rest parameter w. whole (deftest defmacro.16 (progn (defmacro defmacro.16-macro (&whole w foo &rest bar) `(list ',w ',foo ',bar)) (mapcar #'eval '((defmacro.16-macro x) (defmacro.16-macro x y) (defmacro.16-macro x y z)))) (((defmacro.16-macro x) x nil) ((defmacro.16-macro x y) x (y)) ((defmacro.16-macro x y z) x (y z)))) ;;; env parameter (deftest defmacro.17 (progn (defmacro defmacro.17-macro (x &environment env) `(quote ,(macroexpand x env))) (eval `(macrolet ((%m () :good)) (defmacro.17-macro (%m))))) :good) (deftest defmacro.17a (progn (defmacro defmacro.17a-macro (&environment env x) `(quote ,(macroexpand x env))) (eval `(macrolet ((%m () :good)) (defmacro.17a-macro (%m))))) :good) ;;; &optional with supplied-p parameter ;;; Note: this is required to be T if the parameter is present (3.4.4.1.2) (deftest defmacro.18 (progn (defmacro defmacro.18-macro (x &optional (y 'a y-p) (z 'b z-p)) `(list ',x ',y ',y-p ',z ',z-p)) (mapcar #'eval '((defmacro.18-macro p) (defmacro.18-macro p q) (defmacro.18-macro p q r)))) ((p a nil b nil) (p q t b nil) (p q t r t))) ;;; Optional with destructuring (deftest defmacro.19 (progn (defmacro defmacro.19-macro (&optional ((x . y) '(a . b))) `(list ',x ',y)) (mapcar #'eval '((defmacro.19-macro) (defmacro.19-macro (c d))))) ((a b) (c (d)))) ;;; Allow other keys (deftest defmacro.20 (progn (defmacro defmacro.20-macro (&key x y z &allow-other-keys) `(list ',x ',y ',z)) (mapcar #'eval '((defmacro.20-macro) (defmacro.20-macro :x a) (defmacro.20-macro :y b) (defmacro.20-macro :z c) (defmacro.20-macro :x a :y b) (defmacro.20-macro :z c :y b) (defmacro.20-macro :z c :x a) (defmacro.20-macro :z c :x a :y b) (defmacro.20-macro nil nil) (defmacro.20-macro :allow-other-keys nil) (defmacro.20-macro :allow-other-keys nil :foo bar) (defmacro.20-macro :z c :z nil :x a :abc 0 :y b :x t)))) ((nil nil nil) (a nil nil) (nil b nil) (nil nil c) (a b nil) (nil b c) (a nil c) (a b c) (nil nil nil) (nil nil nil) (nil nil nil) (a b c))) (deftest defmacro.21 (progn (defmacro defmacro.21-macro (&key x y z) `(list ',x ',y ',z)) (mapcar #'eval '((defmacro.21-macro) (defmacro.21-macro :x a) (defmacro.21-macro :y b) (defmacro.21-macro :z c) (defmacro.21-macro :x a :y b) (defmacro.21-macro :z c :y b) (defmacro.21-macro :z c :x a) (defmacro.21-macro :z c :x a :y b) (defmacro.21-macro :allow-other-keys nil) (defmacro.21-macro :allow-other-keys t :foo bar)))) ((nil nil nil) (a nil nil) (nil b nil) (nil nil c) (a b nil) (nil b c) (a nil c) (a b c) (nil nil nil) (nil nil nil))) gcl27-2.7.0/ansi-tests/defmethod.lsp000066400000000000000000000154541454061450500172240ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jun 9 07:02:53 2005 ;;;; Contains: Separate tests for DEFMETHOD (in-package :cl-test) (deftest defmethod.1 (let ((sym (gensym))) (values (typep* (eval `(defmethod ,sym (x) (list x))) 'standard-method) (typep* (fdefinition sym) 'standard-generic-function) (funcall sym 1))) t t (1)) (deftest defmethod.2 (let* ((sym (gensym)) (method (eval `(defmethod ,sym ((x integer)) (list x))))) (values (typep* method 'standard-method) (typep* (fdefinition sym) 'standard-generic-function) (funcall sym 1))) t t (1)) (deftest defmethod.3 (let* ((sym (gensym)) (method (eval `(let ((x 0)) (defmethod ,sym ((x (eql (incf x)))) (list x)))))) (values (typep* method 'standard-method) (typep* (fdefinition sym) 'standard-generic-function) (funcall sym 1) (funcall sym 1))) t t (1) (1)) (deftest defmethod.4 (let* ((sym (gensym)) (method (eval `(defmethod (setf ,sym) ((x t) (y cons)) (setf (car y) x))))) (values (typep* method 'standard-method) (fboundp sym) (typep* (fdefinition `(setf ,sym)) 'standard-generic-function) (let ((x (cons 1 2))) (list (funcall (fdefinition `(setf ,sym)) 3 x) x)))) t nil t (3 (3 . 2))) (deftest defmethod.5 (let* ((sym (gensym)) (method (eval `(defmethod ,sym ((x integer)) (return-from ,sym (list x)))))) (values (typep* method 'standard-method) (typep* (fdefinition sym) 'standard-generic-function) (funcall sym 1))) t t (1)) (deftest defmethod.6 (let* ((sym (gensym)) (method (eval `(defmethod (setf ,sym) ((x t) (y cons)) (return-from ,sym (setf (car y) x)))))) (values (typep* method 'standard-method) (fboundp sym) (typep* (fdefinition `(setf ,sym)) 'standard-generic-function) (let ((x (cons 1 2))) (list (funcall (fdefinition `(setf ,sym)) 3 x) x)))) t nil t (3 (3 . 2))) (deftest defmethod.7 (let* ((sym (gensym)) (method (eval `(defmethod ,sym ((x integer) &aux (y (list x))) y)))) (values (typep* method 'standard-method) (typep* (fdefinition sym) 'standard-generic-function) (funcall sym 1))) t t (1)) (deftest defmethod.8 (let* ((sym (gensym)) (method (eval `(defmethod ,sym ((x integer) &key z) (list x z))))) (values (typep* method 'standard-method) (typep* (fdefinition sym) 'standard-generic-function) (funcall sym 1) (funcall sym 2 :z 3) (funcall sym 4 :allow-other-keys nil) (funcall sym 5 :allow-other-keys t :bogus 17) (funcall sym 6 :allow-other-keys t :allow-other-keys nil :bogus 17) )) t t (1 nil) (2 3) (4 nil) (5 nil) (6 nil)) (deftest defmethod.9 (let* ((sym (gensym)) (method (eval `(defmethod ,sym ((x integer) &key (z :missing)) (list x z))))) (values (typep* method 'standard-method) (typep* (fdefinition sym) 'standard-generic-function) (funcall sym 1) (funcall sym 2 :z 3) (funcall sym 4 :allow-other-keys nil) )) t t (1 :missing) (2 3) (4 :missing)) (deftest defmethod.10 (let* ((sym (gensym)) (method (eval `(defmethod ,sym ((x integer) &key (z :missing z-p)) (list x z (notnot z-p)))))) (values (typep* method 'standard-method) (typep* (fdefinition sym) 'standard-generic-function) (funcall sym 1) (funcall sym 2 :z 3) (funcall sym 4 :allow-other-keys nil) )) t t (1 :missing nil) (2 3 t) (4 :missing nil)) (deftest defmethod.11 (let* ((sym (gensym)) (method (eval `(defmethod ,sym ((x integer) &rest z) (list x z))))) (values (typep* method 'standard-method) (typep* (fdefinition sym) 'standard-generic-function) (funcall sym 1) (funcall sym 2 3) )) t t (1 nil) (2 (3))) ;;; Error cases ;;; Lambda liss not congruent (deftest defmethod.error.1 (let ((sym (gensym))) (eval `(defgeneric ,sym (x y))) (eval `(signals-error (defmethod ,sym ((x t)) x) error))) t) (deftest defmethod.error.2 (let ((sym (gensym))) (eval `(defgeneric ,sym (x y))) (eval `(signals-error (defmethod ,sym ((x t) (y t) (z t)) (list x y z)) error))) t) (deftest defmethod.error.3 (let ((sym (gensym))) (eval `(defgeneric ,sym (x y &optional z))) (eval `(signals-error (defmethod ,sym ((x t) (y t) (z t)) (list x y z)) error))) t) (deftest defmethod.error.4 (let ((sym (gensym))) (eval `(defgeneric ,sym (x y &optional z))) (eval `(signals-error (defmethod ,sym ((x t) (y t) &optional) (list x y)) error))) t) (deftest defmethod.error.5 (let ((sym (gensym))) (eval `(defgeneric ,sym (x y &optional z))) (eval `(signals-error (defmethod ,sym ((x t) (y t) &optional z w) (list x y z w)) error))) t) (deftest defmethod.error.6 (let ((sym (gensym))) (eval `(defgeneric ,sym (x &rest z))) (eval `(signals-error (defmethod ,sym ((x t)) (list x)) error))) t) (deftest defmethod.error.7 (let ((sym (gensym))) (eval `(defgeneric ,sym (x))) (eval `(signals-error (defmethod ,sym ((x t) &rest z) (list x z)) error))) t) (deftest defmethod.error.8 (let ((sym (gensym))) (eval `(defgeneric ,sym (x &key z))) (eval `(signals-error (defmethod ,sym ((x t)) (list x)) error))) t) (deftest defmethod.error.9 (let ((sym (gensym))) (eval `(defgeneric ,sym (x))) (eval `(signals-error (defmethod ,sym ((x t) &key z) (list x z)) error))) t) (deftest defmethod.error.10 (let ((sym (gensym))) (eval `(defgeneric ,sym (x &key z))) (eval `(signals-error (defmethod ,sym ((x t) &key) x) error))) t) (deftest defmethod.error.11 (let ((sym (gensym))) (eval `(defgeneric ,sym (x &key))) (eval `(signals-error (defmethod ,sym ((x t)) x) error))) t) (deftest defmethod.error.12 (let ((sym (gensym))) (eval `(defgeneric ,sym (x))) (eval `(signals-error (defmethod ,sym ((x t) &key) x) error))) t) ;;; Calling the implicitly defined generic function (deftest defmethod.error.13 (let ((sym (gensym))) (eval `(locally (declare (optimize safety)) (defmethod ,sym ((x t)) x))) (values (eval `(signals-error (,sym) program-error)) (eval `(signals-error (,sym 1 2) program-error)))) t t) (deftest defmethod.error.14 (let ((sym (gensym))) (eval `(locally (declare (optimize safety)) (defmethod ,sym ((x t) &key) x))) (values (eval `(signals-error (,sym) program-error)) (eval `(signals-error (,sym 1 2) program-error)) (eval `(signals-error (,sym 1 :bogus t) program-error)) (eval `(signals-error (,sym 1 :allow-other-keys nil :allow-other-keys t :bogus t) program-error)))) t t t t) (deftest defmethod.error.15 (let ((sym (gensym))) (eval `(locally (declare (optimize safety)) (defmethod ,sym ((x t) &key y) x))) (values (eval `(signals-error (,sym 1 :bogus t) program-error)) (eval `(signals-error (,sym 1 :y) program-error)) (eval `(signals-error (,sym 1 3 nil) program-error)))) t t t) gcl27-2.7.0/ansi-tests/defpackage.lsp000066400000000000000000000421461454061450500173350ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:09:18 1998 ;;;; Contains: Tests of DEFPACKAGE (in-package :cl-test) (compile-and-load "package-aux.lsp") (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 (let () (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 (progn (set-up-packages) (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 (let () (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 (let () (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 (let () (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") (signals-error (defpackage "H" (:use) (:size 10) (:size 20)) program-error)) t) ;; Repeated documentation field should cause a program-error (deftest defpackage.14 (progn (safely-delete-package "H") (signals-error (defpackage "H" (:use) (:documentation "foo") (:documentation "bar")) program-error)) t) ;; When a nickname refers to an existing package or nickname, ;; signal a package-error (deftest defpackage.15 (progn (safely-delete-package "H") (signals-error (defpackage "H" (:use) (:nicknames "A")) package-error)) t) (deftest defpackage.16 (progn (safely-delete-package "H") (signals-error (defpackage "H" (:use) (:nicknames "Q")) package-error)) t) ;; 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"))) (signals-error (defpackage "H" (:use) (:shadow "A") (:shadowing-import-from "G" "A")) program-error)) t) ;; :shadow and :import-from (deftest defpackage.18 (progn (safely-delete-package "H") (safely-delete-package "G") (eval '(defpackage "G" (:use) (:export "A"))) (signals-error (defpackage "H" (:use) (:shadow "A") (:import-from "G" "A")) program-error)) t) ;; :shadow and :intern (deftest defpackage.19 (progn (safely-delete-package "H") (signals-error (defpackage "H" (:use) (:shadow "A") (:intern "A")) program-error)) t) ;; :shadowing-import-from and :import-from (deftest defpackage.20 (progn (safely-delete-package "H") (safely-delete-package "G") (eval '(defpackage "G" (:use) (:export "A"))) (signals-error (defpackage "H" (:use) (:shadowing-import-from "G" "A") (:import-from "G" "A")) program-error)) t) ;; :shadowing-import-from and :intern (deftest defpackage.21 (progn (safely-delete-package "H") (safely-delete-package "G") (eval '(defpackage "G" (:use) (:export "A"))) (signals-error (defpackage "H" (:use) (:shadowing-import-from "G" "A") (:intern "A")) program-error)) t) ;; :import-from and :intern (deftest defpackage.22 (progn (safely-delete-package "H") (safely-delete-package "G") (eval '(defpackage "G" (:use) (:export "A"))) (signals-error (defpackage "H" (:use) (:import-from "G" "A") (:intern "A")) program-error)) t) ;; Names given to :export and :intern must be disjoint, ;; otherwise signal a program-error (deftest defpackage.23 (progn (safely-delete-package "H") (signals-error (defpackage "H" (:use) (:export "A") (:intern "A")) program-error)) t) ;; :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 (let () (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)) (def-macro-test defpackage.error.1 (defpackage :nonexistent-package (:use)))gcl27-2.7.0/ansi-tests/defparameter.lsp000066400000000000000000000042461454061450500177210ustar00rootroot00000000000000;-*- 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 ;;; (signals-error (defparameter) program-error) ;;; t) ;;; ;;; (deftest defparameter.error.2 ;;; (signals-error (defparameter *ignored-defparameter-name*) ;;; program-error) ;;; t) ;;; ;;; (deftest defparameter.error.3 ;;; (signals-error (defparameter *ignored-defparameter-name* nil ;;; "documentation" ;;; "illegal extra argument") ;;; program-error) ;;; t) (deftest defparameter.error.1 (signals-error (funcall (macro-function 'defparameter)) program-error) t) (deftest defparameter.error.2 (signals-error (funcall (macro-function 'defparameter) '(defparameter *nonexistent-variable* nil)) program-error) t) (deftest defparameter.error.3 (signals-error (funcall (macro-function 'defparameter) '(defparameter *nonexistent-variable* nil) nil nil) program-error) t) gcl27-2.7.0/ansi-tests/defsetf.lsp000066400000000000000000000062271454061450500167030ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 17:18:01 2003 ;;;; Contains: Tests of DEFSETF (in-package :cl-test) ;;; Need to add non-error tests (def-macro-test defsetf.error.1 (defsetf nonexistent-access-fn nonexistent-update-fn)) ;;; Short form (defun defsetf.1-accessor (x) (cadr x)) (defun defsetf.1-accessor-settor (x val) (setf (cadr x) val)) (deftest defsetf.1 (progn (let ((vals (multiple-value-list (defsetf defsetf.1-accessor defsetf.1-accessor-settor)))) (assert (equal vals '(defsetf.1-accessor)) () "Return values are ~A~%" vals)) (eval '(let ((x (list 1 2 3))) (values (setf (defsetf.1-accessor x) 4) x)))) 4 (1 4 3)) ;;; Use a macro instead of a function for updatefn (defun defsetf.2-accessor (x) (cadr x)) (defmacro defsetf.2-accessor-settor (x val) `(setf (cadr ,x) ,val)) (defparameter *defsetf.2-vals* (multiple-value-list (defsetf defsetf.2-accessor defsetf.2-accessor-settor))) (deftest defsetf.2a *defsetf.2-vals* (defsetf.2-accessor)) (deftest defsetf.2b (let ((x (list 1 2 3))) (values (setf (defsetf.2-accessor x) 4) x)) 4 (1 4 3)) ;;; Documentation string (defun defsetf.3-accessor (x) (cadr x)) (defun defsetf.3-accessor-settor (x val) (setf (cadr x) val)) (defparameter *defsetf.3-vals* (multiple-value-list (defsetf defsetf.3-accessor defsetf.3-accessor-settor "A doc string"))) (deftest defsetf.3a *defsetf.3-vals* (defsetf.3-accessor)) (deftest defsetf.3b (let ((doc (documentation 'defsetf.3-accessor 'setf))) (or (null doc) (equalt doc "A doc string"))) t) (deftest defsetf.3c (let ((x (list 1 2 3))) (values (setf (defsetf.3-accessor x) 4) x)) 4 (1 4 3)) ;;; Long form of defsetf (defun defsetf.4-accessor (n seq) (elt seq n)) (defparameter *defsetf.4-vals* (multiple-value-list (defsetf defsetf.4-accessor (n seq) (val) (declare) "Doc string for defsetf.4-accessor setf" `(setf (elt ,seq ,n) ,val)))) (deftest defsetf.4a *defsetf.4-vals* (defsetf.4-accessor)) (deftest defsetf.4b (let ((doc (documentation 'defsetf.4-accessor 'setf))) (or (null doc) (equalt doc "Doc string for defsetf.4-accessor setf"))) t) (deftest defsetf.4c (let ((x (list 1 2 3 4)) (i 0) (j nil) (k nil)) (values (setf (defsetf.4-accessor (progn (setf j (incf i)) 2) (progn (setf k (incf i)) x)) (progn (incf i) 'a)) x i j k)) a (1 2 a 4) 3 1 2) ;;; Test that there's a block around the forms in long form defsetf (defun defsetf.5-accessor (x) (car x)) (defsetf defsetf.5-accessor (y) (val) (return-from defsetf.5-accessor `(setf (car ,y) ,val))) (deftest defsetf.5a (let ((x (cons 'a 'b))) (values (setf (defsetf.5-accessor x) 'c) x)) c (c . b)) ;;; Test that the defsetf expansion function is defined in the same ;;; lexical environment that the defsetf appears in (defun defsetf.6-accessor (x) (car x)) (let ((z 'car)) (defsetf defsetf.6-accessor (y) (val) `(setf (,z ,y) ,val))) (deftest defsetf.6a (let ((x (cons 'a 'b))) (values (setf (defsetf.6-accessor x) 'c) x)) c (c . b)) gcl27-2.7.0/ansi-tests/deftype.lsp000066400000000000000000000162711454061450500167230ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 12:56:56 2003 ;;;; Contains: Tests of DEFTYPE (in-package :cl-test) (compile-and-load "types-aux.lsp") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; deftype (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) (deftest deftype.7 (let ((sym (gensym))) (assert (eq (eval `(deftype ,sym () '(integer 0 10))) sym)) (documentation sym 'type)) nil) (deftest deftype.8 (let ((sym (gensym))) (assert (eq (eval `(deftype ,sym () "FOO" '(integer 0 10))) sym)) (or (documentation sym 'type) "FOO")) "FOO") (deftest deftype.9 (let* ((sym (gensym)) (form `(deftype ,sym (&optional x) `(integer 0 ,x)))) (values (eqlt (eval form) sym) (multiple-value-list (subtypep* `(,sym) 'unsigned-byte)) (multiple-value-list (subtypep* 'unsigned-byte `(,sym))) (multiple-value-list (subtypep* `(,sym 4) '(integer 0 4))) (multiple-value-list (subtypep* '(integer 0 4) `(,sym 4))) (loop for x in '(a -1 0 1 2 3 4 5 b) collect (notnot (typep x sym))) (loop for x in '(a -1 0 1 2 3 4 5 b) collect (notnot (typep x `(,sym 4)))) )) t (t t) (t t) (t t) (t t) (nil nil t t t t t t nil) (nil nil t t t t t nil nil)) (deftest deftype.10 (let* ((sym (gensym)) (form `(deftype ,sym (&optional (x 14)) `(integer 0 ,x)))) (values (eqlt (eval form) sym) (multiple-value-list (subtypep* `(,sym) '(integer 0 14))) (multiple-value-list (subtypep* '(integer 0 14) `(,sym))) (multiple-value-list (subtypep* `(,sym 4) '(integer 0 4))) (multiple-value-list (subtypep* '(integer 0 4) `(,sym 4))) (loop for x in '(a -1 0 1 2 3 4 5 14 15 b) collect (notnot (typep x sym))) (loop for x in '(a -1 0 1 2 3 4 5 14 15 b) collect (notnot (typep x `(,sym 4)))) )) t (t t) (t t) (t t) (t t) (nil nil t t t t t t t nil nil) (nil nil t t t t t nil nil nil nil)) (deftest deftype.11 (let* ((sym (gensym)) (form `(deftype ,sym (&key foo bar) `(integer ,foo ,bar)))) (values (eqlt (eval form) sym) (multiple-value-list (subtypep* `(,sym) 'integer)) (multiple-value-list (subtypep* 'integer `(,sym))) (multiple-value-list (subtypep* `(,sym :allow-other-keys nil) 'integer)) (multiple-value-list (subtypep* 'integer `(,sym :allow-other-keys nil))) (multiple-value-list (subtypep* `(,sym :xyz 17 :allow-other-keys t) 'integer)) (multiple-value-list (subtypep* 'integer `(,sym :allow-other-keys t abc nil))) (multiple-value-list (subtypep* `(,sym :foo 3) '(integer 3))) (multiple-value-list (subtypep* '(integer 3) `(,sym :foo 3))) (multiple-value-list (subtypep* `(,sym :bar 10) '(integer * 10))) (multiple-value-list (subtypep* '(integer * 10) `(,sym :bar 10))) (multiple-value-list (subtypep* `(,sym :foo 3 :foo 4 :bar 6) '(integer 3 6))) (multiple-value-list (subtypep* '(integer 3 6) `(,sym :foo 3 :foo 4 :bar 6))) (multiple-value-list (subtypep* `(,sym :bar * :foo (1)) '(integer 2))) (multiple-value-list (subtypep* '(integer 2) `(,sym :bar * :foo (1)))) )) 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) ) (deftest deftype.12 (let* ((sym (gensym)) (form `(deftype ,sym (&key foo bar &allow-other-keys) `(integer ,foo ,bar)))) (values (eqlt (eval form) sym) (multiple-value-list (subtypep* `(,sym :xyz t) 'integer)) (multiple-value-list (subtypep* 'integer `(,sym :xyz t))) (multiple-value-list (subtypep* `(,sym :allow-other-keys nil abc t) 'integer)) (multiple-value-list (subtypep* 'integer `(,sym :allow-other-keys nil abc t))) (multiple-value-list (subtypep* `(,sym :foo -10 :bar 20) '(integer -10 20))) (multiple-value-list (subtypep* '(integer -10 20) `(,sym :foo -10 :bar 20))) )) t (t t) (t t) (t t) (t t) (t t) (t t) ) (deftest deftype.13 (let* ((sym (gensym)) (form `(deftype ,sym (&rest args) (if args `(member ,@args) nil)))) (values (eqlt (eval form) sym) ;; (multiple-value-list (subtypep* sym nil)) ;; (multiple-value-list (subtypep* nil sym)) (multiple-value-list (subtypep* `(,sym) nil)) (multiple-value-list (subtypep* nil `(,sym))) (notnot (typep 'a `(,sym a))) (notnot (typep 'b `(,sym a))) (notnot (typep '* `(,sym a))) (notnot (typep 'a `(,sym a b))) (notnot (typep 'b `(,sym a b))) (notnot (typep 'c `(,sym a b))))) t (t t) (t t) t nil nil t t nil) ;;; I've removed this test, because EVAL can cause implicit compilation, ;;; and the semantic constraints on compilation forbid redefinition of ;;; of the types produced by DEFTYPE at runtime. #| (deftest deftype.14 (let* ((sym (gensym)) (*f* nil) (form `(let ((x 1)) (declare (special *f*)) (setf *f* #'(lambda (y) (setf x y))) (deftype ,sym () `(integer 0 ,x))))) (declare (special *f*)) (values (eqlt (eval form) sym) (loop for i from -1 to 3 collect (typep* i sym)) (funcall *f* 2) (loop for i from -1 to 3 collect (typep* i sym)))) t (nil t t nil nil) 2 (nil t t t nil)) |# (deftest deftype.15 (let* ((sym (gensym)) (form `(let ((a 1)) (deftype ,sym (&optional (x a)) (declare (special a)) `(integer 0 ,x))))) (values (eqlt (eval form) sym) (let ((a 2)) (declare (special a)) (loop for i from -1 to 3 collect (typep* i `(,sym 1)))) (let ((a 2)) (declare (special a)) (loop for i from -1 to 3 collect (typep* i sym))))) t (nil t t nil nil) (nil t t nil nil)) (deftest deftype.16 (let* ((sym (gensym)) (form `(deftype ,sym () (return-from ,sym 'integer)))) (values (eqlt (eval form) sym) (subtypep* sym 'integer) (subtypep* 'integer sym))) t t t) (deftest deftype.17 (let* ((sym (gensym)) (form `(deftype ,sym () (values 'integer t)))) (values (eqlt (eval form) sym) (subtypep* sym 'integer) (subtypep* 'integer sym))) t t t) (deftest deftype.18 (let* ((sym (gensym)) (form `(deftype ,sym ()))) (values (eqlt (eval form) sym) (subtypep* sym nil) (subtypep* nil sym))) t t t) (deftest deftype.19 (let* ((sym (gensym)) (form `(deftype ,sym () (declare (optimize speed safety debug compilation-speed space)) 'integer))) (values (eqlt (eval form) sym) (subtypep* sym 'integer) (subtypep* 'integer sym))) t t t) ;;; Error tests (deftest deftype.error.1 (signals-error (funcall (macro-function 'deftype)) program-error) t) (deftest deftype.error.2 (signals-error (funcall (macro-function 'deftype) '(deftype nonexistent-type () nil)) program-error) t) (deftest deftype.error.3 (signals-error (funcall (macro-function 'deftype) '(deftype nonexistent-type () nil) nil nil) program-error) t) gcl27-2.7.0/ansi-tests/defun.lsp000066400000000000000000000057761454061450500163740ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Feb 16 23:40:32 2003 ;;;; Contains: Tests of DEFUN (in-package :cl-test) ;;; Tests for implicit blocks (defun defun-test-fun-1 () (return-from defun-test-fun-1 'good)) (deftest defun.1 (defun-test-fun-1) good) (defun defun-test-fun-2 () (return-from defun-test-fun-2 (values))) (deftest defun.2 (defun-test-fun-2)) (defun defun-test-fun-3 () (return-from defun-test-fun-3 (values 'a 'b 'c 'd 'e 'f))) (deftest defun.3 (defun-test-fun-3) a b c d e f) (defun defun-test-fun-4 (x) (car x)) (deftest defun.4 (let ((x (list 'a 'b))) (values (setf (defun-test-fun-4 x) 'c) x)) c (c b)) (report-and-ignore-errors (defun (setf defun-test-fun-4) (newval x) (return-from defun-test-fun-4 (setf (car x) newval)))) (deftest defun.5 (let ((x 1)) (declare (special x)) (let ((x 2)) (defun defun-test-fun-5 (&aux (y x)) (declare (special x)) (values y x)) (defun-test-fun-5))) 2 1) (deftest defun.6 (let ((x 1)) (declare (special x)) (let ((x 2)) (defun defun-test-fun-5 (&optional (y x)) (declare (special x)) (values y x)) (defun-test-fun-5))) 2 1) (deftest defun.7 (let ((x 1)) (declare (special x)) (let ((x 2)) (defun defun-test-fun-5 (&key (y x)) (declare (special x)) (values y x)) (defun-test-fun-5))) 2 1) ;; Documentation (deftest defun.8 (let* ((sym (gensym)) (doc "DEFUN.8") (form `(defun ,sym () ,doc nil))) (or (documentation sym 'function) doc)) "DEFUN.8") ;;; Error tests (deftest defun.error.1 (signals-error (funcall (macro-function 'defun)) program-error) t) (deftest defun.error.2 (signals-error (funcall (macro-function 'defun) '(defun nonexistent-function ())) program-error) t) (deftest defun.error.3 (signals-error (funcall (macro-function 'defun) '(defun nonexistent-function ()) nil nil) program-error) t) ;;; More comprehensive error handling tests of calls to ;;; user-defined functions (deftest defun.error.4 (let* ((name (gensym))) (loop for i below (min 100 lambda-parameters-limit) for params = nil then (cons (gensym) params) for args = nil then (cons nil args) for expected = '(1 2 3) for fn = (eval `(prog2 (proclaim '(optimize (safety 0))) (defun ,name ,params (values ,@expected)) (proclaim '(optimize safety)))) when (cond ((not (equal (multiple-value-list (apply fn args)) expected)) (list i :fail1)) ((not (equal (multiple-value-list (apply (symbol-function fn) args)) expected)) (list i :fail2)) ((not (equal (multiple-value-list (eval `(,name ,@args))) expected)) (list i :fail3)) ;; Error cases ((and (> i 0) (let ((val (eval `(signals-error (,name ,@(cdr args)) program-error)))) (and (not (eq val t)) :fail4)))) ((and (< i (1- call-arguments-limit)) (let ((val (eval `(signals-error (,name nil ,@args) program-error)))) (and (not (eq val t)) :fail5))))) collect it)) nil) gcl27-2.7.0/ansi-tests/defvar.lsp000066400000000000000000000034621454061450500165300ustar00rootroot00000000000000;-*- 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 ;;; (signals-error (defvar) program-error) ;;; t) ;;; ;;; (deftest defvar.error.2 ;;; (signals-error (defvar *ignored-defvar-name* nil "documentation" ;;; "illegal extra argument") ;;; program-error) ;;; t) (deftest defvar.error.1 (signals-error (funcall (macro-function 'defvar)) program-error) t) (deftest defvar.error.2 (signals-error (funcall (macro-function 'defvar) '(defvar *nonexistent-variable* nil)) program-error) t) (deftest defvar.error.3 (signals-error (funcall (macro-function 'defvar) '(defvar *nonexistent-variable* nil) nil nil) program-error) t) gcl27-2.7.0/ansi-tests/delete-file.lsp000066400000000000000000000046651454061450500174460ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 13 18:42:29 2004 ;;;; Contains: Tests for DELETE-FILE (in-package :cl-test) (deftest delete-file.1 (let ((pn "scratchfile.txt")) (unless (probe-file pn) (with-open-file (s pn :direction :output) (format s "Contents~%"))) (values (notnot (probe-file pn)) (multiple-value-list (delete-file pn)) (probe-file pn))) t (t) nil) (deftest delete-file.2 (let ((pn #p"scratchfile.txt")) (unless (probe-file pn) (with-open-file (s pn :direction :output) (format s "Contents~%"))) (values (notnot (probe-file pn)) (multiple-value-list (delete-file pn)) (probe-file pn))) t (t) nil) (deftest delete-file.3 (let ((pn "CLTEST:SCRATCHFILE.TXT")) (assert (typep (pathname pn) 'logical-pathname)) (unless (probe-file pn) (with-open-file (s pn :direction :output) (format s "Contents~%"))) (values (notnot (probe-file pn)) (multiple-value-list (delete-file pn)) (probe-file pn))) t (t) nil) (deftest delete-file.4 (let ((pn "CLTEST:SCRATCHFILE.TXT")) (assert (typep (pathname pn) 'logical-pathname)) (unless (probe-file pn) (with-open-file (s pn :direction :output) (format s "Contents~%"))) (let ((s (open pn :direction :input))) (close s) (values (notnot (probe-file pn)) (multiple-value-list (delete-file s)) (probe-file pn)))) t (t) nil) ;;; Specialized string tests (deftest delete-file.5 (do-special-strings (pn "scratchfile.txt" nil) (unless (probe-file pn) (with-open-file (s pn :direction :output) (format s "Contents~%"))) (assert (probe-file pn)) (assert (equal (multiple-value-list (delete-file pn)) '(t))) (assert (not (probe-file pn)))) nil) ;;; Error tests (deftest delete-file.error.1 (signals-error (delete-file) program-error) t) (deftest delete-file.error.2 (let ((pn "scratch.txt")) (unless (probe-file pn) (with-open-file (s pn :direction :output) (format s "Contents~%"))) (values (notnot (probe-file pn)) (signals-error (delete-file "scratch.txt" nil) program-error) (notnot (probe-file pn)) (delete-file pn) (probe-file pn))) t t t t nil) #| (deftest delete-file.error.3 (let ((pn "nonexistent.txt")) (when (probe-file pn) (delete-file pn)) (signals-error (delete-file "nonexistent.txt") file-error)) t) |# gcl27-2.7.0/ansi-tests/delete-package.lsp000066400000000000000000000127351454061450500201170ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:01:58 1998 ;;;; Contains: Tests of DELETE-PACKAGE (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) (declare (ignorable p1 p2 p3 s1 s2)) (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 (let ((outer-restarts (compute-restarts))) (handler-bind ((package-error #'(lambda (c) ;; (let ((r (find-restart 'continue c))) (and r (invoke-restart r))) (let ((my-restarts (remove 'abort (set-difference (compute-restarts c) outer-restarts) :key #'restart-name))) (assert my-restarts) (when (find 'continue my-restarts :key #'restart-name) (continue c)) (return t) )))) (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) (deftest delete-package.6 (block done (let ((outer-restarts (compute-restarts))) (safely-delete-package "TEST-20") (handler-bind ((package-error #'(lambda (c) (assert (set-difference (compute-restarts c) outer-restarts)) (return-from done :good)))) (delete-package "TEST-20")))) :good) ;;; Specialized sequences (defmacro def-delete-package-test (test-name name-form) `(deftest ,test-name (let ((name ,name-form)) (safely-delete-package name) (let ((p (make-package name :use nil))) (list (notnot (delete-package :test1)) (notnot (packagep p)) (package-name p)))) (t t nil))) (def-delete-package-test delete-package.7 (make-array '(5) :initial-contents "TEST1" :element-type 'base-char)) (def-delete-package-test delete-package.8 (make-array '(10) :initial-contents "TEST1XXXXX" :fill-pointer 5 :element-type 'base-char)) (def-delete-package-test delete-package.9 (make-array '(10) :initial-contents "TEST1XXXXX" :fill-pointer 5 :element-type 'character)) (def-delete-package-test delete-package.10 (make-array '(5) :initial-contents "TEST1" :adjustable t :element-type 'base-char)) (def-delete-package-test delete-package.11 (make-array '(5) :initial-contents "TEST1" :adjustable t :element-type 'character)) (def-delete-package-test delete-package.12 (let* ((etype 'character) (name2 (make-array '(10) :initial-contents "XXXTEST1YY" :element-type etype))) (make-array '(5) :displaced-to name2 :displaced-index-offset 3 :element-type etype))) (def-delete-package-test delete-package.13 (let* ((etype 'base-char) (name2 (make-array '(10) :initial-contents "XXXTEST1YY" :element-type etype))) (make-array '(5) :displaced-to name2 :displaced-index-offset 3 :element-type etype))) ;;; Error tests (deftest delete-package.error.1 (signals-error (delete-package) program-error) t) (deftest delete-package.error.2 (progn (unless (find-package "TEST-DPE2") (make-package "TEST-DPE2" :use nil)) (signals-error (delete-package "TEST-DPE2" nil) program-error)) t) gcl27-2.7.0/ansi-tests/deposit-field.lsp000066400000000000000000000043001454061450500200010ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Sep 11 20:23:15 2003 ;;;; Contains: Tests of DEPOSIT-FIELD (in-package :cl-test) ;;; Error tests (deftest deposit-field.error.1 (signals-error (deposit-field) program-error) t) (deftest deposit-field.error.2 (signals-error (deposit-field 1) program-error) t) (deftest deposit-field.error.3 (signals-error (deposit-field 1 (byte 1 0)) program-error) t) (deftest deposit-field.error.4 (signals-error (deposit-field 1 (byte 1 0) 0 nil) program-error) t) ;;; Non-error tests (deftest deposit-field.1 (loop for pos = (random 32) for size = (random 32) for newbyte = (random (ash 1 (+ pos size))) for val = (random (1+ (random (ash 1 (+ pos size))))) for result = (deposit-field newbyte (byte size pos) val) repeat 100 unless (loop for i from 0 to (+ pos size) always (if (or (< i pos) (>= i (+ pos size))) (if (logbitp i val) (logbitp i result) (not (logbitp i result))) (if (logbitp i newbyte) (logbitp i result) (not (logbitp i result))))) collect (list pos size newbyte val result)) nil) (deftest deposit-field.2 (loop for pos = (random 1000) for size = (random 1000) for newbyte = (random (ash 1 (+ pos size))) for val = (random (1+ (random (ash 1 (+ pos size))))) for result = (deposit-field newbyte (byte size pos) val) repeat 100 unless (loop for i from 0 to (+ pos size) always (if (or (< i pos) (>= i (+ pos size))) (if (logbitp i val) (logbitp i result) (not (logbitp i result))) (if (logbitp i newbyte) (logbitp i result) (not (logbitp i result))))) collect (list pos size newbyte val result)) nil) (deftest deposit-field.3 (loop for x = (random-fixnum) for y = (random-fixnum) for pos = (random 32) repeat 100 always (= (deposit-field x (byte 0 pos) y) y)) t) (deftest deposit-field.4 (let ((bound (ash 1 200))) (loop for x = (random-from-interval bound) for y = (random-from-interval bound) for pos = (random 200) repeat 100 always (= (deposit-field x (byte 0 pos) y) y))) t) (deftest deposit-field.5 (loop for i of-type fixnum from -1000 to 1000 always (eql (deposit-field -1 (byte 0 0) i) i)) t) gcl27-2.7.0/ansi-tests/describe.lsp000066400000000000000000000050061454061450500170350ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Dec 12 13:22:13 2004 ;;;; Contains: Tests of DESCRIBE (in-package :cl-test) (defun harness-for-describe (fn) (let (s1 s2) (with-open-stream (*standard-output* (make-string-output-stream)) (with-open-stream (tio-input (make-string-input-stream "X")) (with-open-stream (tio-output (make-string-output-stream)) (with-open-stream (*terminal-io* (make-two-way-stream tio-input tio-output)) (let ((*print-circle* t) (*print-readably* nil)) (assert (null (multiple-value-list (funcall fn)))))) (setq s2 (get-output-stream-string tio-output))) (assert (equal (read-char tio-input) #\X))) (setq s1 (get-output-stream-string *standard-output*))) (values s1 s2))) (deftest describe.1 (loop for x in *universe* for (s1 s2) = (multiple-value-list (harness-for-describe #'(lambda () (describe x)))) when (and (equal s1 "") (equal s2 "")) collect x) nil) (deftest describe.2 (loop for x in *universe* for s1 = nil for s2 = nil for s3 = (with-output-to-string (s) (setf (values s1 s2) (harness-for-describe #'(lambda () (describe x s))))) when (or (equal s3 "") (not (equal "" s2)) (not (equal "" s1))) collect (list x s1 s2 s3)) nil) (deftest describe.3 (loop for x in *universe* for (s1 s2) = (multiple-value-list (harness-for-describe #'(lambda () (describe x t)))) when (or (equal "" s2) (not (equal "" s1))) collect (list x s1 s2)) nil) (deftest describe.4 (loop for x in *universe* for (s1 s2) = (multiple-value-list (harness-for-describe #'(lambda () (describe x nil)))) when (or (equal "" s1) (not (equal "" s2))) collect (list x s1 s2)) nil) ;;; Defining methods for describe-object (defclass describe-object-test-class-01 () ((s1 :initarg :s1) (s2 :initarg :s2) (s3 :initarg :s3))) (defmethod describe-object ((obj describe-object-test-class-01) stream) (format stream "ABCDE ~A ~A ~A XYZ" (slot-value obj 's1) (slot-value obj 's2) (slot-value obj 's3))) (deftest describe.5 (let ((obj (make-instance 'describe-object-test-class-01 :s1 2 :s2 6 :s3 17))) (multiple-value-bind (str1 str2) (harness-for-describe #'(lambda () (describe obj))) (if (or (search "ABCDE 2 6 17 XYZ" str1) (search "ABCDE 2 6 17 XYZ" str2)) :good (list str1 str2)))) :good) ;;; Error cases (deftest describe.error.1 (signals-error (describe) program-error) t) (deftest describe.error.2 (signals-error (with-output-to-string (s) (describe nil s nil)) program-error) t) gcl27-2.7.0/ansi-tests/destructuring-bind.lsp000066400000000000000000000127471454061450500211030ustar00rootroot00000000000000;-*- 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 (notnot z-p))) a b c t) (deftest destructuring-bind.7a (destructuring-bind (x y &optional (z x z-p)) '(a b) (values x y z z-p)) a b a nil) (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.12a (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.17a (destructuring-bind (&key (a 'foo) (b 'bar) c) '(:c 1) (values a b c)) foo bar 1) (deftest destructuring-bind.17c (destructuring-bind (&key (a 'foo a-p) (b a b-p) (c 'zzz c-p)) '(:c 1) (values a b c a-p b-p (notnot c-p))) foo foo 1 nil nil t) (deftest destructuring-bind.18 (destructuring-bind ((&key a b c)) '((:c 1 :b 2)) (values a b c)) nil 2 1) ;;; Test that destructuring-bind does not have a tagbody (deftest destructuring-bind.19 (block nil (tagbody (destructuring-bind (a . b) '(1 2) (go 10) 10 (return 'bad)) 10 (return 'good))) good) (deftest destructuring-bind.20 (destructuring-bind (&whole (a . b) c . d) '(1 . 2) (list a b c d)) (1 2 1 2)) (deftest destructuring-bind.21 (destructuring-bind (x &rest (y z)) '(1 2 3) (values x y z)) 1 2 3) (deftest destructuring-bind.22 (destructuring-bind (x y &key) '(1 2) (values x y)) 1 2) (deftest destructuring-bind.23 (destructuring-bind (&rest x &key) '(:allow-other-keys 1) x) (:allow-other-keys 1)) (deftest destructuring-bind.24 (destructuring-bind (&rest x &key) nil x) nil) (deftest destructuring-bind.25 (let ((x :bad)) (declare (special x)) (let ((x :good)) (destructuring-bind (y) (list x) (declare (special x)) y))) :good) (deftest destructuring-bind.26 (destructuring-bind (x) (list 1)) nil) (deftest destructuring-bind.27 (destructuring-bind (x) (list 1) (declare (optimize))) nil) (deftest destructuring-bind.28 (destructuring-bind (x) (list 1) (declare (optimize)) (declare)) nil) (deftest destructuring-bind.29 (destructuring-bind (x &aux y) '(:foo) (values x y)) :foo nil) (deftest destructuring-bind.30 (destructuring-bind (x &aux (y (list x))) '(:foo) (values x y)) :foo (:foo)) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest destructuring-bind.31 (macrolet ((%m (z) z)) (destructuring-bind (a b c) (expand-in-current-env (%m '(1 2 3))) (values a b c))) 1 2 3) ;;; Error cases #| (deftest destructuring-bind.error.1 (signals-error (destructuring-bind (a b c) nil (list a b c)) program-error) t) (deftest destructuring-bind.error.2 (signals-error (destructuring-bind ((a b c)) nil (list a b c)) program-error) t) (deftest destructuring-bind.error.3 (signals-error (destructuring-bind (a b) 'x (list a b)) program-error) t) (deftest destructuring-bind.error.4 (signals-error (destructuring-bind (a . b) 'x (list a b)) program-error) t) |# ;;; (deftest destructuring-bind.error.5 ;;; (signals-error (destructuring-bind) program-error) ;;; t) ;;; ;;; (deftest destructuring-bind.error.6 ;;; (signals-error (destructuring-bind x) program-error) ;;; t) (deftest destructuring-bind.error.7 (signals-error (funcall (macro-function 'destructuring-bind)) program-error) t) (deftest destructuring-bind.error.8 (signals-error (funcall (macro-function 'destructuring-bind) '(destructuring-bind (a . b) '(1 2) nil)) program-error) t) (deftest destructuring-bind.error.9 (signals-error (funcall (macro-function 'destructuring-bind) '(destructuring-bind (a . b) '(1 2) nil) nil nil) program-error) t) gcl27-2.7.0/ansi-tests/directory-namestring.lsp000066400000000000000000000027031454061450500214270ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 12 06:21:42 2004 ;;;; Contains: Tests for DIRECTORY-NAMESTRING (in-package :cl-test) (deftest directory-namestring.1 (let* ((vals (multiple-value-list (directory-namestring "directory-namestring.lsp"))) (s (first vals))) (if (and (null (cdr vals)) (stringp s) (equal (directory-namestring s) s)) :good vals)) :good) (deftest directory-namestring.2 (do-special-strings (s "directory-namestring.lsp" nil) (let ((ns (directory-namestring s))) (assert (stringp ns)) (assert (string= (directory-namestring ns) ns)))) nil) ;;; Lispworks makes another assumption about filename normalization ;;; when using file streams as pathname designators, so this test ;;; doesn't work there. ;;; (This is another example of the difficulty of testing a feature ;;; in which so much is left up to the implementation.) #-lispworks (deftest directory-namestring.3 (let* ((name "directory-namestring.lsp") (pn (merge-pathnames (pathname name))) (name2 (with-open-file (s pn :direction :input) (directory-namestring s))) (name3 (directory-namestring pn))) (or (equalt name2 name3) (list name2 name3))) t) ;;; Error tests (deftest directory-namestring.error.1 (signals-error (directory-namestring) program-error) t) (deftest directory-namestring.error.2 (signals-error (directory-namestring "directory-namestring.lsp" nil) program-error) t) gcl27-2.7.0/ansi-tests/directory.lsp000066400000000000000000000031111454061450500172540ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jan 1 12:00:18 2004 ;;;; Contains: Tests of DIRECTORY (in-package :cl-test) (deftest directory.1 (directory "nonexistent") nil) (deftest directory.2 (directory #p"nonexistent") nil) (deftest directory.3 (directory "nonexistent" :allow-other-keys nil) nil) (deftest directory.4 (directory "nonexistent" :allow-other-keys t :foo 'bar) nil) (deftest directory.5 (directory "nonexistent" :foo 0 :allow-other-keys t) nil) (deftest directory.6 (let* ((pattern-pathname (make-pathname :name :wild :type :wild :defaults *default-pathname-defaults*)) (pathnames (directory pattern-pathname))) (values (remove-if #'pathnamep pathnames) (loop for pn in pathnames unless (equal pn (truename pn)) collect pn) ;; (loop for pn in pathnames ;; unless (pathname-match-p pn pattern-pathname) ;; collect pn)) )) nil nil ;; nil ) (deftest directory.7 (let* ((pattern-pathname (make-pathname :name :wild :type :wild :defaults *default-pathname-defaults*)) (pathnames (directory pattern-pathname))) (loop for pn in pathnames unless (equal pn (probe-file pn)) collect pn)) nil) (deftest directory.8 (let* ((pathname-pattern "CLTEST:*.*") (len (length (directory pathname-pattern)))) (if (< len 500) len nil)) nil) ;;; Specialized string tests (deftest directory.9 (do-special-strings (s "nonexistent" nil) (assert (null (directory s)))) nil) ;;; Error tests (deftest directory.error.1 (signals-error (directory) program-error) t) gcl27-2.7.0/ansi-tests/disassemble.lsp000066400000000000000000000045451454061450500175570ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 18 20:47:58 2003 ;;;; Contains: Tests of DISASSEMBLE (in-package :cl-test) (defun disassemble-it (fn) (let (val) (values (notnot (stringp (with-output-to-string (*standard-output*) (setf val (disassemble fn))))) val))) (deftest disassemble.1 (disassemble-it 'car) t nil) (deftest disassemble.2 (disassemble-it (symbol-function 'car)) t nil) (deftest disassemble.3 (disassemble-it '(lambda (x y) (cons y x))) t nil) (deftest disassemble.4 (disassemble-it (eval '(function (lambda (x y) (cons x y))))) t nil) (deftest disassemble.5 (disassemble-it (funcall (compile nil '(lambda () (let ((x 0)) #'(lambda () (incf x))))))) t nil) (deftest disassemble.6 (let ((name 'disassemble.fn.1)) (fmakunbound name) (eval `(defun ,name (x) x)) (disassemble-it name)) t nil) (deftest disassemble.7 (let ((name 'disassemble.fn.2)) (fmakunbound name) (eval `(defun ,name (x) x)) (compile name) (disassemble-it name)) t nil) (deftest disassemble.8 (progn (eval '(defun (setf disassemble-example-fn) (val arg) (setf (car arg) val))) (disassemble-it '(setf disassemble-example-fn))) t nil) (deftest disassemble.9 (progn (eval '(defgeneric disassemble-example-fn2 (x y z))) (disassemble-it 'disassemble-example-fn2)) t nil) (deftest disassemble.10 (progn (eval '(defgeneric disassemble-example-fn3 (x y z))) (eval '(defmethod disassemble-example-fn3 ((x t)(y t)(z t)) (list x y z))) (disassemble-it 'disassemble-example-fn3)) t nil) (deftest disassemble.11 (let ((fn 'disassemble-example-fn4)) (when (fboundp fn) (fmakunbound fn)) (eval `(defun ,fn (x) x)) (let ((is-compiled? (typep (symbol-function fn) 'compiled-function))) (multiple-value-call #'values (disassemble-it fn) (if is-compiled? (notnot (typep (symbol-function fn) 'compiled-function)) (not (typep (symbol-function fn) 'compiled-function)))))) t nil t) ;;; Error tests (deftest disassemble.error.1 (signals-error (disassemble) program-error) t) (deftest disassemble.error.2 (signals-error (disassemble 'car nil) program-error) t) (deftest disassemble.error.3 (check-type-error #'disassemble (typef '(or function symbol (cons (eql setf) (cons symbol null))))) nil) gcl27-2.7.0/ansi-tests/dispatch-macro-characters.lsp000066400000000000000000000040571454061450500222750ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 5 11:42:24 2005 ;;;; Contains: Tests of dispatch macro character functions (in-package :cl-test) (deftest make-dispatch-macro-character.1 (with-standard-io-syntax (let* ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST"))) (values (make-dispatch-macro-character #\!) (read-from-string "123!")))) t 123) (deftest make-dispatch-macro-character.2 (with-standard-io-syntax (let* ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST"))) (values (make-dispatch-macro-character #\! t) (read-from-string "123!")))) t 123!) (deftest make-dispatch-macro-character.3 (with-standard-io-syntax (let* ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST"))) (values (make-dispatch-macro-character #\!) (loop for c across +standard-chars+ for result = (handler-case (read-from-string (coerce (list #\! c #\X) 'string)) (reader-error (c) :good) (error (c) :bad)) unless (eql result :good) collect (list c result))))) t nil) (deftest make-dispatch-macro-character.4 (with-standard-io-syntax (let* ((rt (copy-readtable nil)) (*package* (find-package "CL-TEST"))) (values (make-dispatch-macro-character #\! t rt) (read-from-string "!") (let ((*readtable* rt)) (read-from-string "123!"))))) t ! 123!) (deftest make-dispatch-macro-character.error.1 (let ((*readtable* (copy-readtable nil))) (signals-error (make-dispatch-macro-character) program-error)) t) (deftest make-dispatch-macro-character.error.2 (let ((*readtable* (copy-readtable nil))) (signals-error (make-dispatch-macro-character #\! t *readtable* nil) program-error)) t) ;;; GET-DISPATCH-MACRO-CHARACTER (deftest get-dispatch-macro-character.1 (loop for c across +standard-chars+ when (and (not (eql c #\#)) (handler-case (list (get-dispatch-macro-character c #\a) c) (error (cnd) nil))) collect it) nil) gcl27-2.7.0/ansi-tests/divide.lsp000066400000000000000000000114521454061450500165230ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 31 20:20:15 2003 ;;;; Contains: Tests of the / function (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "division-aux.lsp") (deftest /.error.1 (signals-error (/) program-error) t) (deftest /.error.2 (divide-by-zero-test 0)) (deftest /.error.3 (divide-by-zero-test 1 0)) (deftest /.error.4 (divide-by-zero-test 17 10 0 11)) (deftest /.error.5 (divide-by-zero-test 0.0s0)) (deftest /.error.6 (divide-by-zero-test 0.0f0)) (deftest /.error.7 (divide-by-zero-test 0.0d0)) (deftest /.error.8 (divide-by-zero-test 0.0l0)) ;;;;;;;;;; (deftest /.1 (/ 1) 1) (deftest /.2 (/ -1) -1) (deftest /.3 (loop for i = (random-fixnum) repeat 1000 unless (or (zerop i) (let ((q1 (/ i)) (q2 (/ 1 i))) (and (rationalp q1) (eql (denominator q1) (abs i)) (eql (numerator q1) (signum i)) (eql q1 q2) (eql (* q1 i) 1)))) collect i) nil) (deftest /.4 (loop for i = (random-from-interval 1000000 1) for j = (random-from-interval 1000000 1) for g = (gcd i j) for q = (/ i j) for q2 = (/ j) repeat 1000 unless (and (integerp g) (zerop (mod i g)) (zerop (mod j g)) (eql (numerator q) (/ i g)) (eql (denominator q) (/ j g)) (eql (/ q) (/ j i)) (eql q (* i q2))) collect (list i j q)) nil) (deftest /.5 (loop for bound in (list 1.0s5 1.0f10 1.0d20 1.0l20) nconc (loop for i = (1+ (random bound)) for r1 = (/ i) for r2 = (/ 1 i) repeat 1000 unless (eql r1 r2) collect (list i r1 r2))) nil) ;; Complex division (deftest /.6 (loop for i1 = (random-fixnum) for i = (if (zerop i1) 1 i1) for c = (complex 0 i) for r = (/ c) repeat 1000 unless (eql r (complex 0 (- (/ i)))) collect (list i c r)) nil) #| (deftest /.7 (loop for bound in (list 1.0s5 1.0f10 1.0d20 1.0l20) nconc (loop for i = (1+ (random bound)) for c = (complex 0 i) for r = (/ c) repeat 1000 unless (= r (complex 0 (- (/ i)))) collect (list i c r (complex 0 (- (/ i)))))) nil) |# (deftest /.8 (loop for bound in (list 1.0s5 1.0f10 1.0d20 1.0l20) for one = (float 1.0 bound) for zero = (float 0.0 bound) nconc (loop for i = (1+ (random bound)) for c = (complex i zero) for q = (/ c c) repeat 100 unless (eql q (complex one zero)) collect (list i c q (complex one zero)))) nil) (deftest /.9 (loop for a = (random-fixnum) for b = (random-fixnum) for m = (+ (* a a) (* b b)) repeat 1000 unless (or (zerop m) (let* ((q (/ (complex a b))) (c (/ a m)) (d (/ (- b) m)) (expected (complex c d))) (eql q expected))) collect (list a b (/ (complex a b)))) nil) (deftest /.10 (let ((bound 1000000000000000000)) (loop for a = (random-from-interval bound) for b = (random-from-interval bound) for m = (+ (* a a) (* b b)) repeat 1000 unless (or (zerop m) (let* ((q (/ (complex a b))) (c (/ a m)) (d (/ (- b) m)) (expected (complex c d))) (eql q expected))) collect (list a b (/ (complex a b))))) nil) (deftest /.11 (loop for a = (random-fixnum) for b = (random-fixnum) for n = (complex (random-fixnum) (random-fixnum)) for m = (+ (* a a) (* b b)) repeat 1000 unless (or (zerop m) (let* ((q (/ n (complex a b))) (c (/ a m)) (d (/ (- b) m)) (expected (* n (complex c d)))) (eql q expected))) collect (list a b (/ n (complex a b)))) nil) ;;; More floating point tests (deftest /.12 (loop for type in '(short-float single-float double-float long-float) for lower in (mapcar #'rational-safely (list least-positive-short-float least-positive-single-float least-positive-double-float least-positive-long-float)) for upper in (mapcar #'rational-safely (list most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float)) for one = (coerce 1 type) for radix = (float-radix one) nconc (loop for i from 1 for rpos = radix then (* rpos radix) for rneg = (/ radix) then (/ rneg radix) while (<= lower rneg rpos upper) unless (let ((frpos (float rpos one)) (frneg (float rneg one))) (and (eql (/ frpos) (/ one frpos)) (eql (/ frpos) (/ 1.0s0 frpos)) (eql (/ frpos) (/ 1 frpos)) (eql (/ frpos) frneg) (eql (/ frneg) (/ 1.0s0 frneg)) (eql (/ frneg) (/ 1 frneg)) (eql (/ frneg) frpos))) collect (list i rpos rneg (float rpos one) (float rneg one)))) nil) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest /.13 (macrolet ((%m (z) z)) (values (/ (expand-in-current-env (%m 1/2))) (/ (expand-in-current-env (%m 2)) 3) (/ 5 (expand-in-current-env (%m 7))))) 2 2/3 5/7) gcl27-2.7.0/ansi-tests/division-aux.lsp000066400000000000000000000004641454061450500176770ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Sep 1 07:57:02 2003 ;;;; Contains: Aux. functions for testing / (in-package :cl-test) (defun divide-by-zero-test (&rest args) (handler-case (progn (apply #'/ args) (values)) (division-by-zero () (values)) (condition (c) c))) gcl27-2.7.0/ansi-tests/do-all-symbols.lsp000066400000000000000000000061141454061450500201140ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 21 18:27:22 2004 ;;;; Contains: Tests of DO-ALL-SYMBOLS (in-package :cl-test) (def-macro-test do-all-symbols.error.1 (do-all-symbols (x))) ;;; FIXME Add tests for non-error cases (deftest do-all-symbols.1 (let ((symbols nil)) (do-all-symbols (sym) (push sym symbols)) (let ((hash (make-hash-table :test 'eq))) (with-package-iterator (f (list-all-packages) :internal :external :inherited) (loop (multiple-value-bind (found sym) (f) (unless found (return)) (setf (gethash sym hash) t)))) ;; hash now contains all symbols accessible in any package ;; Check that all symbols from DO-ALL-SYMBOLS are in this ;; package (loop for s in symbols unless (gethash s hash) collect s))) nil) ;; This is the converse of do-all-symbols.1 (deftest do-all-symbols.2 (let ((symbols nil)) (with-package-iterator (f (list-all-packages) :internal :external :inherited) (loop (multiple-value-bind (found sym) (f) (unless found (return))` (push sym symbols)))) (let ((hash (make-hash-table :test 'eq))) (do-all-symbols (s) (setf (gethash s hash) t)) (loop for s in symbols unless (gethash s hash) collect s))) nil) (deftest do-all-symbols.3 (let ((sym (gensym))) (do-all-symbols (s t) (assert (not (eq s sym))))) t) (deftest do-all-symbols.4 (let ((x :bad)) (do-all-symbols (x x))) nil) (deftest do-all-symbols.5 (block nil (do-all-symbols (x (return :bad))) :good) :good) (deftest do-all-symbols.6 (do-all-symbols (x :bad) (return :good)) :good) (deftest do-all-symbols.7 (block done (tagbody (do-all-symbols (x (return-from done :good)) (go 1) (return-from done :bad1) 1) 1 (return-from done :bad2))) :good) (deftest do-all-symbols.8 (block done (tagbody (do-all-symbols (x (return-from done :good)) (go tag) (return-from done :bad1) tag) tag (return-from done :bad2))) :good) ;;; Test that do-all-symbols accepts declarations (deftest do-all-symbols.9 (let ((x 0) (y 1)) (do-all-symbols (z nil) (declare (type (integer * 0) x)) (declare (type (integer 1 *) y)) (declare (ignore z)) (when (< x y) (return :good)))) :good) ;;; Default return is NIL (deftest do-all-symbols.10 (do-all-symbols (s) (declare (ignore s))) nil) ;;; Free declaration scope tests (deftest do-all-symbols.11 (let ((x :good)) (declare (special x)) (let ((x :bad)) (do-all-symbols (s x) (declare (special x))))) :good) ;;; Executing a return actually terminates the loop (deftest do-all-symbols.12 (let ((should-have-returned nil)) (block done (do-all-symbols (s :bad1) (when should-have-returned (return-from done :bad2)) (setq should-have-returned t) (return :good)))) :good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest do-all-symbols.13 (macrolet ((%m (z) z)) (do-all-symbols (s (expand-in-current-env (%m :good))))) :good) gcl27-2.7.0/ansi-tests/do-external-symbols.lsp000066400000000000000000000076201454061450500211710ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 21 18:26:08 2004 ;;;; Contains: Tests of DO-EXTERNAL-SYMBOLS (in-package :cl-test) (compile-and-load "package-aux.lsp") (declaim (optimize (safety 3))) (defun collect-external-symbols (pkg) (remove-duplicates (sort-symbols (let ((all nil)) (do-external-symbols (x pkg all) (push x all)))))) (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-external-symbols works without ;; a return value (and that the default return value is nil) (deftest do-external-symbols.6 (do-external-symbols (s "DS1") (declare (ignore s)) t) nil) ;; Test that do-external-symbols works without ;; a package being specified (deftest do-external-symbols.7 (let ((x nil) (*package* (find-package "DS1"))) (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-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))) ;;; Specialized sequence tests (defmacro def-do-external-symbols-test (test-name name-form) `(deftest ,test-name (collect-external-symbols ,name-form) (DS1:A DS1:B))) (def-do-external-symbols-test do-external-symbols.9 (make-array 3 :element-type 'base-char :initial-contents "DS1")) (def-do-external-symbols-test do-external-symbols.10 (make-array 6 :element-type 'base-char :initial-contents "DS1XXX" :fill-pointer 3)) (def-do-external-symbols-test do-external-symbols.11 (make-array 6 :element-type 'character :initial-contents "DS1XXX" :fill-pointer 3)) (def-do-external-symbols-test do-external-symbols.12 (make-array 3 :element-type 'base-char :initial-contents "DS1" :adjustable t)) (def-do-external-symbols-test do-external-symbols.13 (make-array 3 :element-type 'character :initial-contents "DS1" :adjustable t)) (def-do-external-symbols-test do-external-symbols.14 (let* ((etype 'base-char) (name0 (make-array 6 :element-type etype :initial-contents "XDS1XX"))) (make-array 3 :element-type etype :displaced-to name0 :displaced-index-offset 1))) (def-do-external-symbols-test do-external-symbols.15 (let* ((etype 'character) (name0 (make-array 6 :element-type etype :initial-contents "XDS1XX"))) (make-array 3 :element-type etype :displaced-to name0 :displaced-index-offset 1))) ;;; Free declaration scope tests (deftest do-external-symbols.16 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (do-external-symbols (s (return-from done x)) (declare (special x)))))) :good) (deftest do-external-symbols.17 (let ((x :good)) (declare (special x)) (let ((x :bad)) (do-external-symbols (s "CL-TEST" x) (declare (special x))))) :good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest do-external-symbols.18 (macrolet ((%m (z) z)) (do-external-symbols (s (expand-in-current-env (%m "CL-TEST")) :good))) :good) (deftest do-external-symbols.19 (macrolet ((%m (z) z)) (do-external-symbols (s "CL-TEST" (expand-in-current-env (%m :good))))) :good) ;;; Error tests (def-macro-test do-external-symbols.error.1 (do-external-symbols (x "CL")))gcl27-2.7.0/ansi-tests/do-symbols.lsp000066400000000000000000000101141454061450500173410ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 21 18:24:59 2004 ;;;; Contains: Tests of DO-SYMBOLS (in-package :cl-test) (compile-and-load "package-aux.lsp") (declaim (optimize (safety 3))) (deftest do-symbols.1 (progn (set-up-packages) (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)))))) (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)) ;; Test that do-symbols works 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) ;; Test that do-symbols works without a package being specified (deftest do-symbols.7 (let ((x nil) (*package* (find-package "DS1"))) (list (do-symbols (s) (push s x)) (sort-symbols x))) (nil (DS1:A DS1:B DS1::C DS1::D))) ;; 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))) ;;; Specialized sequences (defmacro def-do-symbols-test (test-name name-form) `(deftest ,test-name (let ((name ,name-form)) (assert (string= name "B")) (set-up-packages) (equalt (remove-duplicates (sort-symbols (let ((all nil)) (do-symbols (x name all) (push x all))))) (list (find-symbol "BAR" "B") (find-symbol "FOO" "A")))) t)) (def-do-symbols-test do-symbols.9 (make-array 1 :element-type 'base-char :initial-contents "B")) (def-do-symbols-test do-symbols.10 (make-array 5 :element-type 'character :fill-pointer 1 :initial-contents "BXXXX")) (def-do-symbols-test do-symbols.11 (make-array 5 :element-type 'base-char :fill-pointer 1 :initial-contents "BXXXX")) (def-do-symbols-test do-symbols.12 (make-array 1 :element-type 'base-char :adjustable t :initial-contents "B")) (def-do-symbols-test do-symbols.13 (make-array 1 :element-type 'character :adjustable t :initial-contents "B")) (def-do-symbols-test do-symbols.14 (let* ((etype 'base-char) (name0 (make-array 4 :element-type etype :initial-contents "XBYZ"))) (make-array 1 :element-type etype :displaced-to name0 :displaced-index-offset 1))) (def-do-symbols-test do-symbols.15 (let* ((etype 'character) (name0 (make-array 4 :element-type etype :initial-contents "XBYZ"))) (make-array 1 :element-type etype :displaced-to name0 :displaced-index-offset 1))) ;;; Free declaration scope tests (deftest do-symbols.16 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (do-symbols (s (return-from done x)) (declare (special x)))))) :good) (deftest do-symbols.17 (let ((x :good)) (declare (special x)) (let ((x :bad)) (do-symbols (s "CL-TEST" x) (declare (special x))))) :good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest do-symbols.18 (macrolet ((%m (z) z)) (do-symbols (s (expand-in-current-env (%m "CL-TEST")) :good))) :good) (deftest do-symbols.19 (macrolet ((%m (z) z)) (do-symbols (s "CL-TEST" (expand-in-current-env (%m :good))))) :good) (def-macro-test do-symbols.error.1 (do-symbols (x "CL"))) gcl27-2.7.0/ansi-tests/do.lsp000066400000000000000000000071231454061450500156610ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 8 07:25:18 2005 ;;;; Contains: Tests of DO (in-package :cl-test) (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)) ;;; Scope of free declarations (deftest do.16 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (do ((i (return-from done x) 0)) (t nil) (declare (special x)))))) :good) (deftest do.17 (block done (let ((x :good)) (declare (special x)) (let ((x :bad)) (do ((i 0 (return-from done x))) (nil nil) (declare (special x)))))) :good) (deftest do.18 (block done (let ((x :good)) (declare (special x)) (let ((x :bad)) (do ((i 0 0)) ((return-from done x) nil) (declare (special x)))))) :good) (deftest do.19 (let ((x :good)) (declare (special x)) (let ((x :bad)) (do () (t x) (declare (special x))))) :good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest do.20 (let ((result nil)) (macrolet ((%m (z) z)) (do ((x (expand-in-current-env (%m 0)) (+ x 2))) ((> x 10) result) (push x result)))) (10 8 6 4 2 0)) (deftest do.21 (let ((result nil)) (macrolet ((%m (z) z)) (do ((x 0 (expand-in-current-env (%m (+ x 2))))) ((> x 10) result) (push x result)))) (10 8 6 4 2 0)) (deftest do.22 (let ((result nil)) (macrolet ((%m (z) z)) (do ((x 0 (+ x 2))) ((expand-in-current-env (%m (> x 10))) result) (push x result)))) (10 8 6 4 2 0)) (deftest do.23 (let ((result nil)) (macrolet ((%m (z) z)) (do ((x 0 (+ x 2))) ((> x 10) (expand-in-current-env (%m result))) (push x result)))) (10 8 6 4 2 0)) (def-macro-test do.error.1 (do ((i 0 (1+ i))) ((= i 5) 'a))) gcl27-2.7.0/ansi-tests/doc/000077500000000000000000000000001454061450500153015ustar00rootroot00000000000000gcl27-2.7.0/ansi-tests/doc/ilc2005-slides.pdf000066400000000000000000003636621454061450500203530ustar00rootroot00000000000000%PDF-1.3 %Çì¢ 6 0 obj <> stream xœmS¹N1å—A„û.ÜŠM<öìÚ[‚DGÚ2]HHA ü¿ÄØccom±y;óæ½9²j Rù'¾gs±“7”Ÿ¿b!!„Òk6—O˜Ú½‹Ñº•‘FAÀÔʸYæ< TmÜŠ©ÀÌí2u'”EÊÕïzŒ1¸5!0Ó8ýfNÞç ´˜¡÷ nEòA¬„ªtÈ`ú“d{: X×4Â&|úÚ‘ûZK„Ú–³å2?U? ¹ µ-†ÎÙâendstream endobj 7 0 obj 401 endobj 43 0 obj <> stream xœ•SMK1õ QjEÔñ³õ°u'›ìQÁ›a½U<Úÿ0“LL¶´‚ìa÷M&ïͼ™]@=A¨éá÷l.bbé5›ÃK'žž¡û)µ¢-õÄ‚nÌDB7ã‹ÇîK >Äøˆ§i"T€­ ð„ Sн‰ñtù8ò™MNè¤R uÌÜfž6òL¿™( óx(]<Üâ»Iô˜s¥Ê¢T>ËkÑA¥cW!†$ÆÀ‹[ˆ{,mŸ_g~/¯£Ü€ TMƒ}mÞ| u¯¹Â 3¹Wj®ukœ8‹É6ís®âιР±ï±‰JÀJµ+-çQ ùÐõçÁ¹ƒÒÓßT³j€¬k]:àµëXÚ^xQ7!pHß3Jì ¢ÌµR+mta™lqvãÌi=Ò¢éðyê¿È€V—±‹k^*tößæ1pÃ÷ò|&§Êû_XãCêÿ˱Ÿ~‹•³-I念ÁƒòÐÚ5J¼†JFæ›@åÇÅ+}KXsî]éã}Ú_•¡¿˜J|Øy—•fá…^;xôü‘Qí5endstream endobj 44 0 obj 425 endobj 57 0 obj <> stream xœ•VKo1 æM™VPB ©ÛÂló~Aⶤ=r+‴Håÿpbg’ÌÎÌ.Úì'±óåóg{n_ Æãž7»î¶»e"½Ë›ûºí®¿0Á¶¿º¼µ´ukÉ´Ðk˶»nuÿrû»GãØög·úñ‡l‰öËh*0u2_E³WL«d>M¦6žõJsôx¤OÖ´œÀèÑ4!™§MIYÖ‡âÚ+À,z¯h¿_\&‡ˆVŽÐû½*è#ѸJÁ¬¬÷fz:-4Á%ÞåZ]ŸÓšE Œpp uV¥-° Ês2ý(JT6àPº¾Yo”¾ÝÝÜA Óœ,dÉÜÁ èW²JV í«Ýw!_ÀNJcΪEbÏÐM1©C&ÄÍ”ÊÈPDȳøþï©Î6§Ð­ŠD˜Z>Ë·0bžmE¢(9w5%ÎOÉ7GVVµäÚ¢Àá0ô]ZuzÌ®*°áø”`A-œ ^ÜKÈjoLÐM1 ÞÒ \‘o<Ý/–¢ÐK7sDëlf£úù\.µ0U[mÓR¤|“Ž¾À¸%Ê2’©¢ ïø&…k³K‘Ï1r(Jˆq½˜_T\ÖjÎÕ-ì1¶ß!i'ÑÖ´ø$çˆúÕ ¤¨=Ì ¸®[_Ìç‚” »)?µ;—”î†þH]Ø€rA9Ab…²uóÌ=kÈBÝ•ãq#lþxl“#Æ1GHh”²9Y¨+Âÿ>½  ôø<\@N!>Í™i‹G„êøCºžšÉ:Äkô“´g]Ý"ø0L,àa> stream xœ•TÁn1 P„”V¥H”K1§îfÛI“AâÆiŽ{+‴•¶ÿhb'›Ì2+æ0û_Ób®Š6gfðí#×´N‘Où<«^êº,]©Dµ+ÄZ×v%mùD–¦4¿¼%‰ÒíEg rlRb\²d5†‡Á¢ïTÕ>+ëÈ:»UíbòeÂÆx˜ý°8ûÓ[Te)#‰GìÔo6û¾T&¥z]›/µÉ|Pöé*©vä¿EÃ2¸ÏÅû<—8¶ÿˆ”ºÜ´–Ñ%?ûRŽ}Ÿà§ÉÏ3¯endstream endobj 70 0 obj 474 endobj 76 0 obj <> stream xœU;o1ˆ—– &È`ƒÇc¯í$º4HWÒQ )üÿ"¶g¼¶7{芽ñŒ¿y¾u† ÒO¾—ÃÕp˜ÏÊçâ¾î†Ï_a÷k(¦cúc90z:›`w9llw¿¤(þ6?þdYÃî|ØmO4&«ž'ÍH •Ê2$9¹ Y¼]DŸÅGÙÚ¡…‘È2ø›|@#e™-ËO’L0¢ªUôÇžŠµ±Õߨ-  ™tåÙàˆÑ4gö—á,£äëA[ÖÛt`R%0Ëw%Ÿær Õc“^ò®\>xœ½O0:®Ö«l€@ä›Â’àIjhÙøuAŸTEWÀyÝAÒ*@##=¤`«‘{·ª&­få¥è£ÁÔ¶/žM¶Ô¦¹´ª-‹‘Ûnž0¸¥¿iq» “~ƒ›d@ wðXD¢}Þ8Õ&«AºõQº¥ÛH•TíX:ç8Œ—¬ó´Èb­àÜíu Ã;Îó x o•~)ÝÑïµqÜç‘Òl›W×ÄmbÏoEÇùŽÕ|÷¤z/…ÔTÅ„‹Ó¦­Lí fB8Œ„f ×Öõ TB&~n‡ë¬CW6ßØF¶ˆû£­«lñ©àkßîiYÒ±øBB±MàI;U"#˜¨îb-Né¶^t;ìëvtãÚš§ÌBìŸï÷IÖeàRyÍb³Ãšz®¾äx(ix·èúê1Y+Ó—ßqž ž›–l¡[Ê’-È%Õn~ERí]gg«“ Dûè+½@ƶX%„ucþ_> stream xœÍWÉn1’@è @Ä&ˆ‘X’C^»í°&¬.HsÌ-ˆRÂÿ(»ªÚv§gˆD„PÛåZß+W 9SBÆ?ú=ÆËWèX9™Ö×Ѷ *-oвχF8ôãàßõ¨ëà'žËJ³¶ÇUçAB™ÑÍ”í¬·µà3bâ%B 6 ê~Ejq9#yíPþ5åOwÙéxcôé2HwèÉú ‰€uQ_G"«ŒrµÞw¢í ý^è×›Cä}Qâ˜Åûé\ cjÄ—õ‹‘(þÕY £íŒ] k³ àç˜`a:Í@Ý·ìºõ¥¬RnYb8ï«\b;A· &î´W,ÜèUVf˜JBKÁk•¹ ¢dŸ ;ˆ¦„jÈ©w5ßluëkŠt5E”ѹ ‘íèùîþ^º(Ðw Âô(}›ÑCëé@ñ-#ÛÔÈî d®”¶%8Àxë´U8 ;PǘŠÔ}‰üY2F(ZG²sñ7$P9‹ÐÍNOÃä¬;«LðËõEö²‹ï‘J}·´RZë³t8ROuãÞMTËà¡õ?ò J6¸:‰š˜¹BC“—È„1 “øŸ±¶ÀJÆWJu‹IZtÍÈ«îY_Â3àXÙá¼ eG—‚ŒÓØ)9Ï)’zQw;Tì[ƒ°ÍÂH@λ@NÈ–:1ÌôS½ŸÛ8…™ñ†ª‡1"äëãÁ©CÑ{lŠ8ÊUVK_—¾¨*Mc ¹Ð…I­•OR©¥|¯;ÑöÓꤿŠ*ýµw î54—|úȸ²”ç3ìšk»•B~\aB¡)m4C¼sÕ“CïÕ⑯îH¡/ÚþÔøbGÙ•/ËÇ ØêqÀ&¿< 2d4ž§U€ìq*hXVôø ŒÓ5MªÅv ô”Ÿ6SÓEârÐÓshMñPdö4cèÙÕÔÑÈ4hïF#TñÉÅ飅»Ë]±˜$£ó²ÖîeF0|³`Zé{SÓÍ%CÚÖŽÑ»ƒ³Ð€;*Üç¸óa.¾6ñï7ûu &endstream endobj 88 0 obj 985 endobj 106 0 obj <> stream xœÍU=O1¢ „… ( b áRøðŒ¿vK(¥‰´åuQ ]¤Ëÿ/b{ì³½Ü] Úbwfìñ›7ϳksžô^®ºu·Œ¾üZ®àaìîîa|êòR>´Ös F›y㪛~Ÿ; ÎÀø§›KPŠ†è8 o#©hŸÇ 4¯ÿLUµ]Â~[ø8…ÑÈhã³qÀhž%Ó• Ã8ÿòÞžs-þr\6™)áúÊÁ”ês†E²Ú+š“ÈòQ6(«"µ}I-¡­ wõRŽ]Ç< MNGßUôy:Hr_˜p ¨R]³ˆÆw ±á.í2a7¦á!ï ýŠ¤Ý2g6Æ WbK%B{’üY‰*8¥–Ô¥&9¤Œ:ÊÃWˆŒæ4ƒ¡¶kNJ<ËáOl*Ô[Zz”Å¡·JkKÿ}&-w¢4PU·G‰8á^†‚Hš–ÉYnr‹´9ÃŦICƒN$‰Í'Þ[åä‘¢UµFÑ`ð?ØNìá2Ùr¢WÑ MÊSbGµX¨›  ÊL¤½ç˜õ:'=Â=Dâ”Hœé^HH¹ZBÓËîyU}¹ŽA#/º¥Ûé©'3®K‰š‚¤½-xQø¢‚â4훊ž¨Ô‹üc@[ó†é>l~ICY,¬W§AÃù×ã¿»ðüpWy³endstream endobj 107 0 obj 525 endobj 112 0 obj <> stream xœ½U;sÔ0f(]3i¨u$…‚veYR 3 I `ÞᙄÀÇ3áøçHÚ•%s9h€¹Â·ïo¿]¯§B-ƒPñÇÏÍI3m¦’.?6'âBßœ;/@ôÛMv•ñOÛêe+Z¯—Qô“fñÒR¿×H¨•è·šÅ…(‡D6I§Xr$¢²KÒéªx²žX¹Lv4>)€£ ¥>–üÑ ´¤8h€ÕÊ/([§“t&Wãä $÷¥äˆ­4>nÁÓjÔ` ’p%¡è!‰W m ”ê¯GÙ†NW¢ëÙ†ž`_£,¾+~È9¯3hÝ’±§–Èx#*ܬ·ØˆEÞ®w¨¢ƒqofóÜHgšîeÒuW¼3µtŸ 0ëùàÑÃD¥ÐØ&Åc^$P8Ûê“</ÇóÌ‹ÜLÛ’bõå„c¹ZêZöEþm˜NW7oœþ?5C£)A—ÞŽÝRi,…Bçë0?ËÀk‚Ž‰ (Ì L)ÖÄ]†ŒHÖ7u²·5ÑïnyßÞ§´6tÛÕ݇÷GvÊV•­pªxØQ{zn{2 F] fS‹œµà0Ž¸Ñº>WyæèçJÃqýøþîðî¨ÙKô1³¦gãþ`¤aQºŠè€J·cn(øÓ`s„ù3çVséRÃÍØ£ºJdàŠlû_¿äsT‘Ru£2ùS5êï[¨çŸwçx- }OĆ“©*âÕ°=,ò\Ë0zo‹÷ šêµÅ.~¤×ÛÏ.ºŒ.Š0¢›[@¢ ‡týÙ;bíêõŠÑ-I  ïña^ÞÌ)å]<`ô¯Øß5 "ØǺ4¡!ƒŠ–íGT]ìÅz?Éxendstream endobj 113 0 obj 719 endobj 172 0 obj <> stream xœUÉn1½÷WøÆäÐÁUv{9‚Ä 2 ê? (d‚ˆÄ¾ÂòµØ®rÛNf$„æÐSvm¯êUy)ä&üÝ]tËn) åÏîB\»«×ˆq¯Ëª}ü£¼Û´Âl¢ÝìÅƸßõh*%Æ;ÝìV<€!èGi+JÁ¯³I|ÅA‹äž%óp¢€Ìwâub¼ÙÍæW‚-z—nn“+oHïÕK’QÙ:…·aEÝnÓ-ÝÝ'¥))‘Ò9â[àÛŒ§D)nèιâŽGV($»=®™=š ñšõÖÖÐÛ¼-EBÆú†®rß&GJP°wQV¬ûžÓ¬°«€rþP×ð#öCE7Q\­ Ò· µšCmO…$“'¡'w9/I9ßce…M-ÑÝZʧµ/Àb¹ +º:CôŽ¹)Z›Š·–ÁŸdaó³U³‚2*WŒåÄ’Ö×'®•'ñŒ#åM¡C1fvX/z¯†þ>çÚ¥ørbaÓÃ/uóO£`´ÐŠŠþ5ù1VxªÒ1¶wª™!žÔ9¥€©y…C©Wl¯«Æ8hg¦ÕY}cSæÑ倆ý3Iç{ÊÝ @¬rW&l%ð^WUÒäG ý¼eÐIžKíûÙò·Œ.ÉÇŽ¡‚¦=ðÒ[3À=Y5ƒ¨LÅŽ¸À40\\åÉŸˆè CÜÖ±.ŽéÉð` ƒr-ë X¶iÖê_"­‰­5Ô¹rÍž&°írÑïÆŒmùæLÙÙrZMô.Øú]€æ‰Aú+¯8Ùìß,–L³ýäU¯{m‚]^£Ç™¼Ã§)•–XFx> …m!U[<–°Ê%&®šÄÝ…(ÿå¿àâ3è뇧w„„h‹Íj‹Cœ6x^í§L žãߌÃTséÃNRâÑQìtñ÷ôJíÈendstream endobj 173 0 obj 730 endobj 200 0 obj <> stream xœÕV»ŽS1…ˆêîjYŲ€0ÙÂÁãǵ½ ‰Ž)eºEHA 5-‚QP€o¾”±g|¯’ QR$ãÇ<Îœ9ÎJ¨•>ü}¶ìVÝJ@^+_gKqÞݹ'@ÌŸtå¨L?lïgZØ3/æËnzádþ´3L/æ»éùdJ#Œ"û2mK€lîÓ¶Ú©¼°8É0²Öya’ì”HÈæ™Ádë7ƒ§ËÏÈ»: ¼Í¾Ïå`=Ö$MßǼv3¯ÞQ./ÜÈ Ú ˆääbZÐN€Cáèúâ9לQIA6õayº.Ð2¯P‚ΖÄÚ-^Lsh©PlÁõ@åL5‰%,âxóðªíC°#¬¸M]9jP=*5ÅØÔ¤ÖvýØi.ÐÓ|: ºFÌÃFç¥¿àššúº&íM³Éä9àVPÇjej¨%;¦Náåhj°…ä¬/qgìf &C•@ÞÍ i$m ù_’‰«mò%„Ñuâ©©v'œÖÕôâ!;^s¡”𮊌D…š^=f)uï Â9âœSpIÈݬ¤®{Ób®¡eœnp¨È:*ʤö|‹ñæ*¶1YÅ1q‹7&rÝN²Ä³8PÏ­ÅtµÄAÐÝ',–%p˜‚õá[êƒAº¯eW²oÙªÙ4"Žò¢„ñõUI ¸CŸ8­HìùPĉJ|ÏcÎsý¦TLÞ&¡’Ìó4y)Byæ¾åò‘®GBóe]ávõ›#ŠôšÓ 0¦•æ]½ãŠëókâJ™1T/¦æ:5ÌCdH:»©kû…¢¦Õ[S"Ýnèa›¢þYqª¸T"Vàÿ‰ÙÓ»Å~·:IÆd{»6ak›P‚zôXN+©§_Éê+ Ùé÷o…Ö~|1ðñqk'T1G¬ŸRRÆaxG(ãJ÷H þƒÎ§CÙòvxÖ÷ÈÿUNÝ5r.]—ª! ´bÏÿ46wuíÿœÚ*„Ò"¦Úr§® ¢ ?“ù`.uéó a¤7Ôendstream endobj 201 0 obj 776 endobj 212 0 obj <> stream xœ½œû‹EÇUDÍ*¾ß/F¢&AwÒïž!!`ôÀ€‚¿ø›„ý‹|üö£ª_;Ó³{K…@îæfo·¾ÝÕŸ®ª®¹GùÀü?øúÓÃÝ£Ý#÷ÍÞheÜÿî[¥Ø<ši°\È‘ ÿšûv·|;üùÇ_¿ìnÿ0ðÝí¯ý÷¿ûÒ}yðÕðÄîâÁð=¼Ñ°ŠÅ÷QãÞGú´÷áÁHüòÓÃáþåîö.Ý¡í{ÿò6–ñQ —w7Ÿ»uùÛŽ\šáòçÝͧü¥{'Ã_x®^öWrÐs¸úñ¹—ŸTüÁïñþ>¾úuq¹*S»%©Lí^˜Dªa*ì–Ãå7»›oÞºáˆYfõ“•q_)MÖî£f˜™'pxµ­¦†Åá1NœWñ²SánL:ß舓¶ãL:îÒªQuÝKžâ^²r/v”w a±wñI”‹¨ö/Uû—:Ê¿¸öT‚œè_\ðÑú—žØhO§`Æ)7ˆÁ+á´x#yÖ%a\²‘sYÎ&P9.›gâ\¨èùoÇ«©¸òNÅâõkáZX÷!°PnúŸøÅWg „‘’Ø ÓFŒ6û$J‘":ÙßþrÁË>ñkE ’Ç[ŸÆU´·QCøÅp;’äú†&RT{MJ‰q šþ†…#TÖä,EÈÝ·#¶þÙ0›ÎÞli%øØ«¸þÏ~äÞÆ–0Žsñ$Þ²™½ÞµÈ¿é÷ý¨ñy¸-ùTƒe:ÊIÉí‡@8ê0h)‹Sw' árjfR”3‰}wC)ͽÏ5Y-+ÉÃãÔþ»€«!ßFN³ '©iùè?"räiœ)“4L¤YòÈEdú¸CWaˆÈžï·»b[”^mùN|¶]gÆ!¡E«;h‰±üõÚ?ïá¥Í@õ—"ûD~ñš‹ ZžZáÍÆ9»s€ý´d맶ÒB4ØÚ`” b*·jË‹PaH‹Üäšéi‘´˜ "…”0!8!Ìæ q›³‰ë+ßÖysvø‘6ãÈÆXòÂíòU´Ì ª¸Ôg7+ÌnŒɳÈÞR?¢F?ˆ*ÛBÔ}2¯ówV;+LâG@\ lJÏ&sÅäÍóXõS ZŠ†1É] ÚÕÖXÒÝxUÐ"Ô©°.aÀ "Ñ^Ö¦ò¼5tL¥%¨š*‚ò„EV t¹YËì…Ž¶R‚LPE‹Ì Jp¬|,¦ž‰ËYB3_)ûá9ûé(£Åfp-—]B¾“LUµå¬›˜¥µ|&&£¢Æ¤ðßI˜ÜDØM‹2¡Äšl»ˆ£ÒŽVlÛ¹×¾úî‘Ìe´x Êšœ;,–S«™ÛjĶÓòNø•Ó¯‰îÝ‚ó BùF»ì%ºÔ+À<Ã*æ;ædœUÉ k’ïù(÷¤EdÁ1þjöÏ¥ŠOÆÌRå¨ÅkG-!ƒ0Î Ìðu\gsez“ï!;_« %dœILîvZCMLæÜÆ}„‚ ê¨Ñ߈~¨ƒ×Nüx~ù9L6Pôupje är'*úÂ{k#Ri!¤jås‰ E %¥Ý¦Œ¼Džj%@a7„š{ž||uï]´ˆ ºÄoëÀ2)¾³a6)]Å<»½ú€®r.Ó£rõf^4eZ—¹Ž¹Që™´ì ³³^.Ww ¯c)DYÂnG-9™•‚¥„ëAÕf›£ì<“b–ô§ïšQÖÍeÄä+@ÅV.RóY†YTÅ$35¾<­…¥yó\,ÉÆUaja¨qŒHùêLjû|<Ç*KKg-9k:6(@¤ëzC¶+r3ï*ËkyÊ¢E`µÞœ´7Ý!Ói‰L÷½˜qz+šjÊÃà‰¼ (¡¾8lXN‹¿`¹ºñ$S»GÑÞ¶‹egZÚk;ºh᧠À¯è¶äiÂíuƒ~¸šÏ¤ŸšgòÖ!7šád'ž÷~åšmþÙFáÃáÌM«p§V¾õÜ*Š¤%Ÿ9/vfêUlzˆ·@e«^Êháç”™6þcuò/7eÐTZØ…IÓ°»Mµ&'¹-æÝx9‰&éhž +íü°ôc:ÚéŒ#-zÃ86‘gÓ”Ñ?ç=|¶Ùñ;²®BÞŵ~&…aä'ÞœÍ#/ÊŽùy]V» ÉΔ<íC|±)^2<²Î}â¤Ô¤ÓÒ2H_h±,«8Íaaö¿>öÕÝ”ÑÒ2(óäcªŽA+”禓-[iql]zNGeŸÊÙæÆâ°§Gu–*/Ïo£åWv˜9£’•º`ù(Õa@¶uˆÊÎF.À3ÿÌg‚]õ¯c=Ò¡ ‚»Ž‰üû°§FØ¿ŸFÊÿû¯JàBendstream endobj 213 0 obj 2522 endobj 220 0 obj <> stream xœ½Z[‹ENBÔä(^#*#&f£™Ù¾Ît ººàB…¾ì[Ô!B‚þ"ãí_ZÝU}›Ìåœ=´²Û;Ó=_UuõUw?mXÇæþÑÏÇO6O7Oîÿ~<~Òœl7Ç_6¼Ùþ¼ ¯¶îÅe§­L³}²9jïmÙ¸gÛ7Gk´²ÚøöM×–M˹o¾ê ÓHaýÞp€6ҷߦþJûæ›[ýüW{ ÛûæÔ• ß| ›ð¼Ç?œßóa4Žß~³øéû±¿Í>Æáá#7Ú]÷ªÄO½^•ƒoD#ìù©¬!ðñ5×V ׬ڢ‹®bg)pì—ÈEàki™A394±4ýú,¸ÿBÚr„öÜÛ¦|󹟢·£K[¡a@ü¼ùçoŠ°Ðj4CTb6åÈógøPÛd|cÏwƒ©Ö¦‘œ©¬œJ}1•¨óÍÐ 8klù.Ë­â ýð9ƳŮ·# |ú Ÿ£·ÉÁááCtpøì›ô!3dqm]ìì—T3ð,ZŒ?¥RßÓmó=,m˜L=Lž†ê¡!5³]ošÞ*Û €“³ÍñÙ·ÍoÏ~ÿisüCÃ7Ç߸ÿN¾û ~œ}Ý\ÚœžÅ¡b8ŽêŒGóNï7ÎÎl#¥c›Þˆ®÷|ó/ÍUL‘žÍOÿÌ cäz`þع֦ùÅj =c¢ª¢Wf¨áw9YyÆHm;³âw>ò;QÇšß%ã{¯›=Ñ c;Yø]ÏR¢÷»ÙÉï\ Ô1\1à™ýæûŽ~7BurºÊ™OôÄXc¾b(yÐPÑ8cV'QÖ…bX.…8pJÁçG>GG†¢LÇÌB‰Ucr¼ŽpÈô†‹ Jšl*‚dd]¾#µ4û‚¶á¤m>^ƒV•L™UÆ%]C¡ÔÕY (¥T–1ß 4 K),U©väòJ"cëò/ÄA Þ )KPª’)@qTª=|ªå¬tº›—I+ôø¥Ð™²†ïìæÖ#§Á…–Š¶’ÔÉu)ÚÏCÎ$%õµEqAÆ ÃkYÇ*s›0nªõÖ’MW)n¤ôÃJaã ÔhËKaÊ©`Jgb,A&Üì®Jwæ©Ö(îÙIžKÀj’æt#RÝ°n+º°A‡öèíã"Ë^ö¹Šë±fåê2‹«+^•øÜLtÔ'á÷¥ÕÁÔ¤>…D}÷ÑMfŸ9Îe¡1…ΈOÆ=ƒ¨$7ûÐ]ðAUºÃ€¬Ó]s(Ý @s¢6ÝA=É}=Œë‹Ç¤Æ6:T*'‰Žh½LfdU]2Ó¸Õ€µòŸk`ª˜w±+:¬óJp±‘©’I{n+RmÂËþå~y}¡u Ë*e®˜e\ºÖ U¥/íÛ‚ÈŽºäíàQŸ®€9”‚4‡¨6Aå+¬'wHÙdJ]Þñ¦LUˆý“5pUyHJ` ÇC™²M¼s9d^ÖO%æÀ4‚ª„k¦w¢'d®ç¬a§ˆÕå,pŠ“ï!ÿÍJݦ*Ky0ÔƒNu=0ªMN•a¿~ò¼b”¨§dÕJž 3ë’˜_%€”&bÌv6S¸CIM ÿ©qÖÉLWµX)ÂLó&~æ›ðmÄR¸ÊƒKåTƒok׆f‹±~'AØúÝŸó^—½áSˆ–ÏJ±®*Â+#œ+ícB*`vÅîº,åZ*«äÒYΠЪr–‡–”Õ ’«&± œ5wÜ@¥àzÖX0².cy#¹ÔTO„ ’ »Ÿ¯€;”±$†¾2cqÓ;Ʋá„îzÔï‹9½¬C½ÔÁg.ŸÃgÐÄ›ò%9¡*{¡æÜìR àj²‚SËÈ—©—ùB3rŽL¬µbp›¹¨ÊÝêêÒ7”iÚéz¸¦&¡!˜‘{ñpeì;X tA'^á »"1Í”g--/¼tê¼`zUšÃ  žhnî°%€9Öø`ë_øà½ð\aÓîÔÔ}¶¹â'èÐø/Š­m‰¢Êå«e…̬K\`¦žÝÀŸ«;#´ª´å#0:­\ªj@/°B/”×Bœ&³ãíûå#ÿ`g]óv®—’LUëÝ"†Zžî}ì@Bã‹Ž t™±Í^ù|4¸P˵gðK]ŠóAJ{øs©&€9”â´î«YBÔüšÜuA0úìMºC3Éo:»¯é²ÚÂ}Éõm¸àºdq—7BM2·KÁT¥?è/l»]Á ¤cŽQ´¿ŽCˆtq/õ…ã4¢ÄAv¡¨ÔåGïˆÄ³I)€©Ê~Š¤²•îó¼2‘ývh¬(ÓÒ0¹&ÊwvÒFÜ(œj¾$^ðQ]®ôs\)—9üB—œèrÿ[p;›¥}àá8î}’»ÑF÷ï?óÞÕÓendstream endobj 221 0 obj 1845 endobj 227 0 obj <> stream xœ½V]k1UñAV©•¿ ôI›É$»É£‚o¾÷±o„ õOù7ÍÇlvf»»¹ÐÛÉÍÇ™™sNr­Ì(“?ô}yÕ]w× ÊØøuy¥>î»ó Ôþ[7NÕù‡åo0jÕíîœî¿wøAí¿v»{9ÎÛ„ÔДà0¨|,ÑÅÏú…êF¨¬¯³/NóˆÊš¾ <È1(Œ|³Jôœ`Xƒ%>"Ã47EaÔ˜À²£ÒÙºgÐrVW³ÒôJcˆî›2„ש°”ìÃ2Ù…¶<.¹¶.>&Îóó£_M'ƒ‹+%ÏSýô[JÓÖ•ï*Œ!* `j%ŸµÔ©M?h ëÛ¸ l 7€yØ F*Û(Óàs·{rz’ÖZÙ¸ÐoŠÃD’T 0‚C£œ¬¨*Ä—­LŽÓ±®¼;–ÅÍé<[Àšüë:H¾7"yÀ ú-­`-t6‰=¥Y©˜„¹æ…?«Áà'¤¹´¤±R’ÌA*­Ir¼¥’µUDƒ÷U ÊZóØ›jª¡§)÷©”àDÏX)¡òæWM.0ûhEy8…XD˜ˆ5rÏ6óëmŒPöŸX&šküœ8u@Ñd.·Iv"èQfÝÌÈpî@¡2!á8ád_6Yñ Fó¸èÆcIé^Øó½<Ù¬ºbÖ/®·"ÿì¤ü §çI@ï7Ônûáï-‡(<(rräK„_‚ùª²–ó+ݾÚGÚR¢›Ã,Uï¸[$ h$±ÎÍZ™œv”„„Rp¦ZäÞs_w…SO+¥l”2bSªà?¿ï²{j¥&ï¹w±ôr2Yù* 6Œâ$U,³(ß’Ù+7ž%®n>gäA£•ñŠéŠ;OÈOO8FÍP†gĶD|œ¹„\ï¸j&¶ŽõÇhäJtii;)7ÏÛ.v$‡¡f*ž}y;¹`Xêߊn#ÃžÛ K[ßîìäŸ /]ò€Iä1.kæ 'CÜ~s1q@q˜GÆAZ?hw‚X)†tÃÌÞ Ö2u…ä\|=àA*šó~Ú«/]þü7Öˆsendstream endobj 228 0 obj 824 endobj 231 0 obj <> stream xœµVKkA6AÆ  ñ â¡=e£LìçôôMOF×Ès‹Ä°É!ñþ ÿàó/Z]U=ݽdÀ‹,dSÛõøꫯzf.ä–2~ø{神7s¡ð·ôµw$Íšû…³ý&¹¶ñ+åV/¼öbvÔL–7g‡FY1{ÙLvßFÛ€o´®Ð¡ 6›­çP9· Í•ämèô˜Ý=ÙwÈYÉ®>V½/­9ø.;kMµ×’ãH"Èífòms#æé5žÜ 8¿ÐP ¸«tü l¾Gû"ÚÚA¿¸Ð=`¹Tì/”1ÂØ"l-sJhÂÕñ’ ¯R¸Ê3ƒôýRBÈ *wÏÛÎå5¦hÞGÖ­sÑ'2¦™¸ïè 2qDÝ:WÖEe)œË¶Žp>¡`ÈƵÑ!ªbe²A*)P"‰Ò$vÂÎ{x¹´«‘˜šƒ@¬1.ä dYQ14pf±þµå˜ˆg@Æ¡ ¤<'¨jïDÛ{lkJª ¤¥¬».ûÁ¡*!+Õx_üÁt &ß1|V G¶½ËÞq?Éù56‚hÞDŽ5踅‰•mzÑò>H¥x÷S]6[kwô*ÚÖ»]à¢ÏþN?¤ŽuÙ£â=M¥(ôŒ‘MÇ?iâAð½sH© g9ìÐéÐèëÂHâ‰Ì"`Ί\öÙêi¾'€†é æãŸúMÎcTõÕèauzú‘4j‡žN™ªWf½ª¬Wàú£ ©L­õÞÿ%år¦Fªxö)[güqãce±%m²T§Üq½\Jºl¶PYëP5éû¼}­µƒ´Óž(© eà ÂO¦iR¾îm%}F3ÊÌÂp»z¸jq¸²®nqÁµ–¯_0<øŒ5õp Ñi>KòeŽ8³îÇf;ÕÕgýù3ÒvìªÑ©âvuQfCþóaXŒ ‡U îܾXpŠ‰®¿S¼Œ•1¥®™– ´eë´Ÿ’pÓkÉ~­µBÇÎ5:Á­ƒ:~¶)ÙQ¬•”IÂÕuç-Sÿ6\¦¾ieQÛ E ×Åg·! .”š[âx¿ðX=¼Z:^MíøúÙÛ—¾2»B~8å—ò¥—“Èèv|¤oàK¹®$WÆË/=†µN¦'|7ÓnÒlÖ((îè|wq˜tWìòþñÛÕ‚ ã\F1 娉 …g½L=M@/•ýþA×`ã-ÆHo3RjCGëñLì4ñóZ/”endstream endobj 232 0 obj 967 endobj 241 0 obj <> stream xœVIkTAVQ/3b"Šd¢¼ØÕÛ{í%(x2qpä”àAˆÿ•žâ¾ü:»»ª¦»3ÉaRSÕµ|õUÕœ ¹BÆ?ú<>mΚ3é;þ8>O'Í£'Ää]æmüǸnÏ Óù=/&§Ív'ï›V °FLNšñ­(kÑ$ñ:«uŸä­(K¡4Z~`ó$.£<Š‡£,šñúîNô£<>¼‚–2;ÕBƒMâ¥iJ]i Ò'q¥|ºJºÞf]ke/Z#JßÝFwÑÈaZãøê‚G—„"PÚàð¾+|†ú¹¬Ç©*!tQ¦ÖgȤДýy™îò­(ßW•_[Ìã-Ù¶ ë8"¿£¾á¤1Ìëdm„6ð·(ƒ§Ö®°Ö‚´Gh¬©éß“6<¶˜Ø„›*/ð¾¬AQ{ÎYmdVCâÀIà@ìñAŒ¸“:Ž¥ýH6Î'ÕËÄ” $?“ÿÂøû¿ÁÂ`ËÃã6@Ž9üJß…vydíMB¶4¸/HÌ-Ú$[«ò<æ¿™’VŸ­1¯ŒªiE¸¬".(\¦˜ZªL¹VÙ¶óFzlC•P%º”™*ƒLG¤Ÿ3"±ˆ×6ê\_I¾”€`\椡¯¢è‹ëãô©šéÚÐU1@kdéh uYE#»K(“<ÂÞÖ“tg0f´Ô˜Ak4¯6K]Ÿ:¼ýçwdŸs&°½§Bï!ƒiú/nëâMÂ-ÌO]A4!Ò*ÂüÒ‚œùTÒÓ-ÆNƒ/±“P«îUœçÿ§šÆÉá|t²jjK“4kUkAJœbgÃVU]‘îㇼl^ä«åq‰ÇFÏkjf÷Åæ’B;ºöNçÜ¢LìúÌû¤¥Ú˜`d?B÷º[g„º,&2BC7ÏÁèÒa™ugâ¢T´¦±Ñ‘äÄs¬Ëøpú83ÔÔ^ÌNð¨`-Ÿ¦·XWÙ‚¬p¥I™. U,Ϩ–EÆaukíó% —µí0øU>q>ç’¡©W Æ +]ÓZÇ œ™O…”˜yôi öñ‹°ûAeIPÐÓ%¾”NSXµ®žÂvD ¹jÊ‚%âbÓ —°\3½«©\žÓkL³’Hm> stream xœUM‹1ñb+ºãŠìª‹%;ƒô˜T>:9*¼sœÛŠa„ñGù'ôÇ™¤*Ý•vf`e=•T^ªê½ªìA­5¨üãïÍ®Ûw{Ðe­~nvðaÓ½{6ߺêÚç?Ã:‚óv°ÙuË«Õæ{§Á[Ø|í–—ÙêqDU~å…dG2ïf3]£±˜PÍbeË€‹ÅÚþ,Xt ìíÚïÉû!o£õÅ~DXA`%ä04gQ¸®ØŽ°Ï+t‹­M(ökBCc4Êé_Å)RÜÉñs·|¶º.!FÓd?a0ÚóÎÑÐøª8e§ èYUIW2ð\Þ_•<ôvÐäõª¬Eðtõ}‚ü¬®"šëoÞ4’ÀT7TsÎŒ<ÜkÓÖÕ©‰¥ÞZ„~°ÄÄŠÇ ®HR6˜Èx\$å@GU£ªyÛrcÖ;Õ$RÓ褯’®8¨¦@tð¢æcÛB…êTb¢´ÛÇÆ{[l/‚ÌLËo*ËÊÿo†>6so¬+°k5Ï (õÀPX$ÒŽ7·IWê|H¹õÖápBÕ<<.ØÂã<ôYS¨…Æ:wÌüE“Š zYA¤@µ@§{„3½äÉä¨ÔOy×:Yé]¹âÑáÝg´=P©±ìd–Žó|¨*1ϧy½ í)7/&{ˆ¾1•ƒ£z•Éì±’£5ÍA îÄ|Nqp™¶ËJ˜'^°ü ž×‡I+#Nô6ߤPT61<…Ÿ0•á„ ŠnXýãlbaÔæåHhª¡Z•!¥9éÙ«shBå¾ÃFV¹c¼ä&»Ì{xª¹ ›¿Å8Ðt€9.€-۪ѣn3?<#4³þ|T« 9«Ä5oAÕ~©w —9í]OÏÄôlòÃ4ÖŽÅÙ³ÂÃ6Œ][ÓèÑÈÐ̶Yú DÎä%gèúOÙü¸/]þýÆù¢endstream endobj 257 0 obj 726 endobj 262 0 obj <> stream xœÅV˪1•»Ò¾¢u|– 8ƒô˜w'nDÁ¸f9»+.„®%ø~œ•T%ôôÌèJfÑSIºRuêÔ©¾±– ⟗»îª»™Öòãrï7Ýëw aóµËGûøGµvà„^{Øìºå“Õæ['ÁØ|é–‹hõj¥DZøÐdžE¯‘*™Íd]DKƒ ÉÚþH¾4HO¾·ßi¿§Ó7y[—ì[äËW¾Ð³šw•$ç2û¶äûNvÝú–Ú'û9ySZ7Þ(§s¾ŠS¤¸ñà§nyoõ2…t“ýèSƒ–6™×JDCsV„1;™œ^ Ó J RQáýUZñ˜9Áô&]ëÉ~&³ƒu¸Ö/Ò®‘˜9¹~›Ü ·RSZÏÒZGæŸPU|¸ÐëIUçz ¡É ŪQ¤&ñ…·ÓÕé7Ÿ&½Þ'ÿ¶…Í5/(¡çè|ž·7v)FÏ©žåÓCC)Ûà6¥”aŸôÚ\Q2róG+T1išée ô&³åwZ³ˆ÷‹3ù_%Æ„b­ª D!”\’í’ßÄ$ÖšèxŸk€2‡+é5Œ—I ¶|•KTà‰´™¦º™š„P¹IhIh R9X…УäÚdaé¹ß¬¸Ö¼'*¿eÁÔcãFþó™d_¢ÈÖÊYí?ÉÇ=1Ýc>ë_Ó܆¤xF G­áÛ÷8z¿tóQjà UVÕVz*G|šA¤µh±”£7QfP™lr:‘e£·â0Cb‰M]qÓôzŽâ輦A zxÐÐN•v¿Î@骟GâÏ&ƒ¡ÊÞt…-´:!ªÿþ¾ÂQŠVÃ~O2m½—KP¾ Ç‹-À\P†6Š¹Ñ‡oÓвEç'uúvÓG$9Ž<·ý¡Œ¢nZQwGHxZÔU¥j¨J›‘òzL‰Ã@Á}Œæ‡ |îâïëPsendstream endobj 263 0 obj 782 endobj 266 0 obj <> stream xœ¥UMÔ0 …ÔEìò!Ä.̉™C—ØNš„ ‰¤綈Ò ÿ€?Ãï$ŸÓ¸LG‹V•¦ãØuž_üœ¨+Ÿò¾Þv»n˜Öêëz ŸÆîÝG@¿w5´ô@WŒŽ¿ã¶[ázüÑõ h4ŒßºÕ“h3ôˆÉ|PÝì’ý&Ú ˆsôæg Oæiö¢ÏææW´Cä—nõlý6æ!Ÿ?<É‘jJÊÀh’ygɶ±¨|2¶ŸžŸ3“¯XÑgÿû”ÚË©@¦šÁßkpJÎ`|Sªæ>)Ù 3Å]AOFXÄLJ´0X ½6œ¼NkHáiÀÄíyàvÆA4•¨1'½,Nã&3ì1ðTC;_Dƒ€ÐÉTnh7ÊûÜ•4Ÿ–P&>Ò¾!^ç’6«È{¿Ú³l&–{²g×|AÂqMhCÇ0û…>¯Ø}«&%àù66°¢ÊY­ ºµ7#—}°]4“=Ø.‹·ÇU$o²³fo¥É\ 1ÔQ“¸'vÎ[%‚]x©}»ƒ!ATæd´nˆÂ)åývà•»¢Êú¢å¦'S—YÛvYÏËÅÌn†|p¨Ð·xʼW¶Ü[ap™guÖð2 Ðg@Ok3A®‘Â/Ã!ÉÍÀºÑz=8ÐTêyY’ÚlþŽæç¾vñù Ù·Ù> stream xœ¥VMkAEñ4ŠFãÁ€` ‚dbWLwßTð¤aŽ¹E<Ö³Wõ ˆ§€þñ/èo³««:Ó=É,!²‡Ý×U¯êUUïÔ‚¢|vën ˜×Ê×Á!<»‡a|Õ•£=ý°zØÀ)¿ç`<ìV7vÇ×`|Ù­n1ò˜Ñþ[†.fx…PoÊx‹qŒ|ÞÑ‚E@£3ÆÙ…‹lÑf¸ÍÁ]Ù_—tÌä a=6L´2¾*»¦æMŽNû”‚cÚÉSð)²l[ÓÂ2Ö>¥V¨¬òÊôçíN^‹ …ï#ɪژG¦Ð{íÀh¦t’"}<§('£s“% .˜)8ªš¸)Ëèp2m b c{ Û¾ÉQ%&>ÈAk7‰O®ÔbŒY@?¦£Ï»ÕÎîýŽôñ•R ¥ÄT¨…xZn ãؤ•iâ²jIb ·ãp.Kð:ªYô¶¶K½P¹.¶µT:¬9ä{ù²Ç˜ê1Èÿ¯ÇtÔhfó›Éûrý‹œlûÓ)®¾e©D«¯I+êb¾øž¶œ&ÑÙò»lɹtÙ6¶½Ë¦Ž²)Ï?HF$ùGeˆ±°rxŸëæÿ›Ù¥P¢¯bK»\"4²ªî:у^TêÇ42¥¶6*ÎÇŸ9×0nšÙ\Ìj&¹o‹Ù.sj1¥ª]> stream xœíTK‹1Öõ¢QÔÅ‹zÐÂÎ I%é<ŽŽ.8  0àeo«„VÜŸ Þ{ FëÅú /ØB†g 6&H|¾=¢/F‚qŸÉ°EÌÖÊ}3<ïð²±®˜\ÎßÀH,áXõ: +`§²¹•ÆÅÁ1ë9_OµÍø\áò|DqÀ\%¿zà,_¾Â\Ʋ¬í'lÎÆ'‹±-\%o•ü}&sZZ`ã¹€¥¶ÇLe ³³×Lð‘> ®)½Zª±*àL¯*Iz¦<Áz3^¬êlß  Ý ªr?e1¯æ€u_@òÃÄÃÄÇ~â-0|Å0q(¯ù.è”áÛaŸ øÿ¶½ÛÜ ò'/kg°Æ¥¸©;¤Îð¾W”iÖ™Æó=YhJ*,jÖ†§êa;™Þ `C4z5mÑS쨩í™úè~à ûlßÚ3ºT™êƒÅ†p~X$“RW¤­™¼‡›;ÇXP8ÄW¥Éx…ãè´u À…4™ŠñôŽ|ötï¡ß— Æ·è1¹{_Ó›òˆØšf®¥·– F9icR6o­ÃÛª??Ql[*­J±kQ±k]Ù³?*œ|Γ¸ëÜo¤ÝƒWƒH:®.íŽ<Ú€žº´l´È1|áFÅñÃ^š£ ÚØ…+@ÆaaZ j•bPíªÂ‡Oú¥0¿æÂ`]Ú+´ñVf[fæÏW&m¹ÀCù°§ñÿ·è¿´E±#À—$ÿÒ8´†ÆÙÜM«çD Ž £Lóò]¶Ä Öl€VÁŠ@@žTÈl”ŠEÖÿf_ý¾bvZendstream endobj 277 0 obj 700 endobj 288 0 obj <> stream xœÝU½n1î÷(¦K(L<þw í…è”+.   P: JxˆðžŠ±=^¯Ww+A]±7žñÌ|Ÿ?w Ÿ ÈôãïùvØ ;À¼V?ç[x6'Oa¼j¨H´‹àe„q;Ÿ>7zZÁøf8¾L¶PÀæ«dJP!fó,{Ñ‚Ò!/œ?JÛLrûЈè²y•LëAIí/9›7 šm§f”Éö{nF!fûºVS+Ýüã~GŒuéKº‹îšBùCÐ+øKú{FÒ¯¡·Tk–z/™oú^oUÎö‡=Èjáw vžXà‚#Õ2‘7ôrÀ°ä(®rd—)Ç;}¯;âJùÚÜ&ÙDÙø"Ió(Käë Ó‰±©áSMÆòÛÌIj•Ü! ÏîmZ ›9œXÒíÒXSòcö’­E…ÌgY!ÇÈz‚œòâpM¸æP„2®&~ÿÊèÍG·o>Vrú1†º{YlGÔöþäpÞ–IÂùÿO¥W×ÊáR³³9¹›äŽ¶ÕN^ÝÎ0™s‰ådëÏ–=èŠ:Κrׇܕ0ÍèÏyAK“^¾ØÑÅCý¶­nk‹ÝËJ)ešÖ®'U9’oU^ænª8¿rÖ `º³VóÅ=bõ’õ|„³!ýþ endstream endobj 289 0 obj 595 endobj 296 0 obj <> stream xœ­UÁŠ1UñÔʪèA¼AØY–^S•t'¹©àÍ‹Ðǽ­xFÿAYd/ ü"ý(+I¥“§ÇdØ©¤ºòê½—êÒ' tüð÷ÙºÛti­|­Õó©{òLšÞt%µ?ìèNPÙ éÿ´îVצ·V¬š^w«Ów16”£1èÑ+CqáV\ ß}IŸ‡`R|/=`”Rx-ëÇÝϹè!…W8W“c ù¨ƒf ·s¡!ˆS9¼™ …CÎ>=J+65ÁaZ|ZŽ³^bËáUÞ6:ƒ½c¢+Ç©m°9>–òFµM"8]§lgT’ÃPÓc±à% ¡¥!¸%B{T>,¢üIFÏ„0Ç,Ô¦òA'ƒnË)d¥x3²sSa‡­ØnhLFÌ#Ö“–[T~õ{P‘ãPö°M|h‰GƒMåIHc«p ›0n£^rA¬®±öAjäÝ;œj†Š[×J¥K?^†ƒ]Ž!·ùË+Úm‰Ž‚°Vt¢mël @†´|ޣ¢œ'=H­ÙUÌ x·Ø =ø2&þyÿG¡z”=´ÖžO}œFM8䥇i)P§bÑÙ_åÛ´¤6CõVv-*V¼’a+…ÿñ6ô¡Ï»ð<`>´S÷GqG>î#_[Ü2–_²?åZ);·Ñ"Ñ<€3Àyâ|Îõx*|)N1-Nà‚ß[Ø?6K-ö~•÷•¯-¥&`iÚÆÙz5üÓI:²^ñ€‹Z€Ôù ˜€C¼{t.èÔát^ÚÚLh2M+ZêÐí›ã`\5²™_³pc« h½¨ÂŒÔH¤v©'‰t$ß÷Xÿkk÷oRös~9O‰ãì/Úc²G×̈X9?þIŽ"n|h [ÖlÅ pý{l ûY=æ¥Cž$®F/&õª‹ŸßÇƸendstream endobj 297 0 obj 719 endobj 302 0 obj <> stream xœµVÍkT1W/â«h«Ú š‚ÐM›É÷;*zó"ì±·Ša…õßÓ?ÎIfò’¼¾ÝjAºd2óûÍçn„º¡Ò‡¿¯×ÃfØÈgåëz->¬†Ë÷ÄêÛPTeúÇêñÂ<þ]­‡³{ç«ïƒ4\«¯ÃÙƒ$'CcŸ¨²°Ïwѵwb¯~$Ù$Ÿ(Ó¥Ž:‹ìµ%í³t¢h’ŸfÑ¡ ‡ZÑõ³b.K‡ôغ–é¹™™Òx>ùužàöUE_©bœ( W?‹Ãh;®’À>ÎׄvD×¥”%PT‘ñà«zòìj¨6L]ºE®åLãe ªèó—µe@VÒFC^ç³c ÿšÕBð¾ Ž*±šÈÙ¹±ƒïgäÆ»’Á%ö6+cz”½'|<ú–džÔ¸Â\l‹{ K¸ )oêSDé Ö ŽÇ"ÿR9ªã¯£iýÐå/¾4 +{Áüš¢4»‚®é^t”éåçlê”,A%ŸÛI…¾ÆY"â©=z…áv¥×‘Ù®b`4 ºç,—N »;ÑlíÄÚZo¨1­Ãn2Ü»¿ó™×˜jòð17«à'SØ498*uáz<6.z‡KÍ F“@cG…FÄÊÇ^A$Ù¨kâCIš,ï•Â¿hîRÕ™2:,Ü—©ºzîÌ,´Œj GO0W3÷”à =aËÊÏ9ÜVÁƒ…ˆ¤ÍÖ”7æ8Éû\EVHSrr#g了™­CÞH¥È¥wÛÜV8xãÿ‹ôØFztõ©ÄäCèçîÍ*Ón%:SºÓîg³zUhøYVË^Å·…íÍ 4ä°}R„|!^Š'üÒ4žÔÔw#ag$TC‚W2ÏÓ²’-x8õœjx ºæÇ ný—¼÷ŒévhYÖe¹® ÍìÝöƒ·ŸgÏ\¯\™DG¥^´ ³E ý¢ ÕI‚Î)J,mmÑ:ˆ'èúo¡ïúÝŠÍЮÑ“ÓèÆU]é~æD¿Œ ‹32¡Óò€4.“øi%¾ éóŠ¶i!endstream endobj 303 0 obj 795 endobj 306 0 obj <> stream xœ½W1o1 †Â€®¨Z¡R‚„ÔWàJâ$w9[¤7²1 ©üÄ ÿ„?PZøE8±s—w÷^ßPuxuâ8±ýù³ïDÈ%¤ÿãߣãâ¤8*¬ÅŸ£cñj^<{)”˜¿/¢jéÿ1U}`…mœ˜³+ûóE©…²µ˜¿+fk^öfš nxm³Íý½Bã¹°þöéU2ˆ7ÉŠ`x߯h)@ZZøéïÒipD~^k iÏü :È·‚hQVÝ+uküN4¤èRÓ$W—þ¸6¹9ENoµ÷«*¾Ûi Hú›t} ¡Ó¾RlŒÚÐÂó°ë„#c"FÜöéQ£7Ë(¶ÊŠ”osX8IœZ’® éÞôL@”X0†”}ݤw×*‹2HE¨êtQr ª(À: 0Ê.I8*Tt×ãpÀƒ´¬ ]ø ,5ØÄÓè-äë=¯–¥hêL·$åuVÖªIáÅaÝåÝJwQÅk´Í‚VféÏ×4R¤Ð òS‚­†t“6Ÿ H³ª(9@íËLmÛó‡˜8êïíaV×Ô†\|¹Ïmè3dk§%©r§Ke†Ò1’ʨ=XOÞO›¢„îþÝ–HCAùE¤D»g΃éF4…sF˜é¤w•£ìí ³‘7˜M¾ú¯_ÀL—œÌG|;¾½R²ÎJ@5tæKt–žô- ìwŽ:ñkd!pªc!”ùúS6Åè`ßëÜwãÉÁy+³HjR_Mîk…”g;êÁ§”:w0mµ”‰ë Ð!Z¸Æ™³õTžk'nW+bEÄVl=$n³)î{-|sb‰ »Ç¶ŒÍ+£N3Áî¶gÓ6Ó»CGëõ Ýû„TˆìyÇ%jAv¯ò#l•0¯AÄ!õ°Ï?ÃZ-•pcPºš*i岺d¤ð-åÐïžßÑYtb÷É);ZÑiŽ"»LeÇÜ 5IkÂ6¼08`J›t`ˆ¯Æ|7¬Ú¥b‡7¢²Ì0ª ‰¢à¤]+øDÈÓ)— F%ÔO™—ù$ë>c¨Ǹ¾¨áôÌ­ö3‰déŸä¯Ú/œ#X=Ÿ*éQø ‘& ªthC„sý^çwªñq¡ù«†ÂìÚÁ&’ŠâYkˆ> stream xœ½VKn1Ý÷)¼KX8¸üiÛKØAH¢¹AP@&Y@JX!!6p ×Èø߆²«Üm÷|¢°@YLÊvW½zU~å…P; TúãßÃy·èòZù9œ‹Û³îæ-bvÔ•£2ýc‚Ý1«(fónûÞÙq7gºíÝd)6î'C !›{ÉtZHP6/¼N ÒYaÀä…ý¼`-‚èóÂ×ìMòð0™ÖéÍ¿Pù‹^˜„m8ï„ÑÙ|•÷µ€à³}Bገa<ŽŸK¶WãóøñÝ{ Õ‘\PÞlQHŠ¶”Ç·´`Rê„d^0’Ç5mOhÓ°aüÚ[! ¥õ–p#³¦Ý¡íë}üÀXÂM5ÂÄ49|Aá€izɼhª4æD u$po˜RɱJFŠÑsÐm °!o…8 Ú@ªª%æÌùçÈ8/˾ÖvÜ—®B:°´ö½Àë[Ó&2æi÷]ÏÍp€L8ç}^×ó‚oˆ±ª*¾Ñ€fÝ5€”kðaèc¢ælÉò®¥$ìHª8Ÿ~R×ä4š±ßS?sC_ðÝ6Ð×WÇ ?Ú”>eN”Ρ>b(<ª•¯¿ÕÃÂeË›±º,Jj«ô?°ù~5_ÂÀ‹Ö÷néwßT‚û{¯|ÌöõZFêˆíµkï0‹Ù£¡ãú2/¡v-ê*ã,WÆŽ±’X°ÎE0…ÒP].pBDSą̃»qxJÈYt×äÅ ;ôáè(·|¸eNW <šEøöÉ7¬Òªóbšz—²ù9Ðk&8´jqTÓ!ãÐëçØXžr+ùîíJfk5÷xZ·¼óñƒâj6KV¥A5ŸèÍc7Îcœiþ (}EVyLz äX”qS`'€÷ix±ÄÚx‰~ÓЬägumOÙU%Ø}¡R"š*®\ä€ïJ¨t¿)`|ØÀizãL{£B@½“aî7óê-rÝ[‰¾žƒ.—¢<'íE'û× 6G~–_K–þnæÙ`Ò»°~MüJ@ÊÀÕ4‡am(µ¡NI¯Œíù‘ôtN‡ÊÈZU¸tUˆ×󶻫êô_]©)#AùB®±‰9Ý?%´oøvk§+’¯Á¶Eí§µè§µ€«jQ©Dz‡MÚJ·ó¦æ5*‹$ã’ã€[œ_ȘÌ;3±ß¥¿¿°Rå.endstream endobj 317 0 obj 901 endobj 327 0 obj <> stream xœÍV½n1î÷)Ü%)6ØcïÚ[‚„D„D÷AEDâ’B (¨Q^"y@äi°=ãõÌÞÞE (ÅÅk{~¾ùæ/•Þ5J§?ú=n¶îleЬãÙXãÖfZˆSðõŒÀ‰:†ö?¥60CZx:"ìd²˜ÜZsjÀ\çd{å6–:NiÞ™ÓX.‚ˆžÞçí®‹9£«ß’7?dØ¿rœÁ»ŒàÕ­K,`¤/Ø ÃsË6®íÁ"âWòÈ cY?£GS³¶ÐçàöReSÚÔ¹Q@@ï]z!@ Cå–©v.u€˜g*·ÒU¢Ð—b×’¡ï+œÍ7;QÆa}+¥` ûg,Dèl”Dodƒÿ‡"Ùù±¥þ‘@:á CyWÆŒ5j„q)™½Ì°)j©"™ÌÐœdz_I‘T¤äxÂWjS$´õvjÏH|A 8^ÌÙ:€Eá©”¸ÐÐë\èÔoB”`ì¸Wn l@%ø)sV¦6Q,â[‚ý›‰Âú:±%Üi¢8‚ü`ô ëKPI9Î6ySì¤oùبýCÜ1C)O®–FV1˜È­°%?-Þ¨çbs†0iWR§Èb÷oHXè2’ŸXSêCÍ?OÛLBÇ&Ìm'ÎJ vü–ôNÑ î+Þ'º]H‡5|1¦yg§¾Šú)”ºª>ß ÉÍ0‘û¡Âåé0§ÇÓçr”g®+S³y?óöÎân׊U¹†à©Æиxôßi"oÕúÞ;-ÄŸÌäž ’gÓB1žõ}ÔǪnŒ7I~ÐäVþfÕöQZ>\¨ý&ýýK0ëÊendstream endobj 328 0 obj 889 endobj 332 0 obj <> stream xœUÍŠ1¾÷SäæzÈšÊO'9*xœu¥ß`eW™UPTô   ">ÂîkxðîE}“TU'™•9ôTºRõý¤Ò+¡vA¨ü£çÁrX +eKqe.] ¦ÃSeþc,ìŽÂ«(¦å°sýât<€R[1ÝvîåX P“ê´5Or ­Z™²p”RìJô·‚­·K¶F—p+鈵r²é÷ªº×yãE©åmùÛ iL×Lk,ðh· c‰WÜl,á‚ÂàëV™$ÑÆÖ^RámÇZFdv7øÄûâ„eUØ"nY•ÉýÇê€1ôÄ ¶ÄÈ­Ç̬ÊÈ-%sÓ «™2)Hµ‘ˆIB`ú>Ö†Þ‘P5Üð Ù|gdFÅ¡{ò¤ð͇îpHo:A”kC>’ DIj5âC?ek×·këzFIMfuƒˆH»Î¡ÑGZ;#;+ÀÇ£_ wç“ÓIˆ!üù$¨mLùœšc?žŠg¥½Ÿáoo¾ÅÓÙ`ª8 ï×:, b©»§ù„®3X£ƒQVwh|Xw¬âÂlÕÖC¢ç©¹¿6ã{\ŽÍ;ûù£TH+„ñdû(‘· VG‡þ²;ì·rÖ¾s ][ s†mÔ:ìð°Ç6Ÿš#2NÅÿgQg‘HéüÁð9íSNùºÀŠÏËBL|7e|µÐJû·_‘»€çïcIN–Qç9NRÐý÷’^£¯ñ%µ}š£Ñ kä»’ÒùƒÞ:ïšZ…%ø\ ¸™å+*‡çKï#áI¦dDý‹^@}Þ ÊýÔ~;¾Q@—ßÛÞ¼7üe¦kâí]Y8ê†4¸¤Dƒ5.tw_ËáÕIìù÷:ñäNendstream endobj 333 0 obj 677 endobj 339 0 obj <> stream xœµWËjTAÕøÌUb‚.¢"¶ $Anìw÷]*¸²f™]Ä…!þÿå·ø-VwUßîêÌCˆÌb¦_ÕU§N®¹òX ™>ô}v>\ Bå¹òuv.>®†÷„«oCÙ:¦Ö‡c'œÇQ¬Î‡Cu´ú>ŒF(gÅêëpø4ÁR>.Ë&äñ›4–BÜ}ú£lÏÃG´[[\¾‹»rË»uFOyâIš€ñXöÿÄójBsÏȼÅå-²æóh?/Z¡#Z˜ÆJ4½‹{ƒjöBTÓT-%ôp¸ƒCºuªˆˆÜš ‹gá–“tçAZˆyë|„ kcÌs¯óœÒBøwÈ´ã”e©Ñ6.«ÒÔ¼‚-_á¸ä›–¦{UG‰È)aX’eͱœ Q2ê;v9¹èÖh`B‘í£l&´ZÈ¡&Ç)ÄHÛß!ÂBk×F¦´aü'ܾGΓ·”iY£†£-½èÅQØÇ“Áµ¼ŸÝ|™iY F`+6¹2íÞ&—tdxºé¿á™ˆàâ:m åDÅÍŠîH¦ Ü€L춎ÐÊ)î½këpÔÌ[ª ŒWN·¤ZÜô¡UÜcÎìÈPPÈO›à-TßÅZ—5‹À-c84•Ü,^Ó:, 4EêžSì$us±DšUîEvs£uÀ=Û¥ TPGk4àêúò‘F’¯¯r] ¿AwòŽÌáŠdN–ˆŸ»˜Ž TÀݧ‡”?m›ô8NW)¢Y'DE˜‰ë‚@¡*[HÇäâi )æU\'€-ß1ŒäH,1ù°Œ‘šÅ4µWAÈ.—6 K«×Ñ ¾*lÜ÷ˆé¦Š-´£“$j×á_U‘·g¹£×k‡¿©ó ÐtP´ù íLÊM/v‹°$S˜È{t¶gTãs–)˜L§ŠxÍU×wxMµd©×k’Ùµ`ö"ucõWm«…§¼¼Ä–È h"mKEMÕ-r£Ý¦‘¬G! F×$„ܺmçÖmý¶‘”ìré¢ôÌ3óÆ®Á´é‚#Kn!tí‚y—ÒvÁiÕ3 /õï¬Y3ä}ó6 +/½‡¬>RAx’@‡ùú+?ôO{Ïž’<¨ÍûgÒ¹"4kðÿ!›ú&dsnäJîaÙL¾mA¦¹'ºOŒ³ËƇ> stream xœVËnÕ@ ]¦¨@âÑFBê­ Åö<’Ù;6HYv׊ÒEº|_Ë<<ÉÌp“ªU·Nfìãcû8À+ ò{³ïÝ(>Ë?7{ø:uŸ¾Áô³ËGûðFÖ©«¦}·{{9ýêzL ¦Ûn÷1Ú ˆÇh_ÿˆaúÞíÎ./:ÿJÙøêq>ª†h¿ ¶GàL4_‹îÞ†»ñ4[Jž/Ãÿ€ãƒ'1¤·çÁ`+ù¾þ#ÁÆûY¼ .$Ò ‹³ÆU0K—¬“Œ2¥bb™½ÜJ˜/Žµ‰B%ÏÓaâd¾Ãf±(RîÝ\,^N£_%åyik?>Œ6Kv zÉî4ƒ ±~­ëü -$‡‚Ò9Ð\V@€Íõ¡QUÌõT¹fmK®zNæûøzð°zC:]Y:3åòrŽàŠ¡}¨¬+–èr«¾ÉáQ•ì÷â:׊\Íb/™Ÿ‰7n¿ÊHœ«z]Ùǽ4~ìdOƒR®"ÝnúMÅ9q™£LX¶lå×Ô~‘Z®ÀÇp?úTCÞ‹¾qɪgãݧècìqd‹Úö~šiqØ%± VÅP˜¹3fNi(„‘b˼PóÖnCe3®]÷84W´ÙZ]X»ZŠj$X¡ÞfTº&{¢Š>?k…¡Ò£ÌëêÔÎCPr\-àÿ³í|> stream xœ½XÍnE¾ïSôÍá0NÿÍôô$nÆ`kß ÈD!–³Žø‰@€@ Q¡"Ê-WÞ€sœ£`!ޅéªÞÙãHQNÏt×ÏW_}Õ³+¥wÒùþ½v¼X-VÊ”gôçÚ±zo¹¸ú®2jy´ ­]þúÝQ cØjy¼¸òÁ;Ë Ô¨ÕòãÅ•ò²³*Ʋ¼‘—Veñ%¾3z(ëÛy­•5¦,ïÀÞ6_‡—F÷uÙÙTgGxžûô —ælYž‚9ë›rÜ÷ÊjW|’¤5ý‚œiîL9Øû!X²Q×4òf+Ïšz¶Ê`V?[Á+ç ;åÖÉ™µZÀ`Xà 3oWä ÜÇåêÙ.ab±Ãùµ‰pü¬Fuƒ%ªF8¨@To·!Ò¶åa!˯(j(â­^qåòSùÿ,ï'Ì¡zNe\{Z‚lƒ,’d¢ÕÌ_âÖr/ÛÚ¦Œ@áï)ÆFl0š%æ; “ó¼vžËz=§Ýò:“,?“»_BZ Ü~„0Û‚†º¡ ú¦ÞuC`”pÁŽÁD˜úfù™ÑÎFü"¯c_ :IPiå0ø—ä;Ô5µó™e* êÄ-ì]ŽZrŠ>Og™f¿%ëDŸÎEÜr“,bÙNä‘y}Zk@í™Üÿ \Œé$ð}yI÷&¾Å‹(J•õ•Q5¹™ÎiZ0ã*óÜþŽ›T–(ûë^¤:s„z wY[¡$oIç“çC£ò~ tk*ï…ÊûJUÞnUy·eB$7ñSzÛ(½}¥ï¥Ò­Ò³±¢Æ‚am‘„X‹7”J_Ï•–èIúª“ÀPL¸DJ|†N¨ìÅKæÇ^n¿ÂK®)¥È~[ðrΣ~m €ø/Š—Þ*ûñ>6y‡Cêkhâ þ Q1û¹l¼BLî€\¹ŒfS:Í‹è.«NnÂÖNð­"zÑ*Dóº†uq± ^Ág”*-nMy³òx®<$$ˆ¤½ì H^ì “Ðó¿À€Œä_õ¬(@@ÕT*ü}¨Tùo%¦e¬ ¥qH§Ði,Æ=sý‘JUVŸùð‰†S %ÖùàxÓÎh"ÁôB븛0Ê“(‡“(Yvc}µ(õL”ÆI” àwºmÙ&®šõ®‡ú|]F’caìôpâñHªÆŠi­ôÒ MvÌ4óTõÏ‘QاÀ8GrbÕô€ÊÚ ýú­°qb¯èËáT |6Ò}wyÝo®_6¾¡î3¤ëEâuu`ºß T…÷œàwÿWIyï°Sn5Îå‘æc£¹¯ŸmÝüê…gät ÀÿušIïl¨&}/%>#…f¿^Lê¦ðL o-"wI¼ùfa_X¥Ž{9ðŒÛ¶ãÑä_ÞÖxdßòz’‘C HYŽ›‡Ô¬•¬Ž“Î4m/†oûÜØ.ÊÆîë(Éâé'å½IË/¼)WÓŒ¤AÎ ¶d3è¾lZIðîo|‡ç'> stream xœUÍn1† l#h)J$P¡M={m£J¤Þ¸ åØ[¤"…WêƒÁ£`{ÆY;íö€rØÌÎÿÌ÷Ín@­TúÉóòªÛtÀü®<.¯à˺;ý ë]1íÓò~À*ë«nÑ/×?»hôµ[¬–']¯=è!ª¾w‹gI¥- Æ,ï%™ ²ô2I ë.~'±'@O1r¬™¨µUYöFåGkŒ™²4ωA£oc{Î|À¡Cî—ÀÚeù+IćIô¹½'©=Zq’ÇIc 'yžã¸˜²7*pÑoò»]¸É{¥GËÁ/~q’ë@z l}Ä• æ¼(ÎÚWÎlüJ"›Åë$:^Ëyª;väC;¹Ð„é9Î~ÎSÕcWh«a¦*MS–±S;®>_äd‡¬Že<Ó‹evOœý)‡³~l2… uíH¹ÍÃØfTÑÐà‰]ßÊ°d¥ Zkg[ #\ œAŒ#9æi:Ð$_äq:nB1öîÌ.%p†!HA‹wãàGBˆ­š4½ÁC–Þ1ŒuäºuÄcÃM=’²H«Ū˜võR Õ©|%UÛœ`\Ñ›n ]–Cêÿo‚uX¾sÙ*‘ŸÚêMâ:×hº N³²S­Ñ'jNv*7‘ {¤ó5|ëÒï!ÅTendstream endobj 353 0 obj 711 endobj 358 0 obj <> stream xœµWKo1 ¦¨P@¢…AªÔHç.$n\öØ[¤EZþGþ"y83q:;ÚBÑv‡c¶?{7LœéƒßWëa3läµúuµfWÃÅlõm¨Gyú¡­;7L{wîØj=œÞ?[}¸bR±Õ×áô ‰Q-â#½Ëâå$«¨+I{xUI™å'xØÍ]½WÄróUQ£¤Íâã²'}–Q­m,R ”ÉâT+‹¦ËŸE6aÚå*ºcpÿ,¯XçWA—Å—y-0 剷ø" ÕM˜ìÌê4Û÷³, ƒ óÂôñ@¼ÝÑÙ Á‚oÑ—¶ÊÐWá·@˜Ôñ¨˜áb1T§ÙoÛ)Š+îV/Lªó’Ø,…š«Ñ‚Câˆ)Jô8À4z1:¶ŸŽð)(œ`HÀ+ÜO«zÓ:Â-ßû…œ¬¦ì·øν¦Wânõ :¼€àUÓíñ2zR M|““¶?œÜ·M˜¹ÔŽq0GGL1‡$¤S§”HÒ‰u\ŸDsóáÆÎÐ 8¡¡ý"²bŠIÜU0WîM¶x’- ›ìðÑŽÏùîÉàuþý+þLéüB"xX*œ+MÙ··ð'ÖÙ^MåYç*ÓA »v|u\ ƒ=Ÿå Jã;òG^÷k×ÑÀúÖ<´˜½=Ó\•Ì‡©$ òD¯Fl«Ï×8Lw4¢HÉpŒEMZ­;¯hÒ‚ìKÄ Ìó©FŠü ÷ëù®¶[¬å?ÄÚµÁO!ë©cIç2¾)Ûkí ÖZêijÁvCˆK0-»& ¡,÷ ˜N¹"Êm£\Cd¢²ð.ŸÎƒAËË€AG¡¦”SFØYûzÓm§*™ó:f:¯¤øY_é&ÂA0ÓFs<¶Žï}CŠV….îK£×Ü{º,I²ã(\K6d¤¸ÿýœÚýͪ”qŒ©"˜ræ ıÜ=IÒ§û2¤ÏaëNendstream endobj 359 0 obj 876 endobj 362 0 obj <> stream xœVËjAÕ *£¨Á,|,lAðF褫_ÓãFݹî2»ˆ !B\»Ñ…¿áG(þŠ¿buWõk2÷$‹›š©îª:uêÔœ uBÅ?þ=>N‡SéYþ9>/ÖÃásbýnÈ®2þcýx …³V¬O†Õ¥ýõûA h¾VG¢mÐ7Z×è%L¶šÒ ó”ìò•|ö:¿ɾŧƒKæ 6Çq!R>«©g 8s\¥k\ ˜Ý|5Ú ÌÔ…(‹Û9Iè“4!ÙÉ[³Y¼)­;ì¦ê,½sBZm|zö€’ÁÔ•i³~¿€h‚0ÔR”àBÎVñâÎ|$ÛMmÖÒƒ£ýthUñŽ{Ÿ!3&t­ó]™0MmVÁÔªñ¥ò]"#5ãg©ˆlm=~=¬v÷ãAíéÖ=ö”3~ðE….-?ÐæVÌ^sŠ BK.ÕÂè ¸G)¬Õ^H£ yüJÏ\@ôù …»³èº.ݵ¢]f‘‡ŠAD·ë¤öü^‡nžc0_wÚ Yûa•ÐN«} Ó4µ'b ü9®:c"a¡ƒ0š*¸™ˆ¶ë;C=Sÿ•vºÑìŠàÄ(ÏTã"^tµ­Cñ4MŒÉÓHu8lEØk6«¡W37Ó ­"jª\–˜(:þ,>À<%“13zÄQ nÆhîç•ƒÕ Z7Ùƒ˜æêÐõ +É÷ÛuíÝ躌8©±ÇMw†V ŒœXêRŒ(1é©òF|MäÙXÛaæÊŸ\³ék½¥Yä•ñ%yuBs¬y‘…[ÛÔzÎb=š.1ÎLôÊwVQÁöÚ‘WÏÒ=O‚¢V­¨ÑP8½‰Z(–ֱϱ¼LaxÁ-䯄»=yòšò!P6•WÕ3®dÝÏmøÇT›Óé囂<Ê:Fc«+芗 Á„¾žQì™áÕ¬•›÷RuÓ{›qIÁ—Ô=Olfo¸ ßK¶û¸jç&$§a™­âu#mÐÜÌýY&Ë€3³ŸTmÒ6l o[¼ÃÙ†˜º¬Œ:]ª é|Í>–§GUÝ¥+Äg†aRÛÆÄVÔM‘sé€4Hv #/é¦@zð9>ˆËGö7Ž,BÍ®ß3]ˆë_’ªè¸èþOt•+ûð÷†RÿJðâb°££+éFæ_²^­Å›!þý÷`~ endstream endobj 363 0 obj 890 endobj 366 0 obj <> stream xœuR»JCAE;W‰‚‚ÍX妸É>²ÙÝRÁN á–é")ı¶D;ñ#üÀ°ó[œ™å&p‹½ggΙÝ9è¾?9'35Ws0+Çd§œ€fªJiœÖýA'hfªºè5×Êš+U=f0u®ªï^Wi°ÆRæ-g?‚Oz uJ„ï3®½g8ð’ê!¡géFyÞPµÃbfû%l†Xà)0%zÄBÿ%ýzÔÂÚF pþ ±[œgEÌgOè5#ëÈä;šÌB4Ïý`ÕRøæB€Ú:ϱ-‘nãSGÞÒ÷óÔ ™xã»Ò*;ìUÜ Å#o™‹7¶];Ëé]2°Ì~qdS8©Ëƒåöå.dû;E‡×­h‘‰ˆW–UÇч˜³2heÒi¶»)þÒ’û mn`ÇcŽåv]\U}X§¶{-¿Œ?~jÉa¿.‰ülFg \ªüýü¹Íendstream endobj 367 0 obj 381 endobj 370 0 obj <> stream xœÕV?kTA'6ÂSÔ H¢Í r¼dgÿ½]¬Ò¥®´‹Xbm«ÁB 6’Z°µT ý~ ý$ÎîÎÞ›=ï]LŠ¤¸Ì›ÙÙùó›ßì[ dü£ß½ýæ 9¾•Ÿ½}qÒlß &›bÚÆŒ2[VtªÛÒb²ßŒ/nLž4­ZI1yÔŒ>´hm?&µÓN(— >¥/DðIÞ$ |å [¯Vy—äëä²úrVK¡ŒÉ§Çñ‹êËÜIr·šìQ­(Üd²x!¨$ ³t¤Nö¢! K¥ ’ʼn¶Ž›‚¡=+9{H®µW ’ć>ÈX°¬¾Aj㸶…\Kå0øZ­+ß`%ÏQ¹nN3n•ftž‡æÙνW ò»Z×y™2ÒÀêƒê « [ }ÆOË'“ÞXÑVÆÛê*ÍQ]ÇQƒ%Í^M¢Eúà[Ýl­¥ ~¤ @´.weDWú!©EcðùÃÏ”0f@mÀ’ª@)ÍIÑ›™è%o¹·ÕDA•wˆTèÒ®•¬ìL]USu8ßy‡N·ñ¡B¿VÓTn>~°ÿ`÷çÚANý=BªäÝOðqŠ]+Œ4K‹a8€#;fœ€KC°6–³w`ëôÄåÕ;4 ï(NÂôQ¹ ²··T\ȇË8gÎ{Ãàˆ€F <Ì̯…¿D Gx–R>Onðƒ¦Ù×ø¡sÉö[¢{å³é‹zWË–MäSvNP6·)wz&,ÑáNÏ.M×w³¡è´ÔôûÛ@‘Æä}ñMõ¹›Ó¶‚dO²ÁN¨#'æ¸*LQ³¥€u3áñ§(v¥ã©*z¸”EHM˜·»m½»YÅ΄ÝAŽÍÎÊW#½ÙŽËà'éur¬SˆGùÅ¢¥åAøÿNdÄèÑКž¾ÛdÍC”v&âAÿ~}¶èúendstream endobj 371 0 obj 909 endobj 376 0 obj <> stream xœÍX=oE&."q‰B  4)Èhý¸»¥A !d ¤·t”É‘LMKR€UøˆßU((ùÀÿ`vgövö|ï½NPraÏÍ~ÌÇóÌÌúL™#P&ýðï{§ÝYw¦ +¿îª6ÝݨÍý®,ÕéßÑW= GNmN»ÃËw6_vFÙàÕæ‹îðuÇ,ÝH’v bÌòÉR›,ÝL‚íCßäÅ>dq´\¯d­U.öYþ4É ¦Õ'_ñî‘Ô×i7]{‰un ³~$¥#“—$~O&‚¡ƒ¾e#m–žr ÷’ä€v>J"\yœt]HöÑÒ¯ó%éƒ3õ¤š1Ö{v\ †.zšDÍ{-ï}¼`î]¯t0»_ò·%—KxI×)ýƒ‚ÐrrÈ°äÈkY (ƒ„Zx®±I=]÷­ë“³ŽàõvþW×gsŒ“æàöy釾j]̱Úϱ×WR Ì.¿ýÌoSý6uùòŒ”o•ÜÏ¢"I“ò¤ –”ûdI@9Ö›5Þ ´àäN¾Ê©¾á¾5VF€¬¾ÅG3÷dY¸UÐëej4cûiúõ’yaÎî•LÃjÑñ¢è`¥€¸¤¾Z@ IVD`÷Îþ+à–ºw›£‡Ê‹”^ÓšïdÆ¢Ì}JY?æ›Æ)”~£zŽììÐ@ÖÁÜ‘~[ÒêßÊvËÖýɉ‰~ÎІ@‚´ÆZÍCË€/ÔYtšŠQ`Y `½Œ=6¬´#fFÉøŒ7Ðïrc@¸!•×aDô1Ñ–Ûç_ùÎTá@`#LÀºÁ36oÙ 2È!¾œ¢bÝRöž»¨p4_xQ1mbž©Ã‡•†ÀS“tœ‘tTÜÅŠéÀ‘ÚçˆówMF¼ØírÚ bRJ¥™Q\œ6Q<´?W“ž)¥Š,SÜ‚˜9V9€™ã˜ÓTqÖqì¤ëîÂ8-Žcc» ƾ…±µÿQo4qŸ¿8¯ÁØÉj‡%¦À8W;”5ÏÓ¹©â°©É¶_óz¥PéÛûùü±Ô„¶³Nñä«X®¹RáD_så|÷UN(Óä'2e:úç${4¼Ú‚(§x'ÕÁ’w å·ïBoñ²èjØ*´5‘¾½"Aw©” ·ÒªÑc+ÔS‰¿RjŠ³¢Ä§1„9ša–‚sœ÷ÐÉ öË+ª½èÝ|ò€ Ò‘G€Wi=cjªnNV·:‚üÍøo ??‚pâv·5dwhBзÃA3™¤9{{uhh[zËä¹y -Ü…¼Ö¨’–…ZX_œ"t£h ˆÓ8k¨ÐzìÆZ¶ª¸LP—I©˜Æ‘þ¢¥x^y,ö;í"ÿãá3fÊ@;ò?°iŽñòë<½°Ï½uéÃ#Ök>ù1Œ´>7üŽyPïý,£~}† > stream xœÍW;‹eEFQѳ¢»¬Èjb/;ƒœÙ®~wæÑ@öc´²0ÂoêÅÀß ¹þ 1ñ·XÝUý:÷Ü;³×Ed‚¹Õêz}_Õ9ò„LüÿîÙt> ÈkåßÝ3ñæfºý†±¹7•£súat81ÂE}âÅæl:zåxóñ4Gá¬Ø|4=“D)¼ÏÒËy¼PòÂ{iŒð*‹?$Q‹9š,~›k¡®GÛ€V%ñGÞžé©ox·]•BËÅ/ò;_yw:úüøÖdúF{÷³\Ð@w¤ïòÙ?ð¬DscÞùŒ´‚4M+ €Ìÿ‹Ü3h¡Ë ÷Ø=°tÿ:ûÇ<Ë÷A“%7Ë}Í÷Kx‚¹¼ÿrô?ê¿ïýr¿ÿú"ÿÃà?u£¸i÷qÖîH|.o+‹Ï‘¶çÓB’ çùuÁÊÙzúiQ|ÿ8(2þ…$½Ä³·&“¾ˆ¿’K\‚ü†lùIÑpkÙ¼A»AÎ)©ÛáYyô†NØ?ÀÆ`ÛsÉFÙlD%Æõ»)ÂI¼RáÆm=V—%eW9\š˜ bp’AXJï ·\¤gft†ržów•Ì¡\?Vl•jÍ•b«V±)—‚}ú æÐ^©‰%]×8-6ôwG§ ½óR9Ú…;٠؇ùF<ºù(.ñ(å# ÔŸ ¶Ã£GŒ‰¯æËk6‘Ÿÿ=¯9%”!/ŸN ¦–ÑëÅKòä òR³Æ'‹E&2ÄcðT$l¢á¢™ÙÂk4­:KáünuKt2¾/.?<ËâuM¯§Àà&[Ä$Ti%¸þ&øŽtôPº#ákm‡]èºcºwx€V1QìˆD)E†—q#Š¸bÔ.UÑ.iØ/xAþ×4 CFâX#œ‚cc±|é´¤÷‘èf¤XM¢ªÔÉVyœŸHE0Ò•¹“ñ(AZˆ‹&cv·›@\ÛnMÏ}Gÿ¶ è%Ÿ`Òf94B óIØ™¼,&1>W"ÃyP*/4þŦa7æ²ökIZ½d¼¾äÓdòOLtôûª™T}Eg¹TÊ®ŠÐk*Ù®”­ÊŽM“¬U¹q)êÿ3N1¤üÂ#CIÚ•Qi’qdØ•.@‰Z¢Ä-Pb.’­Q 'NB÷ÈCKÃÈÑ©ãÒÈ5.QØÖÆ¥dE¡Ì4\ø ?Þüš·í‰Á¤ßh…âœ=Uj€£¼ÿJ+•5µwÆ-¿Bm ˆ¬ð­3Æ@ h†‰}3Ðu Ú‚B.ìCa@Ù– ]›P+Š®íO-¯Í" hWjõËó`ðôf*÷y½ò©¦î­©iÁ=º ¸:äSÍt£Tkø¥:¬¢­Žeº{?öÝ„ˆñI#…çÆy§èà"ù ɉ©ÑÐÑÐööKi&Tå¿æ,º˜OÞÉ.%-tö7.=¶æ´‘ô7wÛÈ2õr·Å:Èâ[\ÚîþdNâ¾ Á¢û¸¾JݯL²²ŒŸó@Ák&—žPö|¤¯ »r'ü|Y¤õ¹e‹4díOeRÒÐ29{D§rÜ“nœ9úï$éíxJÿ¼gendstream endobj 384 0 obj 1201 endobj 387 0 obj <> stream xœ•UMÔ0 …Ÿ«åH€9±+Ènì$mr‰¤÷¶ˆÒ Íþþ9NìL:¥-ª4­c?Çñ{ÎlÁž#ØüèûjÓm»-`Y«¯« |»‹O€0þìj¨ÉžBþ ìÙt§ÏÆ_q`"Œ?ºÓãlr–Þó™˜9¶: ÷Å|¡PL‚=Ê6²i‹ùµ¸ˆúb_þ¸m`Þ(H®7%xÀÆÊÚ[I@ ö8ô ù•`ŠàHªyšøIŸkµšìH÷÷Ósb¦ÎšÓA*ÆmMã,®…þ“­`ŸHƒÆo9ð=;¨šÃ¥â9f÷ÔIúËkÝO3.mÀm `ÈÇiÛ ‡F Ò¦óÊYèWó±ú¸F;q¿7éÙ«ÈR±O*ÚÎб¡ùÐέòÇôh.¨­‹ÿC¶©Ú¸Vxr«äs¡a_Ç‘’Wµ+íëgyEV¤»Ö8LkãRf-í•p!øU ¦á†ƒ“3ùƒelœr*/à» Þ×*Fl­2¸wC£Éô|A˜¬[”+îê‹j"É,*¿Tîî4Ö¤6­Pë ¤=A©©U°ô½úÏJ8bÃAFúÆ—¥fi£ñ|()óuåDÐtÊ=Oy?ÌÚ¦³xk׶›\=ùï÷úÉ×Ç*ß<5äE¥V* %ï½iËîë1Q«Û«óá®@A¾Tâ”æÝè ³k64ð¿V1>”i‡DsÙ-é»MÎä®5‘Käy )EEñ'[_FøÞåç/96€ªendstream endobj 388 0 obj 573 endobj 391 0 obj <> stream xœEÍA 1 PpDô9.f¦I[­K ténÄ…0B=ŽGñ0žE’Î Y¤/?¤®c8­©#*`›ÍmqÊÔÁÈwšW[}ÈÞu !ø."Ô|¶ùAùFÍFé ñ`\T²«\U:ÃZá1m^_ÊÖƒ“¯ƒgÍ[6.§XÂîJÓ`üZ, âS´Y_KÉôV3.¤õ 73endstream endobj 392 0 obj 159 endobj 5 0 obj <> /Contents 6 0 R >> endobj 42 0 obj <> /Contents 43 0 R >> endobj 56 0 obj <> /Contents 57 0 R >> endobj 68 0 obj <> /Contents 69 0 R >> endobj 75 0 obj <> /Contents 76 0 R >> endobj 86 0 obj <> /Contents 87 0 R >> endobj 105 0 obj <> /Contents 106 0 R >> endobj 111 0 obj <> /Contents 112 0 R >> endobj 171 0 obj <> /Contents 172 0 R >> endobj 199 0 obj <> /Contents 200 0 R >> endobj 211 0 obj <> /Contents 212 0 R >> endobj 219 0 obj <> /Contents 220 0 R >> endobj 226 0 obj <> /Contents 227 0 R >> endobj 230 0 obj <> /Contents 231 0 R >> endobj 240 0 obj <> /Contents 241 0 R >> endobj 255 0 obj <> /Contents 256 0 R >> endobj 261 0 obj <> /Contents 262 0 R >> endobj 265 0 obj <> /Contents 266 0 R >> endobj 269 0 obj <> /Contents 270 0 R >> endobj 275 0 obj <> /Contents 276 0 R >> endobj 287 0 obj <> /Contents 288 0 R >> endobj 295 0 obj <> /Contents 296 0 R >> endobj 301 0 obj <> /Contents 302 0 R >> endobj 305 0 obj <> /Contents 306 0 R >> endobj 315 0 obj <> /Contents 316 0 R >> endobj 326 0 obj <> /Contents 327 0 R >> endobj 331 0 obj <> /Contents 332 0 R >> endobj 338 0 obj <> /Contents 339 0 R >> endobj 343 0 obj <> /Contents 344 0 R >> endobj 347 0 obj <> /Contents 348 0 R >> endobj 351 0 obj <> /Contents 352 0 R >> endobj 357 0 obj <> /Contents 358 0 R >> endobj 361 0 obj <> /Contents 362 0 R >> endobj 365 0 obj <> /Contents 366 0 R >> endobj 369 0 obj <> /Contents 370 0 R >> endobj 375 0 obj <> /Contents 376 0 R >> endobj 382 0 obj <> /Contents 383 0 R >> endobj 386 0 obj <> /Contents 387 0 R >> endobj 390 0 obj <> /Contents 391 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 5 0 R 42 0 R 56 0 R 68 0 R 75 0 R 86 0 R 105 0 R 111 0 R 171 0 R 199 0 R 211 0 R 219 0 R 226 0 R 230 0 R 240 0 R 255 0 R 261 0 R 265 0 R 269 0 R 275 0 R 287 0 R 295 0 R 301 0 R 305 0 R 315 0 R 326 0 R 331 0 R 338 0 R 343 0 R 347 0 R 351 0 R 357 0 R 361 0 R 365 0 R 369 0 R 375 0 R 382 0 R 386 0 R 390 0 R ] /Count 39 >> endobj 1 0 obj <> endobj 4 0 obj <> endobj 10 0 obj <>stream 0 0 0 0 135 159 d1 135 0 0 159 0 0 cm BI /IM true /W 135 /H 159 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x-pAþƒÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿóJáÿ&«ïyÁcOÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿì.¾  EI endstream endobj 11 0 obj <>stream 0 0 0 188 138 272 d1 138 0 0 84 0 188 cm BI /IM true /W 138 /H 84 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±Ø`³ì@çj”Cƒ¾îÜš¯àÍ£ˆâ8Ž#ˆâ8Ž#ˆâ8Ÿÿÿÿâ"""""!¼àÀ<}‡ûï‡ïÿÿßÿÿÿÿ¯ÿ×…ÿÖ¿„¿­-uÐXK­,%®,]d“æ•áñäÕ/ÚÚ€€ EI endstream endobj 12 0 obj <>stream 0 0 0 0 110 93 d1 110 0 0 93 0 0 cm BI /IM true /W 110 /H 93 /BPC 1 /D[1 0] /F/CCF /DP<> ID & PCÙøTH ¢!4FÃ*°ÿøzPzÃÒ¾¡õád4øPˆ©5fl(×X?[záÿ¿Ãz[þü-¿ß ÿÃëÿûñÿ½ÿÿÿÿÿßÿäÕuÿ¿ýᇯÿzÿ[x_ýø]ëÞ»K½wë¼.Òï^ máwál<%°xK‡‘Ra!eì‰â·…±[_†¶ `ÂØ/à !¤[† ØVOÉÇ€€ EI endstream endobj 13 0 obj <>stream 0 0 0 0 141 129 d1 141 0 0 129 0 0 cm BI /IM true /W 141 /H 129 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡ÜäuÿP_¿ð¿ß¿ú†ÿ÷ÑNŽ#ˆâ8Ž#‹ÿûðB"" ÿﯯá>ÿÿŽû×ÿÿ~¿ÿöð¿ÿÿ×þÿÿÿØÿÿ[ÿÿþ]_ÿÿÿÿï×ÿÿí&«_ÿÚÿÿøzá¯ý¯û×ý…ÿmÿûip×þ×l%þ»^×a¥Úáávm.׆—k‡­† v¼]†-ƒ oXa‚[#a¤¸2b»%!€¶+k m~ÂÚÁ…µ† ö°aa‚Á…ƒ €Éðad Ʋ C  EI endstream endobj 14 0 obj <>stream 0 0 0 165 141 292 d1 141 0 0 127 0 165 cm BI /IM true /W 141 /H 127 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡ÏàWG@< 7©ÃSüá›®¡zþð—ÿú ¾¿}‡ÓëðEÿþ!½ÿéÿÂßþýûÿß_¿ÿÿÿÿÿÿí&«_ÿÚÿÿøzá¯ÿö»×ý…ÿµÞûiÃ^×zÿ „»^×a¥Úï °¸m.׆—k‡­† v¼]†-ƒ oXa‚[#a¤¸2b»%!€¶+k m~ÂÚÁ…µ† ö°aa‚Á…ƒ €Éðad Ʋ C  EI endstream endobj 15 0 obj <>stream 0 0 0 0 136 108 d1 136 0 0 108 0 0 cm BI /IM true /W 136 /H 108 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±à<áÿ‹ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿþelþMRØ[YiP EI endstream endobj 16 0 obj <>stream 0 0 0 0 138 140 d1 138 0 0 140 0 0 cm BI /IM true /W 138 /H 140 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¨ðdB‡ેMP?ÃÃááƒÃ‡ÁƒÃƒÃ!¡Kƒ ><† 'Áðø|òÁƒø~? ? €ž ¾ ?‡áƒò¼?ƒ  ü0þÃÈj…x†þüƒ!O†ø?Èÿ‡áùà|ãOÂð¼ƒ9>×…òã~Á/ÂðAx@¼ È5‹ü/„‚ø ¼Ÿ Âà‚ð¾D(ð|„‚ ‚à¸.ù¢Œ ¹Ä‚  ‚  ‚„ ‚ „ …¯¥X ¡Bà¡AAIªð EI endstream endobj 17 0 obj <>stream 0 0 0 173 136 287 d1 136 0 0 114 0 173 cm BI /IM true /W 136 /H 114 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±î?‹ÿ\èŽ#ˆâ8Ž#ˆâ8Ž#ˆâ8Ž#ˆâ8Ž#ˆâÿÿÿÿÿÁb"""""""""0áÁþMP>{†Ì.÷Œo aà߆x|0ðÃáᇆ <0øxaᇇà >xaàû†øx0{x|{Þx0{á¼|Þx>=‡Þ {àÞ>öðo°ð~áù¥¿üš¥°¶  EI endstream endobj 18 0 obj <>stream 0 0 0 0 143 112 d1 143 0 0 112 0 0 cm BI /IM true /W 143 /H 112 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ÒKá—Là£àƒÓ„ôÿ Zý@“\& Ýéü„G×»Òýï ;ðAß Ü='¿Iï„Ûÿé8~¡ßþ¡·ëýü%¿½ýÿú ýßÿ«ÿ¿ýÿãÝ_ÿÃÿþÿßÿ÷ÿ÷ÿÕßÿRj¯ÿÿý¯ÿ}{kÿÿ¸záÃ_ÿ°¾õÿ†í_nv¾õ¾¾Ã w ~Âí†Lþ½a°¿î½­Úì>®þØ/kpk†Án_ø0· |;>‚È€ EI endstream endobj 19 0 obj <>stream 0 0 0 131 136 186 d1 136 0 0 55 0 131 cm BI /IM true /W 136 /H 55 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±˜ gœ Áþ!§ÿÿÿÿÿÿÿ@ðÛÿÿÿÿÿ&¨&·…°¨€ EI endstream endobj 20 0 obj <>stream 0 0 0 0 110 104 d1 110 0 0 104 0 0 cm BI /IM true /W 110 /H 104 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ¬kyÀ,† ¶àá‚„Ÿè éè#ˆâzýø‰ ,"¡è« g÷ A½áèôx[ÒÓ|/Iúo_Ûëè>°ýÿ ÿéÿÿøí?ÿÿÿÿòjš_ÿÿkþ¸¯ûaÿuºö½¥°ÿ­µÃa.Âðh-† ½l0—ä 3{"€Âö¶¶¿¶ k ,/à   ØV¯à EI endstream endobj 21 0 obj <>stream 0 0 0 134 106 289 d1 106 0 0 155 0 134 cm BI /IM true /W 106 /H 155 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±Øa•ì@lÎÔwpï“T÷ç‘ÄqGÄqGÄqOÿÿÿˆˆˆˆˆˆ†òƒð}ø{ï¿á¿ïÿ÷ÿÿÿ×ÿëÂþµþ¿ kúZ ô°–¸KK‚Á,ÈÍ´ø_çjï¸wrj»íäO¼àÀ<}‡¿ïÜ?¿ÿßÿÿÿëÿõáZõø]/ëAk®ëK k‚‚]d“æÝXGb…‡ÿ&©~ÖÔ@ EI endstream endobj 22 0 obj <>stream 0 0 0 134 106 218 d1 106 0 0 84 0 134 cm BI /IM true /W 106 /H 84 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±Øa•ì@lÎÔ÷pîäÕmGÄqGÄqGÄÿÿÿÿ äàûì?ß|?ßÿÿÿýþ¼/þµü%ýik®‚Â]ia-pA`‚ë |Ÿ6êÂ;,8ûÿù5Kö¶  EI endstream endobj 23 0 obj <>stream 0 0 0 136 139 155 d1 139 0 0 19 0 136 cm BI /IM true /W 139 /H 19 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x’Û¦/ÿÿÿ&©µÚkà  EI endstream endobj 24 0 obj <>stream 0 0 0 0 110 80 d1 110 0 0 80 0 0 cm BI /IM true /W 110 /H 80 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡°—Ü„oÓ ØšéßúÂwߢ_YÄï„F>ü·è áþ>úMþïÓß ð·øwÿéÿ¿ûÝ×ÿÿÿÃÿûÿÿ÷¿‡Rj¿úûÿû×ÛÿðýpÛ_†í{m½¯½|"ûaŠÿ·Û¯kØ[ ¯û a¶¼5»¸0¿á!{>†X€ EI endstream endobj 25 0 obj <>stream 0 0 0 0 134 92 d1 134 0 0 92 0 0 cm BI /IM true /W 134 /H 92 /BPC 1 /D[1 0] /F/CCF /DP<> ID & z a¯ XSø@ò ¸@ðAéþ<' ôðˆÚ8Ž ÿü(ˆoDh ¿½Ôô?¤xA7þ‚ú~ŸI¾ƒë|'Òaõûôø_ïAÿ…Õÿ¯ýÿ¯ÿÿýÿû¯Âÿ ׯûuþá.÷í¥¶‚Ãý¥°Â]®ÃK K a„²ö—‚âÿÿäÕ/ÚÃP EI endstream endobj 26 0 obj <>stream 0 0 0 93 136 171 d1 136 0 0 78 0 93 cm BI /IM true /W 136 /H 78 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡à±Dàxáá?ò„ýBý$úÿë×ÿ¯_…ÿþëÿÿúãÿÿÿþÿûàø|“ïɪSaþö}oßýø?°k!³a<3CÿÿÿÿÿÿÿÿÿÚë @@ EI endstream endobj 27 0 obj <>stream 0 0 0 146 106 230 d1 106 0 0 84 0 146 cm BI /IM true /W 106 /H 84 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¤v6áý?ÿÿû_ƒ6Ž#Z8Ž#ˆâ8Ž#ˆâ8Ž#ˆ/ÿÿÿüIUˆˆˆˆˆˆá`º"tµ¯¤=u®ý-x]kÿ¥ÿø^¿þ?ÿÿ¿ï“Uïø|>stream 0 0 0 0 136 120 d1 136 0 0 120 0 0 cm BI /IM true /W 136 /H 120 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xl%Á¢?§‚OAþžžÓТ­Oÿ^ð·Áò ôƒ}>°ø úMÿÐ}&ÿÿ 7ÂÿÖúúþ°ÿÿ§ÿÿõ¿ÿOÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿù¥¼þMRØ[_ EI endstream endobj 29 0 obj <>stream 0 0 0 0 110 84 d1 110 0 0 84 0 0 cm BI /IM true /W 110 /H 84 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¤v€Í„D"–1 }ðÿ‡ß}÷¿mÑÄqGB8Ž'ÿÿ÷‹ˆˆƒˆ‡ÑBƒX~‡×o_ÒØ|Í-þ¨> þ=ëÿ¾—þÿÝ/ÿ×®ÿýzø_ëÿÿÿ×ÕGÿÁýÕ_ø]ü}{ýWª†¿ö’ɪ……Úý¤µðõ\*ì0•q¯®Âö«ipõáv½ ÂØ/ˆ2öCø`²À€ EI endstream endobj 30 0 obj <>stream 0 0 0 0 138 16 d1 138 0 0 16 0 0 cm BI /IM true /W 138 /H 16 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±”8@þ/üš¥û[  EI endstream endobj 31 0 obj <>stream 0 0 0 140 136 281 d1 136 0 0 141 0 140 cm BI /IM true /W 136 /H 141 /BPC 1 /D[1 0] /F/CCF /DP<> ID & Vj©@<ƒ ¶APªßÁ„ž ðƒÂzz‘tq\/Þˆ¨lzÞˆ4= ׄAU'Â7­è?MôA‚¼$ßOÓéõ½ýC÷éô¯ü(~¯ß…êßýz¿ý7ÿúýCðÿÿÿ_¿ñßü.ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿüÿɪ[ kà EI endstream endobj 32 0 obj <>stream 0 0 0 185 103 277 d1 103 0 0 92 0 185 cm BI /IM true /W 103 /H 92 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±à<! x9øX´ëX/­kX_ZÂÂ×Öˆ5¯ p—…Òép½Ð^º]. Òè/]Â]z ¥ë‚].½ézá.‚áz\%ë ].½.õ ¥×„º Âéb¾µ……¯.«œP¿_¯×ÿ×àŸªú¡z“T„…†  EI endstream endobj 33 0 obj <>stream 0 0 0 0 136 156 d1 136 0 0 156 0 0 cm BI /IM true /W 136 /H 156 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±î?‹ÿɪçÑÄqGÄqGÄqGÄqGÄq`ÿÿÿÿÿÄDDDDDDDDD ‚Âë x6á‚& XDš×ã<3à°£‚á‚ ‚Á‚ „E6. ,ƒ8ž\‰¼ °@°\X@¸X °ˆ¡pA`p°@°‚Ápˆ  B …‚‚ ÑÁ¢\ ¤Á·è."ðeÍ@xþDàË•x*áþÃäh \<0|<>È°Paðx0ðaáðÈ° † ƒ ‹Öx0x|x0|<( ¸aáðaáƒáä…ðÃÁðÈ°††%†@ðjÃἆäTðx?šY øÿɪ[ j  EI endstream endobj 34 0 obj <>stream 0 0 0 126 106 185 d1 106 0 0 59 0 126 cm BI /IM true /W 106 /H 59 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xf ÿÿÿ_…ÿ…þ¿Kÿ^HKýkQü.—ZZZá-ÖÒÁp–Aœ¿ ²_6Ï„v(Xq÷ÿòj—ím@@ EI endstream endobj 35 0 obj <>stream 0 0 0 134 141 226 d1 141 0 0 92 0 134 cm BI /IM true /W 141 /H 92 /BPC 1 /D[1 0] /F/CCF /DP<> ID & Ø@ÀñÈi”þ<†j®<z„ è=<"6Ž#ˆ?ÿ " è†[ûÑ&o@ˆm(áÐL< ¿ô›éú} ß õ¾ŸJ¿O×…ü7ÿ ÷úÿ¯ÿÿ¯ÿ“U_…þ¯_öëýÂ\5ïÛKm‡ûKa„»]†–0–à d¥xAþŸÿÿý¯ÚÚ€€ EI endstream endobj 36 0 obj <>stream 0 0 0 120 141 198 d1 141 0 0 78 0 120 cm BI /IM true /W 141 /H 78 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x-ð¼OÅáÿÿ~÷<3„ÿÓÿÿÿÿÿÿ×þÿø_þ¿õùBúׯýf”xQøæF©uýX“T¶ìíTÈAÿÿÿÿÿÿÿÿíu†  EI endstream endobj 37 0 obj <>stream 0 0 0 176 105 330 d1 105 0 0 154 0 176 cm BI /IM true /W 105 /H 154 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x4¬òzä ಂ‚ùÌV@ôQ‚äAr¥?Ö A]KÈ6*ä5 9R D, Èf©`¹ê¹ yR x"rK$I„UJˆX`´JÁkŠæFÀñJ€<"ðÙƒƒähEò&¹)|‚Íö"‚ðx2¦ ’SÁò Ár@¼ªd<ƒZ¦CX ª ʘH0yE,‚Án <á¹OäbÒŠ% x!‰Á…‚„þ@ðÎ@ðtž@ðƒRž@ôQ‚Y’Þ²å¸"XAX+!´‚!AŸ%`^CL³ Ð[‚äàˆPkd°6¤-ÈrÜ&  \”‚ÕÑÌr6ˆ TàÁN‚‡*ð`áÁò,²k’€<7ÁòTÀ’ø`òOƒÈ9& ’†”ƒu,†R– ©†VIA¼ƒY& ’†$ò ŠX2¦.I\‚š¦ äA2 Åx7ä1Y AäAüà^¹Ã085<4â  EI endstream endobj 38 0 obj <>stream 0 0 0 0 94 57 d1 94 0 0 57 0 0 cm BI /IM true /W 94 /H 57 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¹°< Óˆÿÿÿÿ;IýB®¦€yzׯÂÿ ÿÿ_ëÿþMPO†«kà EI endstream endobj 39 0 obj <> endobj 40 0 obj <> endobj 41 0 obj <>stream 0 0 0 0 143 164 d1 143 0 0 164 0 0 cm BI /IM true /W 143 /H 164 /BPC 1 /D[1 0] /F/CCF /DP<> ID & PF€¢@£ð@ð@ð@ðàŸè< zx' ÿAè‹£ˆâx_½~ô„A¾E7¢6è ´˜[Ð Þ| ý>[ÂOÂo„H7ÓëzL>¾é7Ð|-õêßOÂýõ¾½X}~¯[÷ë÷áx[ÿþŸýoßþ¿ÿÿøîÿÿÿÿÿï…&«_ÿÿýÿúï_ö¿ÿ‡®ëßë½wø^ýÐ]ûׯíwK¿]…ÛK†½ûh-ëµÛ pÂðÒÃk½l »^]ƒ¶ %‡­ƒ!¨²(¡rT v+k ml/ØX5µ† a~ a‚Á‚Á‚Á‚ü@ÖA™<@ EI endstream endobj 45 0 obj <>stream 0 0 0 55 138 146 d1 138 0 0 91 0 55 cm BI /IM true /W 138 /H 91 /BPC 1 /D[1 0] /F/CCF /DP<> ID >2w°§ /Ã[[á¬5“Uû †×†» v×[~à v» pm-ëa ¶Â\5ÁºØioí¥ƒ Ø]†–Ú[Ö 4¶þí„ÃKXm-Šý…†°û[_†°ÂÚë­uÒáa--tºák„µÒÒëAa‹SK°½ñþMRý­¨€ EI endstream endobj 46 0 obj <>stream 0 0 0 0 81 81 d1 81 0 0 81 0 0 cm BI /IM true /W 81 /H 81 /BPC 1 /D[1 0] /F/CCF /DP<> ID & Öu¹ ‚EÃdzx@ÿO ééè?Ó§§ÿ ÿôÿðŸÿü_ÿòj—ÿþý¯ÿØ_µµÿ†¶¶Ö×á­¬0[X0¿F€ÄY½` EI endstream endobj 47 0 obj <>stream 0 0 0 0 110 91 d1 110 0 0 91 0 0 cm BI /IM true /W 110 /H 91 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ¹à< Ñ G‚ ‚ɯÃÿAzW¯ÓxKéý½ýé?Pü>?ûÿê7ÿOþÿï_ûëÿÿÿÿö¼š­ÿkÿøa¥ÿaÛA¶—kþÃK°]놖^ m°Â_[$ÃK²k‘@Ç VÂÚØX5û aa¬,0¿KJ ,ƒ`AZ¸€ EI endstream endobj 48 0 obj <>stream 0 0 0 112 141 204 d1 141 0 0 92 0 112 cm BI /IM true /W 141 /H 92 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¤e?Óÿÿÿµø3hâ5£ˆâ8Ž#ˆâ8hâ8Ž#ˆâ8ÿÿÿÿ‰0Ê Âb"":Â}¾:Më ½ytõ‡¤?O„›Ò¿ô›ÿ„úß^°ýð¿ýÇÿÿë÷ÿë÷á)5_þëÚ ÿú[kØ^m…úÛKmx0½„a-ý’a¦¶ †X"`ÇŠØX5µ°¿a`ÂÃX0Xa~Y 2Œ†¸ÖATd@ EI endstream endobj 49 0 obj <>stream 0 0 0 0 136 142 d1 136 0 0 142 0 0 cm BI /IM true /W 136 /H 142 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¨àdbáÝ÷pìà¥>Õ¨0­Zö¤Õ¹0¾ÂÆÖýµ†KµÛ]´õ†ÒØa.Âá´¶Ð,=m„¶\5ÛA`Ú[Öà m„ µÛK „°õ°ÒÛAv¸m-°–ð¶ Â]®ØKm-ëa °Ú\xaml,5µûXk -­< ðžŸéá=ÓÂ!éð“z ‡­é7¤}>aáÞ· ›ÂA¾ŸA0ô˜zÞ zL>ŸA7 ›Öð`ô›á>oI¼-é“|'Òaà‚oXzAôzzO =zAè'Ðq Ð~§Ná:pš¡…ɪP EI endstream endobj 50 0 obj <>stream 0 0 0 0 139 104 d1 139 0 0 104 0 0 cm BI /IM true /W 139 /H 104 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡¤HÃ6A FC(ž?Ðx'¦ChCPFøL=4û êÐh?ôI£‰§þž´ô„/ §Ép/ôƒ¯ ¸zëÂ*Á“Áéè?X@›ö)ð½ôÓý| ¯I ßÿÿTþÿ×ÿL'ÿõÿÿÿÿÿÿý]BþMWÿ_ÿþúü.ÿÿÿÛIaÇõáþ–ÿiávÐ^»×~Ú^¼0K¿[h.׿zÛ¯kaµ†Ã ¿p×µ¸ílø ž  EI endstream endobj 51 0 obj <>stream 0 0 0 138 19 157 d1 19 0 0 19 0 138 cm BI /IM true /W 19 /H 19 /BPC 1 /D[1 0] /F/CCF /DP<> ID &©Eÿÿ“T  EI endstream endobj 52 0 obj <>stream 0 0 0 192 135 293 d1 135 0 0 101 0 192 cm BI /IM true /W 135 /H 101 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¨Ä 5È3D0ƒÂ‚Oô éééþƒÂ"iè-ë#‹ÑH>B7¤øXz¤ß øO¥ëxH?Mõè'ÒÿÒo_§ë ×Ò‡Ãë¥Òá|.¯®—_ô¸KÂé¯K¥ëè, ½}/ ½zÖ—…^•zT¿A(KP°´– IP^¦h"†ô^@ð€]%Õ}uÂkù5ZaoMaðÁb,-›¿ EI endstream endobj 53 0 obj <>stream 0 0 0 0 139 98 d1 139 0 0 98 0 0 cm BI /IM true /W 139 /H 98 /BPC 1 /D[1 0] /F/CCF /DP<> ID & Ô@ÀðO‚‚„àŸè=2 çÐa=? ÿéÞˆ8Ž&_‡è˜áa˜þ;ðAýß­ýú ‡OéÞ—ûôü( ûô¯ÿß×ÿþ7þµÿü/ÿõÿ¯ëÂÿªÝWþ²j°«Õ{×úúöÔ ¾—†K ¤¿U¶¡.á/ja¤— $-ê¶P—\5Ã&B!€=‘°Â!D·ªØ‚"‹ìWá­…†Ö á…ƒ Y E¿È6©äŠ²êà EI endstream endobj 54 0 obj <>stream 0 0 0 0 94 70 d1 94 0 0 70 0 0 cm BI /IM true /W 94 /H 70 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¹ÀR:— ðAè? éééþˆ„q„[×Ѭz? ô| ø[Ò}/„ýCÒ}|%ûzè.—ú]C넼.½z^º_ázAh*ëëÕuâUÂé*\J‚UPh ² `úª¦š ˜_áØX°P EI endstream endobj 55 0 obj <> endobj 59 0 obj <>stream 0 0 0 0 133 97 d1 133 0 0 97 0 0 cm BI /IM true /W 133 /H 97 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x3,ಈYÀ’¸X/‚Á`°XKò†h¡O…à «,\ ‚‚Á`aY,Â%A© HYÉ@mB ‹$‚¡VY b®È X." x@°ˆ˜ ÁtDÀðÑ?Ð<"… z |ƒü ÁèÖ ÂAÐ~ƒR bÿH0~ Aü‚°¿†rV >stream 0 0 0 0 139 92 d1 139 0 0 92 0 0 cm BI /IM true /W 139 /H 92 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ÔvPä36`ªòö§„àµðµ…­u®‰4qGGÄqˆâÿÈEÿü"2΋"!˜Aèˆ Ì!>¥ 2ëÁ„÷¤¢-ø[ÒA]?A<>¨}$úMø_$¯è?ÿI7ÿÃáz½WÿÂÿÿÿ×ûÿþ¿Ã ‡ï^ázɪßúû×Úý„»×Økö–ÿ´½°¼80¿h/ 0Kw®Ø0Kán5ò6ìWl-à Úö»÷ax0½­ Áb /Ã%@× ,ã1<=p EI endstream endobj 61 0 obj <>stream 0 0 0 60 103 79 d1 103 0 0 19 0 60 cm BI /IM true /W 103 /H 19 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¨ÖÊ-?ÿÿÿÿÿòj“P EI endstream endobj 62 0 obj <>stream 0 0 0 107 105 204 d1 105 0 0 97 0 107 cm BI /IM true /W 105 /H 97 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x5¬<2µ…<4…òƒ¤…>stream 0 0 0 0 136 115 d1 136 0 0 115 0 0 cm BI /IM true /W 136 /H 115 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x3p@ÿôÿÿÈÿ?ôÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿù¥¼þMRØ[\í( € EI endstream endobj 64 0 obj <>stream 0 0 0 0 136 122 d1 136 0 0 122 0 0 cm BI /IM true /W 136 /H 122 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±˜ Pƒòƒ/D0@ÿôÿ$ïð@ÿÓÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÄÿɪ[ k!6· EI endstream endobj 65 0 obj <>stream 0 0 0 139 103 238 d1 103 0 0 99 0 139 cm BI /IM true /W 103 /H 99 /BPC 1 /D[1 0] /F/CCF /DP<> ID >ƒV<e¦P×µjÕ‚†¤Õ}¬6¸al4°Úï[a-°—kƒ ¶‚Þ¶ÒØaà ƒim ·­°‚Ãip× ¥¶-áa†–iv»ilAa­¬5ûX`¶¿O èý<"1=aá&ô›á>aè ÃÂÞ“xA7ÓéxIƒÖð7¤ßO„ƒI¼-è&aðô›Â ½oIô›ÐqN útœ'OÓ„&¤Õ!€€ EI endstream endobj 66 0 obj <>stream 0 0 0 0 97 71 d1 97 0 0 71 0 0 cm BI /IM true /W 97 /H 71 /BPC 1 /D[1 0] /F/CCF /DP<> ID &   ä3ŒÂAà™ ³ÿ¦A½ZaÓOA‚xM?ù¨=‚4õ .:| òœ¼&ç@N“¤ßÿÔA>5§¯¦Ÿþ>õðá?…ÿÿÿÿý|/Ãòj½þ¿ÿýð°â¿ö¿[ý¥á{]놻ÖÚ Òì.û nÖÃkvûx(€ EI endstream endobj 67 0 obj <> endobj 71 0 obj <>stream 0 0 0 0 14 66 d1 14 0 0 66 0 0 cm BI /IM true /W 14 /H 66 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¬ó‚ÿÿÿÿÿÿÿÿ“T¿à EI endstream endobj 72 0 obj <>stream 0 0 0 0 136 129 d1 136 0 0 129 0 0 cm BI /IM true /W 136 /H 129 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¹€È¨8†@ðÐ{k Ö?°Á§`ƒ´§ðiØNù5M> ‡öþÓí<ƒìD¸;Þ>Ý> ¤ß°h&Ý>ôÖöéø?ÛI½¿Áá>ßì0·Ãýº|ýÿa¤ØßàßìpöŸÿßßßÁý¦ÿ~ü¿÷àÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÍ,…ãÿòj–ÂÚø€ EI endstream endobj 73 0 obj <>stream 0 0 0 0 93 76 d1 93 0 0 76 0 0 cm BI /IM true /W 93 /H 76 /BPC 1 /D[1 0] /F/CCF /DP<> ID & `à3Áÿÿÿÿÿÿÿÿϵ|?ɯò ÐA\>Âð—„½|ð}z^‚ð_AxA}xKÂëéx%ð^—„¼/ ¼ ¾¥á/ è‚_\Auýp¸\.¿® ¬€€ EI endstream endobj 74 0 obj <> endobj 78 0 obj <>stream 0 0 0 0 136 117 d1 136 0 0 117 0 0 cm BI /IM true /W 136 /H 117 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±î?‹ÿòj—>Ž#ˆâ8Ž#ˆâ8Ž#Z8Ž#ˆâ8Ž#ˆâàÿÿÿÿÿˆˆˆˆˆÁˆˆˆÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿæø@þ/ÿɪ[ k“ ø€ EI endstream endobj 79 0 obj <>stream 0 0 0 0 134 92 d1 134 0 0 92 0 0 cm BI /IM true /W 134 /H 92 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¬ìÍÁ© |qäÕ/Á—GÄqGÄkGÄqGÄB#ˆÿÿÿÿâ""$ˆ+DDC0‚ÖÁøƒ.¸$÷¢„·¯zÐeÓÒ‡ÐøJô›ÿ[ÒÂý½/áÿ…ú¿×ÿÿÿõþÿÿ®þÿ†¿ µïïÖÚöá¯k¶–ÿil^ÂðÐX`Á-ëa‚[ `_Ȩ'b°ÂØ[[_ƒ aa¬,0¿ ‚\aF@ðÜ y'€€ EI endstream endobj 80 0 obj <>stream 0 0 0 0 192 96 d1 192 0 0 96 0 0 cm BI /IM true /W 192 /H 96 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡çÜ ðO Áa|†@j¤……‚Â\%‚Ž,, \,X"( ¸A`p°a< 0ˆ°jA‚ <Eð‚à°‚Á…ÁÁà°AaÂà‚ÁÈ  Á„   ´)„ „ ‰à« ª+…‚ …„ Ô+…Á ‚  ‚"á\, X\-áD(.„ €m MP_°¶  EI endstream endobj 81 0 obj <>stream 0 0 0 159 14 282 d1 14 0 0 123 0 159 cm BI /IM true /W 14 /H 123 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¬ó‚ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿɪ_ƒ EI endstream endobj 82 0 obj <> stream 60 0 0 0 0 0 d1 endstream endobj 83 0 obj <>stream 0 0 0 128 47 148 d1 47 0 0 20 0 128 cm BI /IM true /W 47 /H 20 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡š²Á`°Y)äRˆYÁÊ»Èg@rèâ8¦£õ&¹pÛ EI endstream endobj 84 0 obj <>stream 0 0 0 0 94 70 d1 94 0 0 70 0 0 cm BI /IM true /W 94 /H 70 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡”H‰â2$Óü xL†®i‚ŸAÿ§Â ÑÄÿßA ôk Âôý ?ý[õúÿ„Ÿ÷ÿ×÷Çÿø_ÿÿÿ¯ýøküš¨Kÿÿh/¯¿‡Cý×`»ÿaÿ·Ûkþk;ím[P EI endstream endobj 85 0 obj <> endobj 89 0 obj <>stream 0 0 0 0 192 61 d1 192 0 0 61 0 0 cm BI /IM true /W 192 /H 61 /BPC 1 /D[1 0] /F/CCF /DP<> ID <I aZµý¨j“]¥Úï[il4» Úì0‚Þ¶[a.× 0— w…°Á-´¸0» à %‡‚Ø0Ka„¸0¸`È ƶD€ðp°ð¶ Á‘0<7É@vA±a•@.°Ä_ƒ† ,0Y}„üÝ@Q Y¹àÁdk9Âþ@ðÎ’  EI endstream endobj 90 0 obj <>stream 0 0 0 0 134 104 d1 134 0 0 104 0 0 cm BI /IM true /W 134 /H 104 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xp@ÿOÖµ…¯­k _ZÖÖ°°ˆE¥ë¥Á.¼ ¸%ë¥Â\ ¸Azà—áÈ zàpKe,à‚äB¼.CMKÍ$äÙ¯/dpAx/ _ ;5xY[¨/•@=Ád°&¨‹àÇ `xþ Ö†–?ÿÿÿÿÿÿÿÿý¯Á‚äp€ EI endstream endobj 91 0 obj <>stream 0 0 0 0 139 98 d1 139 0 0 98 0 0 cm BI /IM true /W 139 /H 98 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ¨TÁWä5Œò[ì<ØÀÌ‚ðàƒÓ§Ⱥ8Ž#ˆâáïAˆâšÃÑw¢`O•x¼ ¾Dᣭé0øAøO¤ëÖú|+ôü+÷ÿJÿðýǧÿÿÿÿþÔš¬/ûü/ûׯí,?붗av_ì0‚ÛK•x'† †Léo[#@N¶JX.=¬5µ† kðaa‚Á…ƒ;  Á~CXÏ ¨§7€€ EI endstream endobj 92 0 obj <>stream 0 0 0 0 131 20 d1 131 0 0 20 0 0 cm BI /IM true /W 131 /H 20 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡škå0 8/༇ÿ"”p¼à˜ÿùW‘ó 9tqYtqS@Ñú©5ËàÎ  EI endstream endobj 93 0 obj <>stream 0 0 0 0 139 104 d1 139 0 0 104 0 0 cm BI /IM true /W 139 /H 104 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡¦P†lƒ@Œ†RL Èm‘þƒÁÓAè0žšþ˜O §¦žƒAè«Gÿý!&]y.ØD` ÷ÁhÔ txA¾žƒè ÚA‡ÓÂ}u¾˜tý=}>úÚW¿ÿ…Š¾œ?Âÿô¿ÿÿ¯ÿߊØÿÿ¯ÿÿÿÿÿÿÿ½Iª¬/ÿÿ¿ÿµ]úøþDü%ýü0ºÿ~ÚN—ÿÚ ýµm.ÖðÂØ]´›-þ¸a&\0`²0EÊ°øø ÖÓï[ …´×øi­ ÖÓ°ƒ[L/ðh-„ ChÓGÀ@ EI endstream endobj 94 0 obj <>stream 0 0 0 0 192 61 d1 192 0 0 61 0 0 cm BI /IM true /W 192 /H 61 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xBZ„ùÚÎAŸo‚(ÝX#°€Iò »Â‚<>AQÄq\/ððˆ“SÂÞÀôJáò&†üÅ @Þˆ ÃÂ@ðÍ1ÁÐA½ð°xAô7ÁÒoAzÃá>A¾ŸH7 ›Öôaôý ½&õ¾ž)´'Oútè?á95I¨€ EI endstream endobj 95 0 obj <>stream 0 0 0 0 136 124 d1 136 0 0 124 0 0 cm BI /IM true /W 136 /H 124 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡˜Sá•?‚zzd6¦CV¿ðƒ@ôÁ¦žšÓÿDšiáa„ÿOEXÜ>xOéiô÷­¯ ïIÂ"ÿ?MÐ7Ðtá~ÃKÒzoú~áþÒ¿ÿW„ýk~ôý_ÿ^¿øcoÿªýßÿø\V…ÿÿ¿Ø_kÿÿþÿÿÿ¯ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿñÿäÕ-…µ EI endstream endobj 96 0 obj <>stream 0 0 0 85 140 171 d1 140 0 0 86 0 85 cm BI /IM true /W 140 /H 86 /BPC 1 /D[1 0] /F/CCF /DP<> ID & `ì)Áȵ¬'ákZ×Â××ëEZ8Ž#ˆâ8Ž#ˆâ8Ž#ˆâ8Ž#ˆâ8¿ÿÿÿÿÁkÿÿÿÿü! \]~—𿯎¿úÿÿÿù5^ÿÿÿ¿ßûÿÃÿ½ûþ÷ïaÿþüà< <@ EI endstream endobj 97 0 obj <> stream 37 0 0 0 0 0 d1 endstream endobj 98 0 obj <>stream 0 0 0 196 138 342 d1 138 0 0 146 0 196 cm BI /IM true /W 138 /H 146 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡¯Á8X,,/‚ÂÁa,/ °– ‚  …„ ,,., X.,\, XA`¸ X ¸X@°Aap`‚äLá‚ „ „,.@| ¹À¼ °@°¸ °‚à´¯P¡HÀ< ðàør‚ ppä×ðö‡È V > x|<|…ôxaàø`ðÃàðaᇃáƒÃƒÁ‡†BÃVƒ†< <|x`ð|0ðaðxaá¼Ü<áàððð°a@@ EI endstream endobj 99 0 obj <>stream 0 0 0 0 140 117 d1 140 0 0 117 0 0 cm BI /IM true /W 140 /H 117 /BPC 1 /D[1 0] /F/CCF /DP<> ID & Úv4ä5<­aá|µ‚úZ裈â8Ž#ˆâ8Ž#ˆâ8Ž#ˆâá ÿÿÿðZÈàx5`‡`x6ÐZõ ]a.µëAuú_¥ý~_úõÿýÇõÿÿýÿ&«ýÿÿ¿ðýÿ{·ü=¾ýá‡Ãáì˜ÃVüàÕgiO¾½ïï{Ãø<<Á…mØ×À@ EI endstream endobj 100 0 obj <>stream 0 0 0 179 133 287 d1 133 0 0 108 0 179 cm BI /IM true /W 133 /H 108 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡ªx ¨ §ÿÿÿÿÿÿÿÿÿÿù¶i„Åÿɪÿ –çkÓáxKÂø_ |//KÁ}á/‚ô¼õðxKë Ð^¾/KëÂá/_/A}x ½/_ ¾¼ ^—…ð— ¾‚^‚õð—]uÁ\.¸\/ë® ­…ü,€€ EI endstream endobj 101 0 obj <>stream 0 0 0 198 104 290 d1 104 0 0 92 0 198 cm BI /IM true /W 104 /H 92 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡˜lLd `駅‡ÿkÿkÿ /øx[iÚï$%‡ë|{_öÒÞ¿Øa-ëµÿm,<-ëµÿm-ëý†ÃÂãÈÇÈi˜CD6ö½ASˆôÿþ×ò*3¨û"c!°F8éóEÂÃÖøAÿÒo[ÿI¼,>Ÿ[éõ½o„ý&ð°ÿÒo[ÿI¿õ¼$Ãÿ„þŸÿú|<-¦°Á ø€ EI endstream endobj 102 0 obj <> stream 47 0 0 0 0 0 d1 endstream endobj 103 0 obj <>stream 0 0 0 0 97 69 d1 97 0 0 69 0 0 cm BI /IM true /W 97 /H 69 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡”u‰á2 h?ÂxAè2‡ÓôÿôD#ˆ8x@„‡×ù¨?Aï?A¦úþŸ…‡éÿúøÿáÿÂÿþ¿á/ÿà ‚ÿª“U×Ò^ÿÔ%Ý%‡þÒKm‚áགAvA-ê¸0%°`‚¹II¤Ã kk ,0¿ -…n†C4Oò…à EI endstream endobj 104 0 obj <> endobj 108 0 obj <>stream 0 0 0 0 138 218 d1 138 0 0 218 0 0 cm BI /IM true /W 138 /H 218 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡dw!§<ƒ‚È!|àÈN@ðT‚Á`—ä’œÁpK xÂÈ „ x¡x" äJ\‚d Y²Ü H„%€« ¬[Ú-ÁpA`ˆP,ಥ¸"XœAp® !Ëp@°\"Š%`xfà´E@ðÔÁG#@xm”€x+‚‘€x©P‚9Ão"€xkƒ’°<‰® < _eH Áðy«†I@ñdSÈhRÁ•0=d” ÃÁ’P'kSÁƒÁ•@dÁàÁä‰2 JX2¦pePpðd” H3’`ùÉO >ICÈ“ x.IƒäX7ÃÈ ˜n@ðÔ<àþ@ðWI< ÆAäƒ*¸,á´7ä aLYÁ¤§°K’‘ ‚ÈdÁÈ0N* ÉÑ^ YÈrX °‰P*È2à¹ÐL\•‚Ì,*Ô†`&@¸&\•ád+Á < ˜@²e¼”á›@´EðÔ¬AHÐe  ä  e8Ê°<H ¸9ÃX–àÒMr†_Ø=•0<4`ðÊÀ V@ñ ùÕr8<XÈ0x>A­WI—VCn AYW ¤«†+ Ñ P±ƒ+ ¢AW ’†yÍW•H0yìáò ¹Áº—Á¸<á¦Qðx<àÈN@ð$äš ò x0P EI endstream endobj 109 0 obj <>stream 0 0 0 0 93 71 d1 93 0 0 71 0 0 cm BI /IM true /W 93 /H 71 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x7 :Ö¾°µ­}aak_jôºðK„½t Â\ð\à—äÀù Ñ/ P'È`«˜“°XY h_%©‘ $•`³&±Ô_Çÿÿÿÿÿÿþ (€ EI endstream endobj 110 0 obj <> endobj 114 0 obj <>stream 0 0 0 111 47 131 d1 47 0 0 20 0 111 cm BI /IM true /W 47 /H 20 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡š²Èl' !¸/‘J!g*/":GÅ4 ©5ˆ؀ EI endstream endobj 115 0 obj <> stream 94 0 0 0 0 0 d1 endstream endobj 116 0 obj <>stream 0 0 0 0 155 53 d1 155 0 0 53 0 0 cm BI /IM true /W 155 /H 53 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¨œ2 üZa…í{Rjš]¯ .õ‡…Úí¥Ã °Â\Žšã×il0— .a¶–õ°`–à pÂáƒÁ‚[ÖÈØ)­‘@Û\”ŸA€[†Xa~X0Xa`Áa…ùs,0²Y±løO€€ EI endstream endobj 117 0 obj <>stream 0 0 0 79 123 176 d1 123 0 0 97 0 79 cm BI /IM true /W 123 /H 97 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¦xJOOÿÿÿÿÿÿ’ØýÿÿÿßÁä"²ÁÍ¿D 5á7àƒð~‚oÿA7éý}&ÿõýkáµÂÚ÷ÿ¯ÿÿõÿ¿……‡É¯_û­×µí{ oðÒÛ^ö lAaþ †Â{ aWý¬0[_µ†°Áa…† ò‚Xe ÈjW EI endstream endobj 118 0 obj <>stream 0 0 0 189 90 271 d1 90 0 0 82 0 189 cm BI /IM true /W 90 /H 82 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡¶hÒ ŸÂÉ0/A ðX=aëÿ‡­áoïA_5¬†¿ ‡¨íÿéddøY ðý`Þ–ÿßïÂؼxÿ­¿ÿýÿÿÿïÿþ¤×þþ»ÿ×ÿï.ÿõÛׇ¥¿÷¥·…ï^ a½w뇂 dâ=­¬5µ°¿kk ,0°ÂüX`² dðe8j€ EI endstream endobj 119 0 obj <>stream 0 0 0 0 123 82 d1 123 0 0 82 0 0 cm BI /IM true /W 123 /H 82 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xmŸžŸä þa?ôï7ÿþøa‹ÿ÷ïÁøÿÿÿÿ×þþ×ÿKÿ à”G×S°Tõ×X× †d0Öÿÿÿÿÿÿÿÿÿÿÿòj—í†b€€ EI endstream endobj 120 0 obj <>stream 0 0 0 0 111 85 d1 111 0 0 85 0 0 cm BI /IM true /W 111 /H 85 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ÜÐä× „†×ÿ¨Aëêž¾ÿAè¨_áz?)Àß×Âõÿëáqÿõÿÿÿßÿðù5ßßÿ~ÉpRñ"vÿ·ýáïx°ÖCfÂdÿÿÿÿÿÿÿÿÿÿíu†  EI endstream endobj 121 0 obj <>stream 0 0 0 0 90 77 d1 90 0 0 77 0 0 cm BI /IM true /W 90 /H 77 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡° @ðƒÂ„ôÈh þ˜ z~©ÂßkÑ­ËèC}MÖ“ÂéÚûúpo_ødOáÃ…¿áýøÿ¶þ¿÷ÿÿÿþÿ÷¿ÿú“^þû®ÿ¿ß_íÃø>v†þÁÚï×ÚðvÂǦú×¼a®ímmI®®þ  EI endstream endobj 122 0 obj <>stream 0 0 0 224 106 324 d1 106 0 0 100 0 224 cm BI /IM true /W 106 /H 100 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x! h<ÁäƲ @OÈ+dò› ѹä ïOȲùÙRἚ¢ -ðû>ÿÿ¯ÿþ¿ýk×õ…ׯÐ]k¥…ëKAk¥‚]hð‘êÁ äÊ ° $TÈ+-d 2›Ž² ü}‘#iò ´ùÓó²DÛF߆—‰ØàØRÁX¬™R‚X ù(â$ˆRá‚jˆ€<6YÐ ¯³àx5€ EI endstream endobj 123 0 obj <>stream 0 0 0 0 110 95 d1 110 0 0 95 0 0 cm BI /IM true /W 110 /H 95 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x¦ o |¯ ´%'*üƒ*–AT—!®ekÞd2öGä6lfA}«ÈMd·åa@ð¿Á ó±Ã8zÿo²‡ä°-ù/Èlßü˜ «Ø/µ ³øAyFõü/¯ëéúü$¿×_Zð¿ý­éÒÿê¿ÿ]~¾—…ÿÿ ‚ÿúýB_ñþ‚_­{¥×ô¬%ýi.¡ {K°¡®< °£&©„¸úÃõµÂý­­¬5°_†Atù Ÿ EI endstream endobj 124 0 obj <>stream 0 0 0 119 106 290 d1 106 0 0 171 0 119 cm BI /IM true /W 106 /H 171 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x! h<ÁäƲ $È+dò› Ñ¿ü}é#eò ²yÆól2”„wáüìpÑ”°Ëe`åHd°ä  <‰̤Ãy5D@[:áv|?ÿÿ_ÿÂ×ÿ¯Òü/_¥Â×^ºÒÂ률ºÒÁ-p`ƒü" 1 Î5X(Èd‰? Ø—ÔØùþ@¾ôȲÿM“Èö7›bø^wáüìpщJ ¼¬[åHd°ä  $He ù5D@[:áv|1ÿÿëÿÿ…¯ÿZõøKõë…®—éa/ÒÐZé`—ZG<$z°CÂyrŸÈ,ä 2 ËYÃL†¦ã¬ƒFÿ _ddÚ|‚m>G´üì€Q6Ñ„wá¥âv86°V+¦T`–>Jø‰â€x`š¢  –tÃ+ìø @ EI endstream endobj 125 0 obj <>stream 0 0 0 0 110 96 d1 110 0 0 96 0 0 cm BI /IM true /W 110 /H 96 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ÌK†\8–è=ïø}ðò ðœŒ_Ð"_Â/…ÃzÿX7¥¿ï¥°úÃëÿÞ[õÿ¾—ÿuýÞ—ÿÿ_Âÿÿáþµÿÿõþ¿ÿÿ¥ÿ…ÿÐ_ýzúÞ—ÿRj¸^ô¿_Ð\=pý~ï Þ»z]à–ü.ÛÒï:NVÁÖ)u²%ǵ°¶Ãû ,0X2& ŸR$†® EI endstream endobj 126 0 obj <>stream 0 0 0 197 141 284 d1 141 0 0 87 0 197 cm BI /IM true /W 141 /H 87 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡Î9Á˜Œ.¿Þÿÿ‡áÿïÿÿùÃ7øAÿ§ÿÿè/ÿÿÿ¯ ÿ¯Êÿÿõ¯_×ò`ÿä”yF8ÿ x7ë x.¥<*®@ó[È3šd7}d 7™mÓ Ù½r›¯ ѺùÙ§ _zäÙ|‚lžG´å›u|íøG~yØà_)`Ñ•€ÓÊ6ä°òP ‘ XÊ@gɪ"óìè…[> üZ€€ EI endstream endobj 127 0 obj <>stream 0 0 0 0 110 106 d1 110 0 0 106 0 0 cm BI /IM true /W 110 /H 106 /BPC 1 /D[1 0] /F/CCF /DP<> ID & °F”‚˜A\_!¶[ø@ðƒÁ< z‚zxD]O‰¯Zá Q¢ D˜j=| Mè7Á>‚}/Xx@Ÿ ü/A7¥ëõé7¯ …ÿIõþ—úúÿ…×õþ_ÿÿªþ5ÿákøKÿKõ´ºý&ªµô¸i‡K°Kµð‚Û }m„¸2J; °È5¤ä˜[Ö0q_°¶ÖÁa…øk`°`°Áa‚ü†iŒ†ž° EI endstream endobj 128 0 obj <>stream 0 0 0 117 106 196 d1 106 0 0 79 0 117 cm BI /IM true /W 106 /H 79 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xfá®?ÿÿÐ_ÿýaô¿¯×­zý…ë^´º×\ ºÒÒ×K H„ž‘:°CÂx_Èd 2 ËYÃL†¦ã¬ƒFÿ _ddÚ|‚m>G´üì€Q6Ñ„wá¥âv86°V+¦T`–>Jø‰â€x`š¢  –tÃ+ìø @ EI endstream endobj 129 0 obj <>stream 0 0 0 97 103 214 d1 103 0 0 117 0 97 cm BI /IM true /W 103 /H 117 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x5ýakZÿXZ×Zég°º”Z\+JPøam. ÐV”5°”Rjµ¶‚ÛKƒ\ l:ÃÖ  ¶ .× 4¶K¬0Ð[iv¸0iak°Âý¬|7ƒßAþzz£RH7Óá “zÃÒ é0}Â7¤ÃÖ ÃÒo øIô7^“Ò}ÂOA¯IééáCÒ kè ÂÒ°––º ®¢«áUWPªMR€€ EI endstream endobj 130 0 obj <>stream 0 0 0 0 134 109 d1 134 0 0 109 0 0 cm BI /IM true /W 134 /H 109 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xr$$§ò°¬x'„OðO éàƒÑGÄÿý"ͧ¢]oè¤ W O¤zøA>“ðOÓtºôƒázxK×_]_ ×_ô«¯þ¼,/_ø_×úIá~¿é/ý~¥õëá/]ÒíTþ¿B/iù=†A§ý²  »d4Õ8d2Ö¶ ˜aûëb°×àÎÓ…ÓÚ~v@(ÍØyû# FÓä>Óä{¯ pGtˆ#¾·âdˆVðÁRÃa-Ã+"àx5°<5Š@<6ɪ"ðe²ÿ ð€ EI endstream endobj 131 0 obj <>stream 0 0 0 111 110 212 d1 110 0 0 101 0 111 cm BI /IM true /W 110 /H 101 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x5@ð0Œ ÿ¿ï~ÿoß Â!áøð­è/ý/Iÿêé„Ã믮¿é×úÿÂÿøKá}ÿñKýkü,/ék×éZázù5Tkëý,=v½„¼.ØApa-ë°Kl%à ÔÉ0PÈÐU‡®!l/ÚØ[X0[ ðÁa…†JZC,SR¿ÈiÕ EI endstream endobj 132 0 obj <>stream 0 0 0 227 136 301 d1 136 0 0 74 0 227 cm BI /IM true /W 136 /H 74 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x5 (@ÿôÿÿÿÿò?ôP‹ÓÿÂÿõëõëÿ×þ—ÿäF‚È0ÈTÿýd”xáò„ ×ÈJ¼áºÔdM2û¼‚¾éÂÈ6ïò{üƒNÑd ì‹ ÆÈहbvkþv yÝ@™5Gt þw`_ɘ4Ã$¡©Ù ®ÉP+öDÀ߃*À¯þ üý¯ÚØP EI endstream endobj 133 0 obj <>stream 0 0 0 111 141 222 d1 141 0 0 111 0 111 cm BI /IM true /W 141 /H 111 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡dºò¸LàÈä ¡IÃPª@ði< *ÈÖüàæ’‹»ÈïÁr›ò²²û"‡Ç Ë°ò{!¯ºò {OËÚ~v@kHlØyöBlKi0ƒç~/Ž ½°0ß+ÓåH5Ÿ%€«ä _"@±ûàŸjÂö}…â“ëá+Òúô¥ëõá~½%ÿ_…ëõúZÿø\%ü/_ã^µëô¬/é~‚µ× CJMWð—iv Ú „¾¶%ØK†A¬d˜ ‘ E½lV/ëama‚à ö ,X2.†$3¿ Öž  EI endstream endobj 134 0 obj <>stream 0 0 0 228 14 294 d1 14 0 0 66 0 228 cm BI /IM true /W 14 /H 66 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¬?‹ÿÿÿÿÿÿÿɪ_†€€ EI endstream endobj 135 0 obj <> stream 48 0 0 0 0 0 d1 endstream endobj 136 0 obj <>stream 0 0 0 0 105 99 d1 105 0 0 99 0 0 cm BI /IM true /W 105 /H 99 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xi­8,/¬°]k…ÁtT%…¯ZX\ZÖX@°¸K.XAap‚Ð\,XAk‚ .–A`— °–  XK…‚¥…ÐX ]h-ר…PP¥@  >stream 0 0 0 120 138 162 d1 138 0 0 42 0 120 cm BI /IM true /W 138 /H 42 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x/È A2‚¨á®) x5•H€¾@ðn« x.· xSIÏy Ï¿¹ØëYý@“dA[iò ›ÔÝ|ì€ÊhÙû# FÓäiò=§çd<ÛFßÿ‰Øàx¥,+xg*@x%€x4ä  2$ƒiH‚¹5D@ötÁgìødà EI endstream endobj 138 0 obj <>stream 0 0 0 0 106 99 d1 106 0 0 99 0 0 cm BI /IM true /W 106 /H 99 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xYÃ8?Èb@ñDäÊd d Õ<ƒ*Ô†Ù¤†¾âA¯sÈeìå?ÖCfÂû#!6Ÿ%º°ŽÃ߃Nv8jÑK ¿ÊÀ2eH2X™(Ã|‰çùÄ°¶¶}…Š \%¥ÂÒýtºü%úè/ëõý/ÿÂ_ÿÿä'ùÃÕ<äF$ ÄÙBŸ ¬ Ú©!¦´ÈfHÜjMS Æÿƒ"m|ìH\í <3±£;Ð Y߃Oçc†­•°Û²ª –Aâϲ6†ðÊ€<¤"  EI endstream endobj 139 0 obj <>stream 0 0 0 101 110 195 d1 110 0 0 94 0 101 cm BI /IM true /W 110 /H 94 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x5yÃ(=?ïÿ!¥Íä3+ð@ül?ôÃàøNõð›ÿ§é¾·AÿÉq< M‡Â~·Ò ýõ}'ÿ×õýü+áþ¿¿ÿèð¿×ïÿÚýë†ÿ…á}.þ×a„¿¶Â]…ãØRjµïÝxkþXv¾ Ã]†ûlƒ È)Ól{ý‡Þÿ†ÿö¸-…³`x4x€ EI endstream endobj 140 0 obj <>stream 0 0 0 212 19 234 d1 19 0 0 22 0 212 cm BI /IM true /W 19 /H 22 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ‹"¢zÇÿó¢ëñ“Th € EI endstream endobj 141 0 obj <>stream 0 0 0 0 155 53 d1 155 0 0 53 0 0 cm BI /IM true /W 155 /H 53 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ~BüX¶@à+ ʵøAä6÷˜Aàáø xAá„AQÄq„J×áüŽtECMàˆ mƒÖôDMè[àôÂ0õ½Ð o§ÐA¼ ƒ[ÐA½&ú~}ÂÃéô›ÿAúxí:tü üš¤ÖÓ[M@@ EI endstream endobj 142 0 obj <>stream 0 0 0 0 132 97 d1 132 0 0 97 0 0 cm BI /IM true /W 132 /H 97 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xR>@ñ‰áÁ„?Ðzzz òa]{Òo[ÑH<„ Àø@ø@›Ò÷¤ýøO¤ý?Þ—ï×ᇅÂÿïýÿÿÿõß/¾ƒáx ábá×k¿Úï]®Ú\^×a¥‡ù !l“ê"U˜ÿÿ΀xkÿÿÿÿÿÿäÕ&¿ÃMl&  EI endstream endobj 143 0 obj <>stream 0 0 0 116 121 199 d1 121 0 0 83 0 116 cm BI /IM true /W 121 /H 83 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¦`X zÿÿÿÿÿÿÿÎÉ`ûÿò ?ÿÿÿÿÿÿÿÿÿÿäÕ&¶šÁ‚ (€ EI endstream endobj 144 0 obj <> stream 45 0 0 0 0 0 d1 endstream endobj 145 0 obj <>stream 0 0 0 0 87 102 d1 87 0 0 102 0 0 cm BI /IM true /W 87 /H 102 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¦xAééÿÿÿÿÿÿó´öÿÿÿ÷ð{"_ø@½x]/]}uõÿ øÚÚ¦±ÿÿþþ&¿¾;OXÏ®÷ÿ߇ïßü x@ÿÿÿÿþ×ím@@ EI endstream endobj 146 0 obj <>stream 0 0 0 131 27 157 d1 27 0 0 26 0 131 cm BI /IM true /W 27 /H 26 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¢„„žŸþŸÄ?äÕû_û[X0Xa@@ EI endstream endobj 147 0 obj <>stream 0 0 0 216 124 286 d1 124 0 0 70 0 216 cm BI /IM true /W 124 /H 70 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±à<è=8¿ÿÿÿÿÿ¬°\(P ¤0<Zð´Z]azÐ_×Zÿõÿ3_ÿÿ“UªÞŸÿL,D0  EI endstream endobj 148 0 obj <>stream 0 0 0 80 91 170 d1 91 0 0 90 0 80 cm BI /IM true /W 91 /H 90 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡´x6áÓü ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿò{¯< þ/òj—á…øad5kÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿü0¿ö°Á@@ EI endstream endobj 149 0 obj <> stream 32 0 0 0 0 0 d1 endstream endobj 150 0 obj <>stream 0 0 0 201 127 287 d1 127 0 0 86 0 201 cm BI /IM true /W 127 /H 86 /BPC 1 /D[1 0] /F/CCF /DP<> ID & HB$‚¨¶A°+!¨±ø y Ýæx xAþžž‰b8Ž'‚%+ð#†Îˆ˜j½ VzÞˆ¼" ááèo[á>7Â~é7þ‡×Âï×ôÿÿÿjMV»ýxaÃp½{]†— w®Áv\]† pÂáál˜u²4 Ë‘@Õì–űX0[[_ƒµ† _k2Á‚È6dE²>  EI endstream endobj 151 0 obj <>stream 0 0 0 203 125 296 d1 125 0 0 93 0 203 cm BI /IM true /W 125 /H 93 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡¬x!üßé„ôø¿ÿÿÿÿÿÿÿþ'a?¿òl:?¯ø^ ×…á/ü%è‚øKÐ_ Á&©h/Âíh-¬Xõáô¼Ð^/¯/ zø ^ø^‚ðAzøAz áx%áãë…ÁuÂþ¸.¸\á®P EI endstream endobj 152 0 obj <>stream 0 0 0 74 123 171 d1 123 0 0 97 0 74 cm BI /IM true /W 123 /H 97 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ÔRá¿Èf áÁ„?Ðzzz òa]{Òo[ÑH<„ Àø@ø@›Ò÷¤ýøO¤ý?Þ—ï×á‡Âãÿ¯ÿÿÿ[ÿ…&¿ð¼:íwû]ëµÛKƒ Úì4°ÿ!¤-’`]dö©„þŸÿÿýïyÁX?ÿÿÿÿµû[P EI endstream endobj 153 0 obj <>stream 0 0 0 0 90 86 d1 90 0 0 86 0 0 cm BI /IM true /W 90 /H 86 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡ªu i¥y Á,"P>< ðAè=?ÓÐxOD O^úF4Iƒw Aþ oAá?@Þ“ýðŸJú~Ÿ_áôþÿôÿÿÿý¯&¾¸kÿý„ûkÚï]ü4»]°^[øa„¸0Apav@Á;µµ†¿amml,_† ,2$² Jò•ü@ EI endstream endobj 154 0 obj <>stream 0 0 0 110 90 189 d1 90 0 0 79 0 110 cm BI /IM true /W 90 /H 79 /BPC 1 /D[1 0] /F/CCF /DP<> ID & Á83ü) ¹àƒ=Bªz§þ·…þõø_5¯¬(~>¿ úoAéäuþýÿÿÿ¾¿“\:ÿ׿Â÷ uÿm.þî— .õØ\6— Ø]’aœ-ë «b¿|5°[XkðÖÁa…ƒ†ä•ä5+€€ EI endstream endobj 155 0 obj <>stream 0 0 0 205 121 304 d1 121 0 0 99 0 205 cm BI /IM true /W 121 /H 99 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¦`X zqy|ü ôôÿÿÿáðÿ¾ø>ÂÚý¬ÚØ[_Ð5Û^×`ü6í¬š¤ÚüíÑ­p`ƒa/ý´¼…ÿµí{^ 5°¼¼ü ÚkM¡ðÔXKAk¥¯XKK]¥×XJ'dàþÿÈ`x4ÿÿÿÿÿ“TšÚk Âþ  EI endstream endobj 156 0 obj <>stream 0 0 0 0 155 90 d1 155 0 0 90 0 0 cm BI /IM true /W 155 /H 90 /BPC 1 /D[1 0] /F/CCF /DP<> ID & A¬‰W‚„z§„™Ã7´ÈÃåB„ùN‚8„$²ƒ)Â|áR/ y‰|0¡ZgbBɪAd³Â[P¶ˆa„/ ¤ ´-¢ À¸aAa„," åž EdAq•ƒ)¨3ÁAXž x"  ðA%`ËÁž•#ÁPx “Á@'|/D¤‰pž)À†?"€~p©È(N5!ðv¸aIª A„ÙÔ ‚¶†x Å‹_°°ÖÖX0_†@ð(ª  EI endstream endobj 157 0 obj <>stream 0 0 0 79 127 170 d1 127 0 0 91 0 79 cm BI /IM true /W 127 /H 91 /BPC 1 /D[1 0] /F/CCF /DP<> ID & Á8)ž ¹¬ x_ §…õÿ×Òõÿ Ð/„?Ä \hò  X[!¬)…È5Iªý…ò¸apØ"+{¼>—`ˆÐc[a¸ab@€ñØ\–àÂ!·^Șm•aŽ…°‚`°½BA§¦  iáƒÿ@Â*Äò0`ea¯A醓è<'¤iz Ap¿„^ .šÆA, ¯%`ú BÁö°KJÖÒ†‚äa…&¨0H\¨ˆ.7Çá¢Ëô; ­¯ÚÚà ,0¿ ,‚` EI endstream endobj 158 0 obj <>stream 0 0 0 115 123 191 d1 123 0 0 76 0 115 cm BI /IM true /W 123 /H 76 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¦`8 zqÿÿÿÿÿó´á”|PÁý;OOðƒÿÿü0¤0+ÿû^×µàÁxÿÿÿÿÿÿÿÿÿÿíIª_†Ðó  EI endstream endobj 159 0 obj <>stream 0 0 0 98 87 200 d1 87 0 0 102 0 98 cm BI /IM true /W 87 /H 102 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±à<ƒÓ‹ÿÿÿ¸l;ð_Ãï¾þC'ùzöáÿ¹šÿ&«]ëÿ\GõÂüßé…ÿN¢×õÒý,.ºX^ `”Iƒïÿÿù ÿÿÿÿÿÿòj“_í5´Ô@ EI endstream endobj 160 0 obj <>stream 0 0 0 0 90 96 d1 90 0 0 96 0 0 cm BI /IM true /W 90 /H 96 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±@þŸÿÿÿÿÿÿùÙ¨Ãýƒáðø}ïÞïaïýá èÿÞ‚Pü,ë}(Oûzÿ_û¬>¿ÿÿÂÛÿÿ…qÿ×ëÿëÿÿ×_ïëëù5ÃשÄ|.ÂAw¥¼/µ^×᯳È0JÇï_õ½ø~¾šÞXÐ`º /ö‡°ÂÁ…†P   EI endstream endobj 161 0 obj <>stream 0 0 0 78 85 170 d1 85 0 0 92 0 78 cm BI /IM true /W 85 /H 92 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¹ é<7È°ƒÓÓÿÿÿü=á…íCV0­xaZ†¨aH¶°ÃŒ]…ÌÔ0ÒÉªÓ þ\a&± ãðÂk ÂÃ[ ôý‚dóz ðƒŒAþ §áŤß&­ðA:Aôâ Ð~ƒ§è:Á:t áÿÿÿû_&©~Xa @ EI endstream endobj 162 0 obj <>stream 0 0 0 78 87 170 d1 87 0 0 92 0 78 cm BI /IM true /W 87 /H 92 /BPC 1 /D[1 0] /F/CCF /DP<> ID & y™„„ƒï ÷ÿßÿÃÿx<ÿç¢þŸáEø_þµýzý-pºZð´C]k ák_ë!¬pK ÐPaýÿÿÿ!_ÿÿÿÿÿÿÿÿÿþMRki¬0ƒ  EI endstream endobj 163 0 obj <>stream 0 0 0 213 17 296 d1 17 0 0 83 0 213 cm BI /IM true /W 17 /H 83 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¦x¡Óÿˆÿÿÿÿÿÿÿÿòk…ûX`  EI endstream endobj 164 0 obj <> stream 52 0 0 0 0 0 d1 endstream endobj 165 0 obj <>stream 0 0 0 96 87 204 d1 87 0 0 108 0 96 cm BI /IM true /W 87 /H 108 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±à<?‹ÿþw€AÝÁÃîï¾C>@¡?ƒû“T}.õÿ‡®"¿áfð¸Aþ¿Qk„°¸K ª£¬ƒj¸®¯ƒ»¿¹ ü9„ðrj—û]®=›Â ?ÿJ-p¸K ~AT&Aµ\AÃûÿÿÀ¯ÿÿÿ&©5þA… EI endstream endobj 166 0 obj <>stream 0 0 0 243 85 269 d1 85 0 0 26 0 243 cm BI /IM true /W 85 /H 26 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¢‚™ðƒ zié§ÿúiÿÂÿÿ&¨ ×ûMþÓ[M`Á†`  EI endstream endobj 167 0 obj <>stream 0 0 0 0 135 96 d1 135 0 0 96 0 0 cm BI /IM true /W 135 /H 96 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xŸ=>stream 0 0 0 0 97 71 d1 97 0 0 71 0 0 cm BI /IM true /W 97 /H 71 /BPC 1 /D[1 0] /F/CCF /DP<> ID &   ä3§Â †e4 ¨‚h?ôÂM¦ž©á¼ƒ_šÂ0ˆb‡ @ðƒzÚß ô›Hàž¿}ôºoãúáa0ýþ¿ÚÿãÃaÿÿþÿÿ_ÿÿþMP}~Óûÿü:ÂøkØ_¹ž×uÒÿö &ëµ°^,ì$à lq]O»_í5´ÂÚ ,al3@Ùü0‡ ¡ EI endstream endobj 169 0 obj <> endobj 170 0 obj <>stream 0 0 0 0 103 82 d1 103 0 0 82 0 0 cm BI /IM true /W 103 /H 82 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ¬P ÔÿðƒÓý?Óý?ÂôÿOOÿOˆAüŽºCzß_O­ÿ ƒxI‡ÿO¤Þ·þ“è ßO…‡­ôý>·Óëz7ÿO„˜zßúMë}?>·…‡Óé7ÿO¤Þ·þ‚ ôøX}>stream 0 0 0 240 64 273 d1 64 0 0 33 0 240 cm BI /IM true /W 64 /H 33 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡˜T.5øAàžzx'úzè«G¯Â‹å@}ྂëë ^šÂ_MG.°ž±ª`¨dÕ¬5†@ EI endstream endobj 175 0 obj <> stream 59 0 0 0 0 0 d1 endstream endobj 176 0 obj <>stream 0 0 0 0 121 95 d1 121 0 0 95 0 0 cm BI /IM true /W 121 /H 95 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x*9Ã, ÿOÿÿþùôq`ÿÿÿ7ðƒþ/ÿÿÿÿÿÇÿü†ƒOÿÿÿÿù5Kÿá…ÇÿùÃ4Ä/õÿÿÿµÖP EI endstream endobj 177 0 obj <>stream 0 0 0 208 121 302 d1 121 0 0 94 0 208 cm BI /IM true /W 121 /H 94 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ÊD$†Ð®CT ÖK‚‚øAàƒÐ<' ÿˆª8Ž#ˆ=½DFðˆ5ÁlÑH Aõ¾>‚ú„ ‡Ð>·Óé7Óðƒé7ÿ_¿O§ÿ„ÿÿÿÿÿÿÿÿÿù ŸÿÿɪM†a EI endstream endobj 178 0 obj <>stream 0 0 0 0 121 97 d1 121 0 0 97 0 0 cm BI /IM true /W 121 /H 97 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¦`YB_ñdUáúÿÖtGÅÿ¡áäÿþCPÇÿÐÿÿÿÿý…þ .CoOÿÿÿÿÿÿÿÿÿÿÿÿÿÿüGÿü†ƒO™¯ÿÿÿÿþMVšÞšÁÄ0±à EI endstream endobj 179 0 obj <>stream 0 0 0 0 127 88 d1 127 0 0 88 0 0 cm BI /IM true /W 127 /H 88 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡šN äYȬ>stream 0 0 0 103 121 195 d1 121 0 0 92 0 103 cm BI /IM true /W 121 /H 92 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xf•?Óÿÿÿ¿ƒ6Ž/øˆ?ÿÈ+pƒÿúÿÿÿÿý¯ðÂäÿÿÿÿ›þü_ÿÿÿÿÿÿÿÿþ#ÿþCÁ§òëÿÿÿÿþMRzÿÃ`  EI endstream endobj 181 0 obj <>stream 0 0 0 0 127 82 d1 127 0 0 82 0 0 cm BI /IM true /W 127 /H 82 /BPC 1 /D[1 0] /F/CCF /DP<> ID & `ì01!Ÿjÿ!öQ„ž§§ú|‹#ˆâ8Ž#ˆâ8¿ÿüâ鈈ˆß)óÿ„Tàáð@ü'éúã …Ýû¯ÿÿÿÿÿýþ¿¾¼š ëÂö½¯ Ã.RçäX|{_µÿµµ†Ö__cX0Y!¨± EI endstream endobj 182 0 obj <>stream 0 0 0 97 124 198 d1 124 0 0 101 0 97 cm BI /IM true /W 124 /H 101 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡Î x5ü'‚뮿¯á~9­Káb<È<?†Ai$ˆpä, &¨Aðiÿ†{aÁ§Ú{iïïàăÿ†aàÁx4ùQ ø0ƒýïàÓôûÞÓÿþÓü0ƒÿÿÿÿ#Ï„Óÿôÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!àÓÿÿÿÿÿý¦¶šÃ0¿€€ EI endstream endobj 183 0 obj <>stream 0 0 0 78 121 170 d1 121 0 0 92 0 78 cm BI /IM true /W 121 /H 92 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±0†T ÿÿ\èŽ#ˆýÿÿÿÿÿþ@ðÓÏÂOOÿÿÿÿÿãÿþCÁ§ùšÿÿÿÿÿäÕi­é¬C  EI endstream endobj 184 0 obj <>stream 0 0 0 78 121 170 d1 121 0 0 92 0 78 cm BI /IM true /W 121 /H 92 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¨ _ñ~@ðk¦ŸþŸàþ (0¼0¬PÁA…á… PÁHx0°~aa°S5ƒ MV† z 0ˆ¿‡ y,D0aÃ_àÂk &°`ƒ !Ãúáüx x Èb™xiá?äOú`bÂ7È¢ð| Ž‹~< N!àÂp@áàÂpAÂÁ8X_ÿû_òj“^;P EI endstream endobj 185 0 obj <>stream 0 0 0 76 121 169 d1 121 0 0 93 0 76 cm BI /IM true /W 121 /H 93 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x9 $&Ÿàéééáúzz*ÑÄõï¡àð§Öú}áÿI¿úú}oOÿÿ?ÿÿÿÿÿÿÿËÏ„ÓñÿÿÿÿÿÿˆÿÿÀðiÿÿÿþMRki¬0ƒ ø€ EI endstream endobj 186 0 obj <>stream 0 0 0 102 127 194 d1 127 0 0 92 0 102 cm BI /IM true /W 127 /H 92 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ®hŽŸéÿÿþIT†X¾ êŸÿÿÿþ¾í|/ðá­‘e ÖȲÊ4I‚A¾AƒÞ¿ÂÃz ÁaúÛÒßøxKøS5ïOÓ×z¿ñ_ÿö¿ú“Të†ÿðÚ µívÒÿa„»^]´¶ ÿ 0‚Ø0K† ²6 «dTVõ†JA€¶+ö°Âà ,0¿ ,,,ƒ`WäE²  EI endstream endobj 187 0 obj <>stream 0 0 0 205 121 299 d1 121 0 0 94 0 205 cm BI /IM true /W 121 /H 94 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x+§úÿÿól–ñÿ”àxey5D¸ ù&ƒ`ûß‘Fù4×"€ÍÃ"ÀV² ƒƒŽ  "À± Ò+ƒ"À¥Á‡TäX$pÁä°`ò B\ ^àøAgÓ ~5"‚Á‘W x¢X> àßäàä ¤ðãÿä0<ÿÿüš¤ÖÓXa@ EI endstream endobj 188 0 obj <>stream 0 0 0 0 60 56 d1 60 0 0 56 0 0 cm BI /IM true /W 60 /H 56 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡ Š¿“UÂè?‹ù5×ì,ŠÈÚ(\z§±|qÿÿÿüƒi.5‘Bóè?ø¿&ºý…ø|†\†µP EI endstream endobj 189 0 obj <>stream 0 0 0 0 127 82 d1 127 0 0 82 0 0 cm BI /IM true /W 127 /H 82 /BPC 1 /D[1 0] /F/CCF /DP<> ID & \¨Ãƒüx@È5Šh0@ðOÐiþŸO§Â&üâÊ}h—ð´6×ß OÓ`ý9é4ƒÌQÓj÷xW~ û¿PÞ=¿÷êØ~ü?ÿmÿ÷ûïûÿß&«þÿûþÿ×Ãðþ®Û_ýÿ».õì7ì;KßÛ†— °^IƒXk²6D˜«ƒcö°XZa¬/íl-…ƒ_†š¤Ápˆm—Á¢ À@ EI endstream endobj 190 0 obj <>stream 0 0 0 210 124 292 d1 124 0 0 82 0 210 cm BI /IM true /W 124 /H 82 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡šBâÈü ðá< È)~ƒ?ôü&>ŸEZ8ƒÿüI¤è7ÂþK‡ÒáôßAü>—鿇é?¯ÿ ß…ÿÿéñÿÿõÿÿÿúÿþ·ÿ®MW÷ý/ÿøa„µÿíÚþÙ)®!…ÚÛÿ‡ÿ~íoî ,0‡ðøk°a@@ EI endstream endobj 191 0 obj <>stream 0 0 0 0 127 88 d1 127 0 0 88 0 0 cm BI /IM true /W 127 /H 88 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ÐtÃ<ƒÁ„éÒ Í/ Á„Âz`ÿ¦ž˜ODš8ƒOü'„¶ƒàþ6ºõµé‹ÐL•Ó" ž˜ o ÓëßÂ~˜_ÓáÐaÿÿô×Þ¿§áÿÿÿÿúþõÿþMW¯þõÿð×ÿá„Xaä={?]ëµî»4×bî·û­áwýaÚÞ·kØ/÷ ‡|5ƒ_†  EI endstream endobj 192 0 obj <>stream 0 0 0 76 124 174 d1 124 0 0 98 0 76 cm BI /IM true /W 124 /H 98 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x)tžŸÿÿüàÚ2@ðÔQ x4HB~@ðØQ x0Y xp¹ÆI ~·ä$7›œ‚¾ÃÚÚ|í솮ßkØü†fûQ¾äßyÛ†YšÈ&Ýë"lÕë'»ü#±Á_XD̲´ùTŇÉ` `< <3J€<5À<J€<5ФX,Á‚‡* x¤Õ ?ɘ-Cá“@V‘6jŸ;àkyߧ FûQ±ù ÍÈ5ì;ár»þCkiäö&ç ±¸ò F’ërŒ’@ðárƒž@ðØQ xe È R†¢‰Á´g<Ãÿÿý­­¯€€ EI endstream endobj 193 0 obj <>stream 0 0 0 184 125 276 d1 125 0 0 92 0 184 cm BI /IM true /W 125 /H 92 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¨ _ñÿFá´Uá©0<H¨ P(* x™ZÙ4c¸“º!Þ€¯ˆÒøjgdL‰½2Øx?;¨;ÍgjÌš­N†Y »Þ² šb9ë^C1Wü†/ ØSÈ+‰rùÁÁ>A\Kl)ÿ!¤ Èf*ò Öæü‚æšy »þ´ò{踎óºàŽÃ ÜÀĉ¹ä÷ñÎÄiÞ€®w@$;€Y&€Í• =•P>stream 0 0 0 0 124 106 d1 124 0 0 106 0 0 cm BI /IM true /W 124 /H 106 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x2…§úÿÿþCOjüƒFÀà°XX/…­`µõõ„F€ñ4Iᎂè/ô¼®—ÚÂý5 Ǩþ¿ÿ¿“Tü᧟ð §éï·þÁûðûá÷á >stream 0 0 0 0 87 94 d1 87 0 0 94 0 0 cm BI /IM true /W 87 /H 94 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xp´ÿOÿÿÿÁ|@ðÜ$bH,¸Ÿ‚È+HmAd4Õr.°DXò‚ür¾•È0Wä\3àˆ°(ÈAyšÉü OZüŠfò”€X Dð) kȨ|šä 2$˜2ÿ²P aïáƒò]< å\+ d6 ð`ù ÁÈ5pc× ƒÈ+y!h<‚À@ðÜ'=ŒƒÁÿÿÿÿµµµ EI endstream endobj 196 0 obj <>stream 0 0 0 0 121 73 d1 121 0 0 73 0 0 cm BI /IM true /W 121 /H 73 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±à<58@ÂüZÿÿÿÿÿÿÿÿüÿÈ`x4ÿÿÿÿÿÿÿÿÿɪM†0P EI endstream endobj 197 0 obj <>stream 0 0 0 0 97 69 d1 97 0 0 69 0 0 cm BI /IM true /W 97 /H 69 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ØD¬†žA ³ð@ðƒÓÁÓü"M<$FAC^¨úðôBÁ ¾ˆ€èA¾ ô?@Þ}%o„OÕzì=—ÿ¤­ê¿úPðµÿ×õÿÂÿÿ…þëÿý{þë×¾MV^Ø_ë¶KØ0½Áqx®Ã v½­Úÿ¦¶…Á0± `Á~AcX€ EI endstream endobj 198 0 obj <> endobj 202 0 obj <>stream 0 0 0 0 152 82 d1 152 0 0 82 0 0 cm BI /IM true /W 152 /H 82 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ¤vŸjí_ú 8²{(ƒ8iÃ?ƒNp}§E‘ÄqGÄq_ÿþqbˆˆˆ“å`¿&¨©àì–᳃O†Ÿ~† 7 >á‡Ãáð`ømÿÿÿÿ΋ðÿÿàÿð†¾/ÿÿÚÿÿÚþõà Úö½¯ød)ûȨ2øö¿kÿkk -¬0¿ Û±¬,‚–ÃÈ-,@@ EI endstream endobj 203 0 obj <>stream 0 0 0 0 124 100 d1 124 0 0 100 0 0 cm BI /IM true /W 124 /H 100 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x)pþŸþ@ðÛ®@ðkI x<0 ä$ƒ9”¾þAWzÈií_ËØ”ƒH`äMŠrö5ÑØ@ÙÎôŒ#¿ x“ eòªrVœàAô¤` ’`xÔ‰àÇ’°<&¨…áþTÊXÃ|™Ì„KÈao!±W aK Ò[ÞCT£!¶%eI'/,« N_ Ê“!¶%ù RŒƒIn@žCa&C |B,äÖ0¸D,…áòTD€ðÊ$Àð. N@Àð!ÉXo•P+“0eÌ5äÕÔ gafü‰²|ƒIãËØ”†žÕÈ*ïY}üƒ9—>stream 0 0 0 104 121 202 d1 121 0 0 98 0 104 cm BI /IM true /W 121 /H 98 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¦`Ó =4âÓÿÿÿãÿþC ³ kÿÿÿÿþMRÚÚÚÁ‚Á‚Çÿÿÿÿÿü¼ÈmfxAééÿÅéÿÿÿÿÿˆÿÿÀðiÿÿÿòj“[Ma„_À@ EI endstream endobj 205 0 obj <>stream 0 0 0 0 143 144 d1 143 0 0 144 0 0 cm BI /IM true /W 143 /H 144 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x0jiÄÈÊ°AþAh—<>ÍpƒÁúxOžý4q<" ½á~²8ôA§ÉH6pˆ°+½08zúÞˆøAð0ôëz ô øAð^“ÿ ½&ø^‚~¼/¤ü+×K×_Aè/^¸Ký}x]}uõðº­~¿ð«Âþ¿ëÕôºÿô¿Œ-|-]/ë\%¯é} ´°ºÉªiéz]‚ú a¯×`—¥Ø\6 vál0—`—ava®%¼.1=´¸2 e¸d…Ä-­­…û -­‚Úý…ƒ°°ÊÐA…ødä4Ê2 €Yj  EI endstream endobj 206 0 obj <>stream 0 0 0 83 91 197 d1 91 0 0 114 0 83 cm BI /IM true /W 91 /H 114 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡˜]™çÁp\.—: °Aaph.¸--H2ŸH‚¡~ˆ6p¼$C\O Aù²ØÈf©`µä-a<ƒ5°AÙtø• ™5E(3þòJ|©ƒV/%@Ù²* ŸØ.Ê@SØ\2œ0ÁŠýëú úÂþ–½ik…ÐZ]i`–¸Akø" ,yA¼‚¸¾Ch·òªy²\†b^AFÇȹþA6DÚy=ƒ£±Ãè™~V€¾% ÞTƒJ<‚¼”†ÜŠ‚¼"’`QÖMQ s¨pÍðÝb `–@üfAh¾ p´ ‚þHöx2À@ EI endstream endobj 207 0 obj <> stream 38 0 0 0 0 0 d1 endstream endobj 208 0 obj <>stream 0 0 0 0 64 166 d1 64 0 0 166 0 0 cm BI /IM true /W 64 /H 166 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¬Ì Ý4ôÓÖð×ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿþÞûMm5 EI endstream endobj 209 0 obj <>stream 0 0 0 0 97 69 d1 97 0 0 69 0 0 cm BI /IM true /W 97 /H 69 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡¦U†¬†aN@º–àႧ„#Hâ8Ž.Š°ixD@*þS«@ƒ| ü}&ÿÒo§÷ÂPü?ü.;éÿÿÿû^MV¿áþ¿ ×m.×µØ0—û %°a. ‚ ÎRO BÚà kð`°ÂÁ‚Á‚ÈfþCLœ@ EI endstream endobj 210 0 obj <> endobj 214 0 obj <>stream 0 0 0 0 135 80 d1 135 0 0 80 0 0 cm BI /IM true /W 135 /H 80 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¦`x zqÿÿÿÿÿÿÌ¡‡Ãü*ªúÀðÓ ô¿^¿¯×ÿ¯ÿ×ÿ…ÿÿÿ_ɪ¾ÕbÖP EI endstream endobj 215 0 obj <>stream 0 0 0 123 139 221 d1 139 0 0 98 0 123 cm BI /IM true /W 139 /H 98 /BPC 1 /D[1 0] /F/CCF /DP<> ID & HJ[äÕrix@ò»¦‚„žŸá¢.Ž'…áé ¥- LÀaò`‰ 4"t€š°¼*÷ J ú ÃáP}o„¡õ[ÂTý Ÿª}%¾>¡oKÒ__ûéWëð·ÿ¤_ÿÿKÿþ?úÿÿ¯…ÃÿõÿþëÂí­ÿÔš­¯¶—ëÜ0¿i{ûÚ ¶ü5á†%‡”–½ëm #ÛþÛ Ã[µím5ÿ …†5°˜X†°`¿ ,à€YÃ:x€ EI endstream endobj 216 0 obj <>stream 0 0 0 0 135 99 d1 135 0 0 99 0 0 cm BI /IM true /W 135 /H 99 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ÔUàÿFÀðAè< ðAþ™~Ó@ý4á?ôúô‘¤q>½ù0á`£áÍ×ðA¾‚è?„Ãé?ï¤×÷ôß ÿð¾­úÿýÿúÿÿÇëÿÿÿÿýÿ_þ×ÿɪ××ÿ¿éî^ÿ¯×†_þ‡l.×ö×öÿáöýðíwíƒÃöÇß ~ÂØ[[P EI endstream endobj 217 0 obj <>stream 0 0 0 0 169 60 d1 169 0 0 60 0 0 cm BI /IM true /W 169 /H 60 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡°ì´ ’0à¾N¿à½zÿ¯øKýˆâ8Ž#ˆâ8Ž#ˆâ8Ž#ˆâ8Ž#ˆâÿÿÿÿÿ…Ñ u>Ž/…¤"?ÔW×ÿ ÿ‡üš¯ÿûÿûÿû\,3  EI endstream endobj 218 0 obj <> endobj 222 0 obj <>stream 0 0 0 264 141 369 d1 141 0 0 105 0 264 cm BI /IM true /W 141 /H 105 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±Øl„ÿ§ÿÿÿÿɪ_øa5Œú8¿ø? ÿÿÿÿò†o.iÿ§ûÿáþÿßÿÿÿÿÿýááõð—ù¥Ø_ŠêuPRj–Âý’ÉÃ(?ÿÿÿÿÿÿÿý®°Ô@ EI endstream endobj 223 0 obj <> stream 28 0 0 0 0 0 d1 endstream endobj 224 0 obj <>stream 0 0 0 0 136 129 d1 136 0 0 129 0 0 cm BI /IM true /W 136 /H 129 /BPC 1 /D[1 0] /F/CCF /DP<> ID >‚φ¡«V?µjÔ¿°­Z“T.GMqëm-††»u†ÒÞ¶ÐXmx~à m¥½m® 4»öÐ[a-ë ®Á¥ß¶–Aaý†Û®×a¥°ÒÃûh,7]…ÛK 4·ö[p»]†ÁµÞ¶ëm.<0·ÚÃXk÷ÚØ[Xk÷ÚëAiauë­-uáa.´µ×­Ö×^´¸Zá/ÒÒë\ÒÅÿòj–ÂÚ€€ EI endstream endobj 225 0 obj <> endobj 229 0 obj <> endobj 233 0 obj <>stream 0 0 0 0 47 20 d1 47 0 0 20 0 0 cm BI /IM true /W 47 /H 20 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¨Ö?È&’1( ’¢ E‚“Ÿ A‚jaš  EI endstream endobj 234 0 obj <>stream 0 0 0 178 121 280 d1 121 0 0 102 0 178 cm BI /IM true /W 121 /H 102 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±à<(=8¿ÿÿùÛ9ß‚–;‡ß}ü† Oòõì=ðÿûÌ×þMV½ëÿÃ׈ÿ¯ ó¦ý:‹_×Kô°ºéaxX%‚Q;5ƒûÿä0<ÿÿÿþMRký¦¶š€€ EI endstream endobj 235 0 obj <>stream 0 0 0 0 86 78 d1 86 0 0 78 0 0 cm BI /IM true /W 86 /H 78 /BPC 1 /D[1 0] /F/CCF /DP<> ID & \À5˜@ÁÓOM>_ÿííÛKýëµÿa„°Ú ýëµÿm/÷­ŠÿÚü0¶²÷®žžŸÿÿkkkò *ðƒÿÓý=Óÿ§ÖÿÂL?ú}ÖÿÒoþŸ[éÿÿ§ÿ„i¯öšÃ0  EI endstream endobj 236 0 obj <>stream 0 0 0 0 47 90 d1 47 0 0 90 0 0 cm BI /IM true /W 47 /H 90 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¦x 8 `é§üZÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿäÕ&¿ÿi¬ `  EI endstream endobj 237 0 obj <>stream 0 0 0 0 131 94 d1 131 0 0 94 0 0 cm BI /IM true /W 131 /H 94 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x§úÿÿþ ಂ IÁ±$@ðkðYÃ(ª@ðn ‚äY`ˆ©ä[‚òå<ƒ1_‘p# '™¬ä ž² …ȸ6a`ˆ¨Hj‹ar % \‰ç \£‚á¼<"´ ðDiƒÑ0°d53@ˆ0(x"L`Ê|ƒŸÂ 4è" ¢]aô2, Ñ1OAøHX—„}dYt@öÃèáJ†<—~È5ƒÈ «v@ðØ3ÓTÈAþþ¿Ã÷íwàÁƒ\ZÚà  EI endstream endobj 238 0 obj <>stream 0 0 0 144 138 164 d1 138 0 0 20 0 144 cm BI /IM true /W 138 /H 20 /BPC 1 /D[1 0] /F/CCF /DP<> ID &± ëûÿÿÿÿÿɪ_î`ˆÄà EI endstream endobj 239 0 obj <> endobj 243 0 obj <>stream 0 0 0 0 135 160 d1 135 0 0 160 0 0 cm BI /IM true /W 135 /H 160 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x3( z ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ¬à¤^@ðU' xkùÁ¬^@ðÌ,<©H ¬H/È{y}ÎAczHld‚¶ÕùÍHjlRA£eRö FÅ Ó; ›ä{æØ—ì 2¹Ú€jçiÃZ'a†Üî`Ëçnò– R°ò¤‹%€x?’€<‘ < Ê@<$Õxjlèƒoö||ÿÿÿÿÿÿÿÿÿÿÿÿÿÿû ö  EI endstream endobj 244 0 obj <>stream 0 0 0 162 138 262 d1 138 0 0 100 0 162 cm BI /IM true /W 138 /H 100 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x! H`ò ãY‚Œ 'ä‰2 ‰y MhÜò÷§äÙ|‚lžG±¼Û ¥_ø;4bRƒ/ܬ^T·%€¯’€$È,þRá¾MQ—g@A6Ÿ#Ú~v@Í´aøøŽŠRÀðr°†r¤‚XƒNJðÓ"@x6”€x+“TDàog@<~φ@n  EI endstream endobj 245 0 obj <>stream 0 0 0 183 138 324 d1 138 0 0 141 0 183 cm BI /IM true /W 138 /H 141 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¹àÈèèX”àx•x) <r&ƒa(ÃL–àÒBÀðÊ$€xlÊØ šáð3º蚣°À³áÔöv ³µ`«vLd>ÉäØ<ƒ}—Èeì¿;H$¶“!©´ŸÎÆË!àþüuùÙþAFßË3ÿ ÔµÈk*r`¼ƒ!W p)þ@¬=(ä~ð¾¾ z_ø@½/ð‚ôÂðKÐ/ á//¯@¼õð‚ôÂðKÐ/ á//¯@¼õð‚ôÂðKÐ/ á//¯@¼õâ …×_ÁuÂáa®Ð.°Aiapa.‚Á®Ð.°Aiapip´‚ø¨*…\B…&¸_ EI endstream endobj 246 0 obj <>stream 0 0 0 0 143 127 d1 143 0 0 127 0 0 cm BI /IM true /W 143 /H 127 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x‰òF˜O ßþA²«Èj„ ¾oþ6ôßOÓ½0ÿáú~·§é¿*ï„Bú ÿúL0Ýþú~•ÿá ïÛõôÿë~¾¯ëÿëë_þð¿Ãøpµë¯ÿ÷þÿ×ÿúŠýþ×ÿ¯ývëÂÿÿÂíwK‡úúX~î» ë¶‚“U°¾õða.Ø`¿×µõà -Úÿ붽¬; °×þ]°[ƒ à ²‹?öÿíÿ}íþ‡ûþÂál/æ`x,ØP EI endstream endobj 247 0 obj <>stream 0 0 0 0 105 154 d1 105 0 0 154 0 0 cm BI /IM true /W 105 /H 154 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xi¬……‚øX-a`—á, E‚øQÒá`‚‚ᄠ¬Z…Á„‚ apaÁa‚ ‚„Z‚ „  -t Ap´ 8R0êF€ð„°ŠÀ)¸k†™Ø@ ìLgbñ5Ãü>EØ” ä3vDƒfÇ$$=È*¬á F¬. ap@°‚áa‚ ‚  ,., ¸XA`k„ ,X\ °ApZ  „. , X\ ´ÂÐ(ùìªÁ3 ³ºQØ€Øv4;‰®ûîðyö®C/zy mă"ÔX,æ+ x.£ò†Pp EI endstream endobj 248 0 obj <>stream 0 0 0 0 139 45 d1 139 0 0 45 0 0 cm BI /IM true /W 139 /H 45 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡ËœàÌŒà³VŸõþ@ðÌŸùÁ½\à¸>@ð¦9ÌOg)ýd|"£Ye¯ ØhÁd57œ ¡È4oòöF@§È&Óä{OÎȉ¶Œ#¿ï±Àñ X+xh*@xeÀ<²P†¡Ãh¤Áš¢ ‹:àWö|2€ EI endstream endobj 249 0 obj <>stream 0 0 0 0 139 113 d1 139 0 0 113 0 0 cm BI /IM true /W 139 /H 113 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡‘›9ÁiÀœf@ðe'äA©ÃXZ@ðj,<2”¤ „¾@ðÂ\âl|ç¼È3휫ø,‚žÃ‚¶ÈÈ6m>COi2 ;ü#¾Û†‡‚ÃÑØášôLÃIò¶ œZW ½oAÑ(@˜|‰’ðˆP½`¸OªÞK†uÑNªé%é¯I/ ½} ’ôºþ—Ö¾h%ÿÿ …KëAÿøT£ú×ÿ¯^Â^¿ú_ðÐ^—…ípé}v°—k°Â ìúÛ pÂ\2 ¤ÕX2 ‰|WµØa{ ÿ¯aaÚá°^ /û`¼0·EAW†U ßä¶?ÿûð¶|  EI endstream endobj 250 0 obj <>stream 0 0 0 0 47 68 d1 47 0 0 68 0 0 cm BI /IM true /W 47 /H 68 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡¶ *²(!M$b&P? Jˆ) “œ) ª5†lÿÿÿÿÿÿ!¶ÿ•Y È&’1(…%DŠÉ€ÎƒÕÃ4@ EI endstream endobj 251 0 obj <>stream 0 0 0 190 47 258 d1 47 0 0 68 0 190 cm BI /IM true /W 47 /H 68 /BPC 1 /D[1 0] /F/CCF /DP<> ID & c!°Ÿ…ÀÜE(…󂕈èmGþh?Rk— ¸ÿÿÿÿÿÿþC6¼€r øY ÁdRˆ_8 ùQH΀žhšåÃl@ EI endstream endobj 252 0 obj <> stream 91 0 0 0 0 0 d1 endstream endobj 253 0 obj <>stream 0 0 0 0 167 164 d1 167 0 0 164 0 0 cm BI /IM true /W 167 /H 164 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x.F€¢@ðå‚‚‚„ÿAáÊ´â ´ÚÑGÄá…ûµû´Fù Í¢¡ÚAPÄ0·hnÐA¾=Á=¤pÖäÕ0}¸&þƒàÚMíÐ~ÞÚL=¸O‡§Ø«Ýþöƒí7‡öí?ÞþÓöÃíü;Û|7ÿÛá;áýý¿úwßÃû~tOðÿ·û~°ïAþáûýþÿþï÷ûýÿü?à í|ÿ…ßzÿÿÿíÿzÿµÿü=p×ÿû]ëþÂÿ¶‚ÿzíxkþÚ]…Ã×®Ýv¼5ÛAo]…ÛK°¼Xl.õ¶\ðÁvK`ÂXzØ2£["A˜%¿b¶°ÖÖÂý…ƒ[X`¶àÖ,,,/È déà EI endstream endobj 254 0 obj <> endobj 258 0 obj <>stream 0 0 0 108 141 282 d1 141 0 0 174 0 108 cm BI /IM true /W 141 /H 174 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x’ m‰?Ó‹ÿÿÿÿäÕ/ÿðÂkôqp~"?ÿÿÿÿä ß \< Óÿý;ÿßÿðÿþÿÿÿÿÿÿëÿ Âÿÿ¥ásKð—õPª«‚“T¶ÎÉdÿÿÿ xýëýïùÃ7Ãáÿ§ýÿÿÿÿÿÿÿÿýáx_ÿúõõô¿Í,ÂüW «ª…&¨-…û;Uò†Pÿÿÿÿÿÿÿû]a¨€ EI endstream endobj 259 0 obj <>stream 0 0 0 0 17 136 d1 17 0 0 136 0 0 cm BI /IM true /W 17 /H 136 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¬ÑÂþ!ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ“\/à  EI endstream endobj 260 0 obj <> endobj 264 0 obj <> endobj 268 0 obj <> endobj 272 0 obj <>stream 0 0 0 0 121 93 d1 121 0 0 93 0 0 cm BI /IM true /W 121 /H 93 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡–HÀ‰åðDÀ2ˆÐd3D„@ôÁ„Ðz =4ýBziòMMp¾ž ß ÀƒÒD¸Ÿûéˆ }Ðo¦ úhÃ_÷O°ž¿§Þþ|?õÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿâ?ÿä0<ÿÿüš¤×øað EI endstream endobj 273 0 obj <>stream 0 0 0 182 121 280 d1 121 0 0 98 0 182 cm BI /IM true /W 121 /H 98 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x+žtžŸÿÿÿ‚ÂÁ|,àÐ’ á`°°²ððƒ¦‹¨°¼\"P>ÍazÁø_Á…‚#ÁD(\ì0T wà¤wp wà¤v€VÃÖ ÃÃPƒCGáƒ>ƒœ0ø~ ‹Òjaþ;@ðˆ<> endobj 278 0 obj <>stream 0 0 0 174 135 316 d1 135 0 0 142 0 174 cm BI /IM true /W 135 /H 142 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xdR~@ðÖ<3Jà°¿æ°¸g+ø½ü?÷ÿßÿÿÿÿÿÿÿÿÿÿÿ¬,ȃ%aÁµ@²†˜àÒ% xe ùÃadà¸\áI$ÔùŸZÜHnr {A_uÈmlv‹!«´r [G!—º°ÈlÞ¼‚û«ÎÐy ´r[F<š£±µÎênv€Sç|ìpZÿ)`ÊÈ\ªáyÁ~J€ðÙþE@ðÊälŽRá§È0<9¬_ò@ \/^—ÿøA£‹ÿ×ýzð¿ëׯá…,MP@‚Ä ä`h<3aá— Árif­ @ EI endstream endobj 279 0 obj <>stream 0 0 0 0 113 66 d1 113 0 0 66 0 0 cm BI /IM true /W 113 /H 66 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¹à<h8¿ÿÿÿÿÿ…nÿU ®P†u¥ý~¿Âÿ×úÿÿÿÿù5J¿Ã ñj  EI endstream endobj 280 0 obj <>stream 0 0 0 0 113 84 d1 113 0 0 84 0 0 cm BI /IM true /W 113 /H 84 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¨Ð °/ø°ƒÂ‚OAþžÂ}è«Gÿ@…‡„K_@ƒz@ßý>‚o è'è0ú}/Iõ¾„¾Ÿ_§Öét¯ðzô½ º\/Kþº]Ô.« õézIkð—KøQKIaia%ô –ˆ„ ‚êJ‚_PT“Uk„ÂÁ¦ üX(€ EI endstream endobj 281 0 obj <>stream 0 0 0 167 171 294 d1 171 0 0 127 0 167 cm BI /IM true /W 171 /H 127 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±ÀÖ8ƒ(Zh0œCM?ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿû_Þ¿ÿþÑõÿÃõÿÿÚÿû -ÿí¨ÿÚï_í¥ÿk°Â]®õþÚ]®Al0—ûim¥Ã °ÂXm6¯^à { |0¾Ã x`Ááá{*Âö@ÇàÁxaI¯„ ôXˆa~@ð.Q<3@²†p EI endstream endobj 282 0 obj <>stream 0 0 0 148 123 263 d1 123 0 0 115 0 148 cm BI /IM true /W 123 /H 115 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±Ø€Ô„vD88pù5Aá˜GÄqGÄqGÄqGÿÿÿþñðoƒ ÷¾Þo~íïøoûß÷ï÷áþÿýþÿÿ¿ÿÿÿÿÿ×ëÿÿð½ëü/×ô¿ô¿ ×ékú ^°–ºá,áa,á°F}”iEB… ‚“TΈ € EI endstream endobj 283 0 obj <>stream 0 0 0 0 168 86 d1 168 0 0 86 0 0 cm BI /IM true /W 168 /H 86 /BPC 1 /D[1 0] /F/CCF /DP<> ID & z" } NµeÞdw§äv!«³Gba§<?ÂOÈš!hâ8Ž#ˆ }ìyEXÊ—ÀÀÿE8 z …Z@ðÕèá¤%©Á [ DT x)ëá< RƒÐúEA>@ð¢ŸPOä—¨ Wä žˆ- ?‚"¯ø/ȉ~A”Kð_Èm ~ŠÏäh¾CHKì†h’ø/¹âÕÙWäl |‚ {dQ$f ĉà£ÉP\2(ƒBÂ"@x5ð@’É àˆ¨k‰á­ê¢ RRŒ‚à™ˆ°)Ôb¤Õk à. kö°ÂÁ‚à ìÀküƒnÁäw¦A—y'ZÈ…¾  EI endstream endobj 284 0 obj <>stream 0 0 0 149 123 264 d1 123 0 0 115 0 149 cm BI /IM true /W 123 /H 115 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡¨ Ó´˜N á-ˆâ8Ž#ˆâ8Ž#ˆâ8Ž#ˆ-ÿÿýàxl¢œX@´½ip´ºÂþ—_ ¿^¿­¬/õÿ¯ð¿ÿãëÿÿÿûäÕÿÿ‡¿ÿ‡þÿoÿoø{þ߆ûßa÷ÞÃØ<>ÃÙ†Ì죷·àðÖCSeà EI endstream endobj 285 0 obj <>stream 0 0 0 0 186 105 d1 186 0 0 105 0 0 cm BI /IM true /W 186 /H 105 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡ ‹ðN°°X]`‚ \XAp°‚ÁÂè,.°‚ÁÂè,\ Â ¸, Â„ Âà‚ÂÂÁÐX\ ,à°‚Á×,à°‚Â Ð, ºÁ Â ¸X °‚Âà‚Ð.,Âà‚ÂÂÐX °¸A`‚à°‚Ð, h. !BàªMp¶  EI endstream endobj 286 0 obj <> endobj 290 0 obj <>stream 0 0 0 112 124 195 d1 124 0 0 83 0 112 cm BI /IM true /W 124 /H 83 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±à<áà¤Tg ¬7üXAàá9¢ üÿÐ~Ÿ§Ð'ͪ hâüý B ú)€ü/è“ÐA¿„þ‚ú[ð~“Oé~“úÃø_„ƒý~“úW×è/×ëá'ëõú_A~¿_ }~¿I|/¥ú¯ ¾—éüB.—פº^«„A›ÂøA„½ ½%×Ô._ýu]WL.«þ MVƒ½0·ÉÃ,@ EI endstream endobj 291 0 obj <>stream 0 0 0 244 65 277 d1 65 0 0 33 0 244 cm BI /IM true /W 65 /H 33 /BPC 1 /D[1 0] /F/CCF /DP<> ID & n Aþ½È³X ÖŸúa-¾ºh/¿ôkKÂס?$`x®¶ºý­‚Úà `¿ ,Pf k EI endstream endobj 292 0 obj <> stream 116 0 0 0 0 0 d1 endstream endobj 293 0 obj <>stream 0 0 0 0 55 33 d1 55 0 0 33 0 0 cm BI /IM true /W 55 /H 33 /BPC 1 /D[1 0] /F/CCF /DP<> ID &  — !'á=Á==O  ë\—ø.‚á}t¼/L/‘Ö?¡­ªfÞ¤Õ!‚ÿÇa`Ô@ EI endstream endobj 294 0 obj <> endobj 298 0 obj <>stream 0 0 0 91 121 191 d1 121 0 0 100 0 91 cm BI /IM true /W 121 /H 100 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¦`Ó =4âÓÿÿÇÿä0<30YÃ@LáƒÂà—Rj‘ئÑз‚àÁZ)Ä.EC<ƒ0¶Ad[È)”à‰@idP5 ˆ˜mB¯ `Ë*c"kÁò 2üÈ*àðȸkA’€Òƒä ÅpdX2²T äŠrå8>^<7 œ8²ÂùÅÁò† d ;< ÿÀðiÿÿäÕ&¶šÿ €€ EI endstream endobj 299 0 obj <>stream 0 0 0 100 121 186 d1 121 0 0 86 0 100 cm BI /IM true /W 121 /H 86 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±ÀÄ d ?8°]? X/K tGÅ_ÁB"Ö XZ K…ÁÐ\/ pzè. uáéx\]Âð—®‚à—^.—…ÁÐ\/ pzè. uáéx\]Âð—¬B× p`U…„«ák¬/„Ô*“Tƒ\á… EI endstream endobj 300 0 obj <> endobj 304 0 obj <> endobj 308 0 obj <>stream 0 0 0 0 135 146 d1 135 0 0 146 0 0 cm BI /IM true /W 135 /H 146 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x<H E†P'…ÿÃ>‰ ã!àþßßÿÿ÷ÿÿÿò‚Žäÿ x=\âädùp>AdoÊ@ÚÈä@ùANáëþH0¿ðÎxµßÿÿ®ÿÿÿÿÿÿÿ×…ÿäFr Š9 0)ã Ò%þƒÈe !°³\/¤œküæxü‚žÃWÝ~Ck`ä5v‚:H5n®C/ur 7«çhäu ‚ûGÈ]£ä·W‰ÚW— ®MQÝ@­ó´ŸÎø ?üìpZùKÿ•A@ð/ù*Ã7" xidl l¤Ão ÀðdüÖ¾HÁg …ð¿ÿÿù5A|@ EI endstream endobj 309 0 obj <>stream 0 0 0 164 91 267 d1 91 0 0 103 0 164 cm BI /IM true /W 91 /H 103 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xÉÂB„ôõÈfeÿ.tð¾ _ |)¯è«Â î§èO§.ð‚ëÒôºéW Õ}p”/ú xJ5Ö.°‚Èë8RUIöC\O!¤Sd3¤Õ2 x2[ÿƒ%³\1}þÃÙÜ/)@ý’PÙÿd,2Ü2T {"­†L¦ —L¢ ð`³È`Í„ ¥Õp]*áz ~z Õ}E.–ºX/ ",%¦ vÔ“U࿸Ð_áà¾Óãµû[   EI endstream endobj 310 0 obj <>stream 0 0 0 107 62 132 d1 62 0 0 25 0 107 cm BI /IM true /W 62 /H 25 /BPC 1 /D[1 0] /F/CCF /DP<> ID & Ôj0“DÊ@‚Œ'‚ Ð}ŒÑ¨;Âêœ \ ¼.t¸_ ´Õrjkü4ÂŬ0  EI endstream endobj 311 0 obj <>stream 0 0 0 201 23 224 d1 23 0 0 23 0 201 cm BI /IM true /W 23 /H 23 /BPC 1 /D[1 0] /F/CCF /DP<> ID &£3žƒý?‹ÿ&©~×ì-¬(€ EI endstream endobj 312 0 obj <> stream 39 0 0 0 0 0 d1 endstream endobj 313 0 obj <>stream 0 0 0 0 117 78 d1 117 0 0 78 0 0 cm BI /IM true /W 117 /H 78 /BPC 1 /D[1 0] /F/CCF /DP<> ID &  ØeA“ù(ƒÂ§úÞ«…¾Ôº$OÁ§ÖCüú ‚g’ôž¾„V?ª ýkdîÈš¥k“]×ivm}-ëa ·Kü6Ã:ôˆÆ õáÐDémH+‡Ô†Ò{„ˆkºD4Œzî‘‘-Â!š-Ôr¼Q ¸rTëè‡Yò*_›cì|š•°¼Yù¥ŠÈe¥ùæ^Aƒ/•Óä:Ï‘V<´¯EdÂÑU|…ï%`x‚E€ð|ŠàAÁAV†aƒY5È`xk}™á´  EI endstream endobj 314 0 obj <> endobj 318 0 obj <>stream 0 0 0 0 155 15 d1 155 0 0 15 0 0 cm BI /IM true /W 155 /H 15 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¦eYÁÓø¿Éª_µð EI endstream endobj 319 0 obj <>stream 0 0 0 0 113 31 d1 113 0 0 31 0 0 cm BI /IM true /W 113 /H 31 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡–tÅP ‚œòÌ0@ðM=4ÿÂúiá}¯úù/úü _…úÃZL/…#«QÿC]4ÖÌ$Õ=&© aøŽÂÁ¨€ EI endstream endobj 320 0 obj <>stream 0 0 0 0 127 86 d1 127 0 0 86 0 0 cm BI /IM true /W 127 /H 86 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ÖkÁ$3`ƒÂøA×> „@ÂM§ü&žè?EZ8ëÎ'øá±ßõ¸z ‡ôý8}Øf{Ó‹Öýô﯅oÂÿñ_ý~¯ÿ¯^¿ü/ÂþõôµïY5]/¯†¡,>½ëÚIv«¿ º l0¡.¯h ]•a–‚[õÈT˜d1¹)b[[[[ /Ã[ƒ a‚ü,,†šžA°§ ÈOà EI endstream endobj 321 0 obj <>stream 0 0 0 212 85 301 d1 85 0 0 89 0 212 cm BI /IM true /W 85 /H 89 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±VŸ„X_Ó­k úZÅ_¨G…­k_ ZÑ´½p‚é¥ÒõÐ\%×¥××K„^—K×K„^—¯].‚áz]/]z\/At½bµð´A¨"ÐUÂ…­k_áh5UA¯“T‡…†@ EI endstream endobj 322 0 obj <>stream 0 0 0 0 128 88 d1 128 0 0 88 0 0 cm BI /IM true /W 128 /H 88 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x)?ÓÂþºë® úë®_Âë…Âëø"­t…ô‚_^ð@¼/„¼ø^^@°KÂùo¾ È+y ¢Ÿ!¨ ä<†Å¿‚ò{Ï/ ð\Ap\+ OùU¼&¨–÷‘p<^ÃðÍ`xãÿÿÿþ@ðm‚úÿÿö¿ðdæ  EI endstream endobj 323 0 obj <>stream 0 0 0 0 127 86 d1 127 0 0 86 0 0 cm BI /IM true /W 127 /H 86 /BPC 1 /D[1 0] /F/CCF /DP<> ID & nUƒ,‚±VAµS!ª—øAáÁ„᧠ðOE->E×Ñ1:©oDLÌa~‰€ñ!¡&‚Ð@ü„4¤´á×¼%@ü·Õ>•}+_áAáô–¾½úû®?øKø_ÿ^5ÿÿ§úÿøiÿý…»AoÿÚRj¬5ìóµâ„¸m¯õ†ÃÛK¸`¿&…»µ¸kv¿ö¶˜X;[Ma„_à ,C ,à•ü@ EI endstream endobj 324 0 obj <>stream 0 0 0 0 127 88 d1 127 0 0 88 0 0 cm BI /IM true /W 127 /H 88 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ÔN†É ²ø ðƒ!ªŒdF¦xMÓO ‚A ÿÓ½4ùVŽ*zöÂoàˆ.Ÿàƒ ô‡#¯ ›šß ÐAúz¤ð›ûIõûè=?LÓáá‡õÿûýBøûNÿ×ÿÿÿÿÿýíWäÕzÿîúÿ Báíòuû_Û ikÚL5Û[ ~þÃJK†¬ŒØ,{UÁ‘°°õìPkÚÿi­ªØL,4 -¦¿ÃLÐa`Â!ªŒ0‡äH€€ EI endstream endobj 325 0 obj <> endobj 329 0 obj <>stream 0 0 0 0 132 101 d1 132 0 0 101 0 0 cm BI /IM true /W 132 /H 101 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¦l¸@ðœ_ÿÿÿÌX|?ð¾èĘg$ÄÈ0Ëè" c8&ôƒð›áÒ~›×öú~¹5ICá¨_ðàÁã¿õÿÿÿÿ×ûÿáx\0ÿ^ÿK¿´½vÂðioö–Ø^ / °Ê@ηö@‚®+ö¶Ã[_°X5† _<*¼áŠà EI endstream endobj 330 0 obj <> endobj 334 0 obj <>stream 0 0 0 104 87 202 d1 87 0 0 98 0 104 cm BI /IM true /W 87 /H 98 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xp´ÿ@<ÿ yWäÔH,È) HmHiªù Ä©ûCœ‹½eìfw~‰˜š+ÄySòX 2(òL%8AädH|šäT5 ×% ×®A3ìíƒÂÈ¥‚80ò ‹wØ%Ê1hQÔO‡È4(ÈeÈlü‚âÙU‘A2´ˆeÿè•P|Š†®4È6ÁeX2Êp(¼¬Š†´–O•0/&¹X94gyìr.õÆç ßcù Ä© 5Y  I!i€? ΢@ò®@ðÿÿµû_ EI endstream endobj 335 0 obj <> stream 44 0 0 0 0 0 d1 endstream endobj 336 0 obj <>stream 0 0 0 102 121 195 d1 121 0 0 93 0 102 cm BI /IM true /W 121 /H 93 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¨ _ä ?‹?Óÿðððþ + ƒPÂö† ÂÓ ~ 5&¨úAƒ_à ðØX< Á¢_ÄC× 4X0Â_ /°ÐMa†àð°Á„¶Â †¸0iaˆX5°°×àÂÃ[ ¸X\% ºÐY¼$C_ðƒPƒð‚âÒO „º …ép‚õÒÄü†ƒOÿÿüš¤×øa@ EI endstream endobj 337 0 obj <> endobj 341 0 obj <>stream 0 0 0 115 141 205 d1 141 0 0 90 0 115 cm BI /IM true /W 141 /H 90 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x6”ˆ"œ6AÂOÿA÷§§„ÿôB õøDeô?I¾Ÿ é^¯×«è/ z^¡úô½|Ò‡'×¹ƒ¸A. ðK ׯ_ð^¼/^ þ”€µ&©AwÂ_ÇÂÿü/ÿZÿë×þ—ëýa]ýoµùÁf™Ášà EI endstream endobj 342 0 obj <> endobj 346 0 obj <> endobj 350 0 obj <> endobj 354 0 obj <>stream 0 0 0 196 141 300 d1 141 0 0 104 0 196 cm BI /IM true /W 141 /H 104 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¨Êoü_ÿüš¥Ï£ˆâ8Ž#ˆâ8Ž#ˆâ8Ž#ˆâ8Ž#ˆâ8Ž.ÿÿÿÿÿˆˆˆˆˆˆˆˆˆˆˆÿÿÿÿÿþ@ðÍòÃÂýtïßÿü?Ãÿûÿÿÿÿÿÿ¯ü/ü/þ¾ÿ4» ñ]B®ª MRØ_³²@Ù xeÿÿÿÿÿÿÿÿµÖ€€ EI endstream endobj 355 0 obj <>stream 0 0 0 0 95 139 d1 95 0 0 139 0 0 cm BI /IM true /W 95 /H 139 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ÔfFŽC*² iò Á‚pR ÁBÒ rAH4 Qp@‚)Ã]\*ê´¤—øA%ªõ]BÔ/ýV«ÿUþ«ÿ ¿ÿÿÿÿÿÿÿ‡îÿÿÝÿ»ÿÝî¸í·þøwÝîûmÿ¸~á÷{¾mÿ¶ÞÛ÷l7»á߇}Þï¶ßû‡îw»á†ßû¿wþÛîþáÿ»ÿÿwÿÿÿÿÿÿÿáWú­Wþ¡¨_ô’ÿI.aWUÂ@—Pµ\$–!BYiIÔ,$ h þ Aƒ{5ƒX,3@Ú4 EI endstream endobj 356 0 obj <> endobj 360 0 obj <> endobj 364 0 obj <> endobj 368 0 obj <> endobj 372 0 obj <>stream 0 0 0 0 192 39 d1 192 0 0 39 0 0 cm BI /IM true /W 192 /H 39 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¬ðd¡ç@ÿþ!§ÿÿÿÿÿÿÿþMRÿÁ‚€€ EI endstream endobj 373 0 obj <>stream 0 0 0 0 192 38 d1 192 0 0 38 0 0 cm BI /IM true /W 192 /H 38 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¬ÉeÁø¿ù GÄqGÄqGÄqGÄqGÄqGÄqGňˆˆˆˆˆˆˆˆˆˆˆˆˆ?ÿÿÿÿÿÿùuù5IëÿÁ@@ EI endstream endobj 374 0 obj <> endobj 378 0 obj <>stream 0 0 0 0 74 84 d1 74 0 0 84 0 0 cm BI /IM true /W 74 /H 84 /BPC 1 /D[1 0] /F/CCF /DP<> ID & °f$=<‚‹Aà·þ ¸[×ÂøAN»Ê  ^‚Ç š<¼ žºB>_]W ¤ÿ¤½c]*X%VÓ Ú3!¦¢Á?È“]ÎUÁ¡\CïÛþTÂvKA‡d\ á‘ ÍÃ*ÃKú%Ã_F°Tä€eÂÐ.«Az®¤ªõz¯Aid^Á]B_V˜JM~.2 *ø_[Áu x_ì!ÚÃP EI endstream endobj 379 0 obj <>stream 0 0 0 0 106 81 d1 106 0 0 81 0 0 cm BI /IM true /W 106 /H 81 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x4üàc\á ¾@ðÁ<ᲧäE9ÂÜ:–AH“ ¬±ÂÈ6’ä52 )x"¶ ŠÈÊ 4B!a§Bƒ^º% ©•.E@âZ®— Úå8«@’‚×á.•pU¥ô_ªÂ_ ë ¥N² Úë„ÿ Ø«!¦ÿÖŽÈf vAAV2…ì¥>ICÿ`¹_`°Á6EÀƃ %§äÕ5d3¨d5!³JÛÅ.0¾[D´ØU´-¢ 5ƒ< Ác ‚à  EI endstream endobj 380 0 obj <>stream 0 0 0 0 74 74 d1 74 0 0 74 0 0 cm BI /IM true /W 74 /H 74 /BPC 1 /D[1 0] /F/CCF /DP<> ID & yý`² -`«KáaAª ¸A% ‚\/I„—×IuÑz¯ÒôPÿõJý}W[ÒoXzW×Âô¯ zÛW&½/×x_Ká{¥ØkÞ¸t«x_ªøJ·K߯Kô^«á— u]V”ú ºf–×Aiu¡u Mu EI endstream endobj 381 0 obj <> endobj 385 0 obj <> endobj 389 0 obj <> endobj 393 0 obj <> endobj 9 0 obj <>/FontBBox[0 -264 192 218]/FontMatrix[1 0 0 1 0 0]/FirstChar 0/LastChar 229/Widths[ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 60 0 0 0 0 0 0 0 0 0 0 37 0 0 0 0 47 0 0 0 0 94 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 48 0 0 0 0 0 0 0 0 45 0 0 0 0 32 0 0 0 0 0 0 0 0 0 0 0 0 0 0 52 0 0 0 0 0 0 59 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 38 0 0 0 0 0 0 0 28 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 91 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 116 0 0 0 0 0 0 0 39 0 0 0 0 0 0 0 0 0 0 44 0 0 0 0 0 0 0 0 0] >> endobj 8 0 obj <> endobj 2 0 obj <>endobj xref 0 394 0000000000 65535 f 0000043040 00000 n 0000116838 00000 n 0000042681 00000 n 0000043088 00000 n 0000036655 00000 n 0000000015 00000 n 0000000486 00000 n 0000115732 00000 n 0000112281 00000 n 0000043157 00000 n 0000043404 00000 n 0000043685 00000 n 0000044024 00000 n 0000044397 00000 n 0000044748 00000 n 0000044964 00000 n 0000045382 00000 n 0000045729 00000 n 0000046089 00000 n 0000046302 00000 n 0000046638 00000 n 0000046987 00000 n 0000047269 00000 n 0000047470 00000 n 0000047776 00000 n 0000048082 00000 n 0000048342 00000 n 0000048621 00000 n 0000048908 00000 n 0000049234 00000 n 0000049417 00000 n 0000049741 00000 n 0000050031 00000 n 0000050506 00000 n 0000050741 00000 n 0000051052 00000 n 0000051310 00000 n 0000051884 00000 n 0000052091 00000 n 0000052121 00000 n 0000052150 00000 n 0000036825 00000 n 0000000505 00000 n 0000001002 00000 n 0000052563 00000 n 0000052859 00000 n 0000053104 00000 n 0000053407 00000 n 0000053750 00000 n 0000054154 00000 n 0000054509 00000 n 0000054688 00000 n 0000055028 00000 n 0000055389 00000 n 0000055667 00000 n 0000036979 00000 n 0000001022 00000 n 0000001895 00000 n 0000055696 00000 n 0000056079 00000 n 0000056448 00000 n 0000056636 00000 n 0000057036 00000 n 0000057292 00000 n 0000057555 00000 n 0000057897 00000 n 0000058188 00000 n 0000037133 00000 n 0000001915 00000 n 0000002461 00000 n 0000058217 00000 n 0000058401 00000 n 0000058733 00000 n 0000058988 00000 n 0000037287 00000 n 0000002481 00000 n 0000003235 00000 n 0000059017 00000 n 0000059296 00000 n 0000059642 00000 n 0000059991 00000 n 0000060190 00000 n 0000060254 00000 n 0000060461 00000 n 0000060727 00000 n 0000037441 00000 n 0000003255 00000 n 0000004312 00000 n 0000060756 00000 n 0000061061 00000 n 0000061372 00000 n 0000061717 00000 n 0000061937 00000 n 0000062329 00000 n 0000062645 00000 n 0000062975 00000 n 0000063256 00000 n 0000063320 00000 n 0000063725 00000 n 0000064042 00000 n 0000064346 00000 n 0000064674 00000 n 0000064739 00000 n 0000065042 00000 n 0000037596 00000 n 0000004332 00000 n 0000004931 00000 n 0000065072 00000 n 0000065827 00000 n 0000066082 00000 n 0000037753 00000 n 0000004952 00000 n 0000005745 00000 n 0000066112 00000 n 0000066322 00000 n 0000066387 00000 n 0000066667 00000 n 0000066971 00000 n 0000067281 00000 n 0000067540 00000 n 0000067806 00000 n 0000068098 00000 n 0000068492 00000 n 0000068842 00000 n 0000069354 00000 n 0000069686 00000 n 0000070030 00000 n 0000070375 00000 n 0000070684 00000 n 0000071030 00000 n 0000071439 00000 n 0000071757 00000 n 0000072079 00000 n 0000072493 00000 n 0000072685 00000 n 0000072750 00000 n 0000073104 00000 n 0000073426 00000 n 0000073812 00000 n 0000074130 00000 n 0000074318 00000 n 0000074608 00000 n 0000074911 00000 n 0000075133 00000 n 0000075198 00000 n 0000075450 00000 n 0000075648 00000 n 0000075882 00000 n 0000076118 00000 n 0000076183 00000 n 0000076525 00000 n 0000076817 00000 n 0000077115 00000 n 0000077416 00000 n 0000077699 00000 n 0000077998 00000 n 0000078425 00000 n 0000078820 00000 n 0000079059 00000 n 0000079321 00000 n 0000079619 00000 n 0000079927 00000 n 0000080181 00000 n 0000080377 00000 n 0000080442 00000 n 0000080732 00000 n 0000080949 00000 n 0000081333 00000 n 0000081649 00000 n 0000081679 00000 n 0000037910 00000 n 0000005766 00000 n 0000006570 00000 n 0000081962 00000 n 0000082189 00000 n 0000082254 00000 n 0000082492 00000 n 0000082780 00000 n 0000083044 00000 n 0000083369 00000 n 0000083626 00000 n 0000083917 00000 n 0000084230 00000 n 0000084466 00000 n 0000084807 00000 n 0000085080 00000 n 0000085416 00000 n 0000085742 00000 n 0000085969 00000 n 0000086303 00000 n 0000086603 00000 n 0000086935 00000 n 0000087377 00000 n 0000087782 00000 n 0000088071 00000 n 0000088415 00000 n 0000088631 00000 n 0000088936 00000 n 0000038067 00000 n 0000006591 00000 n 0000007441 00000 n 0000088966 00000 n 0000089299 00000 n 0000089758 00000 n 0000090019 00000 n 0000090439 00000 n 0000090849 00000 n 0000090914 00000 n 0000091201 00000 n 0000091487 00000 n 0000038224 00000 n 0000007462 00000 n 0000010058 00000 n 0000091517 00000 n 0000091741 00000 n 0000092118 00000 n 0000092430 00000 n 0000092694 00000 n 0000038381 00000 n 0000010080 00000 n 0000011999 00000 n 0000092724 00000 n 0000093002 00000 n 0000093067 00000 n 0000093403 00000 n 0000038538 00000 n 0000012021 00000 n 0000012919 00000 n 0000093433 00000 n 0000038687 00000 n 0000012940 00000 n 0000013981 00000 n 0000093463 00000 n 0000093661 00000 n 0000093931 00000 n 0000094200 00000 n 0000094421 00000 n 0000094816 00000 n 0000095021 00000 n 0000038844 00000 n 0000014002 00000 n 0000015039 00000 n 0000095051 00000 n 0000095426 00000 n 0000095848 00000 n 0000096302 00000 n 0000096669 00000 n 0000097113 00000 n 0000097419 00000 n 0000097852 00000 n 0000098093 00000 n 0000098341 00000 n 0000098406 00000 n 0000098864 00000 n 0000039001 00000 n 0000015060 00000 n 0000015860 00000 n 0000098894 00000 n 0000099235 00000 n 0000099433 00000 n 0000039158 00000 n 0000015881 00000 n 0000016737 00000 n 0000099463 00000 n 0000039307 00000 n 0000016758 00000 n 0000017489 00000 n 0000099493 00000 n 0000039456 00000 n 0000017510 00000 n 0000018316 00000 n 0000099523 00000 n 0000099819 00000 n 0000100141 00000 n 0000039613 00000 n 0000018337 00000 n 0000019111 00000 n 0000100171 00000 n 0000100609 00000 n 0000100824 00000 n 0000101125 00000 n 0000101470 00000 n 0000101782 00000 n 0000102252 00000 n 0000102558 00000 n 0000102888 00000 n 0000039770 00000 n 0000019132 00000 n 0000019801 00000 n 0000102918 00000 n 0000103256 00000 n 0000103482 00000 n 0000103548 00000 n 0000103764 00000 n 0000039927 00000 n 0000019822 00000 n 0000020615 00000 n 0000103794 00000 n 0000104157 00000 n 0000104460 00000 n 0000040084 00000 n 0000020636 00000 n 0000021505 00000 n 0000104490 00000 n 0000040233 00000 n 0000021526 00000 n 0000022721 00000 n 0000104520 00000 n 0000104960 00000 n 0000105339 00000 n 0000105563 00000 n 0000105756 00000 n 0000105821 00000 n 0000106207 00000 n 0000040390 00000 n 0000022743 00000 n 0000023718 00000 n 0000106237 00000 n 0000106422 00000 n 0000106664 00000 n 0000107008 00000 n 0000107283 00000 n 0000107591 00000 n 0000107943 00000 n 0000108307 00000 n 0000040547 00000 n 0000023739 00000 n 0000024702 00000 n 0000108337 00000 n 0000108643 00000 n 0000040704 00000 n 0000024723 00000 n 0000025474 00000 n 0000108673 00000 n 0000109065 00000 n 0000109130 00000 n 0000109451 00000 n 0000040861 00000 n 0000025495 00000 n 0000026526 00000 n 0000109481 00000 n 0000109781 00000 n 0000041018 00000 n 0000026547 00000 n 0000027363 00000 n 0000109811 00000 n 0000041167 00000 n 0000027384 00000 n 0000028847 00000 n 0000109841 00000 n 0000041316 00000 n 0000028869 00000 n 0000029654 00000 n 0000109871 00000 n 0000110176 00000 n 0000110565 00000 n 0000041473 00000 n 0000029675 00000 n 0000030625 00000 n 0000110595 00000 n 0000041622 00000 n 0000030646 00000 n 0000031610 00000 n 0000110625 00000 n 0000041771 00000 n 0000031631 00000 n 0000032086 00000 n 0000110655 00000 n 0000041920 00000 n 0000032107 00000 n 0000033090 00000 n 0000110685 00000 n 0000110885 00000 n 0000111132 00000 n 0000042077 00000 n 0000033111 00000 n 0000034414 00000 n 0000111162 00000 n 0000111490 00000 n 0000111872 00000 n 0000112161 00000 n 0000042234 00000 n 0000034436 00000 n 0000035711 00000 n 0000112191 00000 n 0000042383 00000 n 0000035733 00000 n 0000036380 00000 n 0000112221 00000 n 0000042532 00000 n 0000036401 00000 n 0000036634 00000 n 0000112251 00000 n trailer << /Size 394 /Root 1 0 R /Info 2 0 R >> startxref 116888 %%EOF gcl27-2.7.0/ansi-tests/doc/ilc2005.pdf000066400000000000000000003617011454061450500170620ustar00rootroot00000000000000%PDF-1.3 %Çì¢ 6 0 obj <> stream xœ¥ZY“ã¶Nü8¿BvÕˆƒ“ü”õúšªµãx'qªâ¬èô“ÿ³=®¾ºƒá©Ê•buwåî£+šóŒèU.yFá‡ãÕçw‡ò‹»ß®8͈Ìíew»«Ï¿{ûnZÔ™âÂ/¾ùñý­]"ynpõm{<¶]ÏuÆ™ÆåwUš!2­”¿øÎ.™ŒKNü…e?ØEÆ3¯{?VÃd샯(ÍŒ”ÌîcMÁ& ¦¯9Éx>]üÓôòL(Ã$Þ_Œµ]äŒzû¿µK2˹a9.enÉh­ü­_Wåðçôê7à/x¥wúÚþçàÓU/7“÷þ‚Fš•ÉLÎò™³™V˜-•À«ßlú¡+¶ƒ»‰±ô¦5Õ$zµ¦y¦'K&g«Œ(Ž_ve¿íª‹Xžê­\)ìE„€mÛæ¾íŽE³~”2SŒû­èøÉGšãjïÏX&¹¸ ÁÇs!͘Ê(aê‚dJvF=ÜÛ½«À#ÕfúAfÌù8”»i•dÚÆãÚOf0x¡öfœŠÎmpE¨ß^{?­Q[ÿ²ï~ü'¾HPC/ì]s6ln2ÉX4ùW›¿~‘aÖ”ýÖ1•( 4üœƒy ~¦~®šm=B§gC¸B|mWbš|=Š·žG'1rM™®6™f9 ßU!ŠÁ¾Õn,jŒ#g©Ùý5"A)!ç€Ð†<”uí­È¥:¿ÐÄPuE³kÓæX¦ƒG‰Å}Ù”]1´Ýô Á!’áÄãZÀ^4‘1ši—5“›DÆ)çžbþpK†Rê^vÛª¯šýd ‡g„_úS¹­>Ûz#-"Îz ™¦ŠÎF`ïhSÜdr!HFA?žêòX6C1Tm㜮”ø`€ÛÐ?JI¿x@LñÖ8”(ûRå ÿ¸°ý¢Æôâ“ÄÇçˆp‚„ŠÆÅG÷DNiàìsb„ÍÛµq¯Sð>¿4î{´Ÿ™ÀñUƒŽ£&dPáqU™!Ï<„ÅÆ°°mçlà.˜wöáÚ¦=¡Š«j‚šÎ”ý”+7eÙø eÁc“!{˘‰œEö†2°¶oº”¶S>Ò·Í0á–Ù ¨®Ý[»/|®^MIc¦â³À蜪ÕîÑbºþïM`¦Ø† *¾ök¾(@Zð=te³.«Àcšê'ž‘Ð9·b@žCêˆ ï\Ÿôâ+0KAFðý¥ DDYáaÍ-ÙU8TÂí•uÑ!çCF¹¾|û®Š 3 ºŒ¯êȵ¢Ûaý¢‘k'^¸DÎ:ÑôÙYÀÏ¡Àd‡LðøX9ê²u¿¹®…‚xÀSAåd2OS _ ™FhxíYZLÀT )´ôoÊdMˆPùèD¡õ EÏŒz¤>崡ňäñc_:J‡:,I0u :es°³CÕÉヘœ@‰ÑboI¡füx‘f¶Ès:Í ¿71¼ÿÙìñ?+½ƒ‹Y®„Úkc&ħèJIëYqv3TLAp»Së´ H*Õ¼™L-³¸ð5&^ òêyýˆØf<˜¼k'„¬AýJPvÛà´\5̓“¨1ÄOg:Á»uœ'>¾oGWµàJ¯ìÇ…ËP9Í!@´ùg7ãqƒÐVÜó -§/öJhÿŠÍ¾}ý¾ˆ[©üž¹ÒþÂc†ÌÏÄò¸¹„ý¨Œì·”P§"Èß8;Dºd²” »²ëáÚá r^B Óh9oKm‚BØ9íРÜéKì޸ࠪÞ! ûYàØm{FÀ‰zq¡÷5âa,›|5ÁÑz%¸7xÛÖä1 4»(¸ÃAèFEø›ºB¡^„Kõ‘3Ý6F,„æXTpOÕD©©Šís^§~2ö¯Ð¯qú„ÌyÓpªq2Âc"3qA^4E5W ž] ÍJ‹L¾â¸©öP”ªÒ!\æÖJ_IÁÐÆ`-–4…2¸±/?Œ¶Éqw‚tL°ˆtÈ—²CxÐX¹|®>¦ zøá`Hé5\öŠxì*¯áTìÍî¡þ9mÍtšDVøÙ M…°ž-À¨ðë{…Ó¶TÚž*¤½ £Ú ß•uµ±Ã¥+2²tWíP-²‡¦.we_íoçúòxq¢n’OÕM’Œ)¡x,‹~DçZÚŽú¸Ci"âÅ]ÑüŽD›§D;cÿœÀnÎõ <Ä{"‘¹ÉC–d®&©6ÃI»IªØA‡+òYï1°õÜÇ—t°Ù¶™²ÄÎ碠]h5ªz¡*úˆÍ‚Éä+íìe¾ñbz9Ž ‹´—̼DÖβl¥‹qí·~;±ý™ó-ˆ:˜Ö(䰶Њ̣Ô¾œÉWõ *¿ì’Îh¦'ŒZpQÒ%&P'jê"J‚¥>lñ©x(eaé(Ç®AÛ’¨í¥pÔíéyˆfT %<,Ú‰_&ÛzÀˆ(¥ghÐOüê ëò‚Û§†w}[u½këløyà¯Ê –!ZÉvŸÞÏï¬,Ž.élžóYÛp(|­IráöBXì÷l3„ùbžž ‹ß=gÛ‘eHŒZò¦cÌ‚$cÃ’NgŠ¶å„¶ qŽ½-Õ‚8L>]`ê%¦'Ÿ”NjÚèÚÞù³èû %A ÑêÓ?ÌØêã×ß—@«;œ¸ÌdÅõ%WEdK¶€ìdoÿõEì _B´Ýï(fóx^±kñ\iöšPçÖ3ÏWôlŸ“Â3f/¸^d¸Û¥ah"z–F½L K$MîÅ£OŽ¨ÌR¯ÒèÕE—|þœÃ¤°dQµÞlgÜ_²å+ñ–t{ñ”ÄšT³æ›í#¨êåÓ‹…YJ1(;?g™åô¦èK?«Ïã¥xªz9­¶WE°¸á4ç„@køhUÊA ؅–Öé0°®ZE¸“üŸ­Jíª“ûõ×é7·?¾½½› ­¢VùøŸË×χð\eĈ4¶*;WAÔ=0‘ȘDQþÛ"Ê=ó×/¦R(ìY_T¼áH(™c~šça±óß8«ñ¶éŒ5~2ÚNé<†é™`U'#.»ƒÍ#¦£Šzýû¢«Ë£# ‘ÛO?7~â™Ë%­MÚlþâ•J„WõÎaö¡§Û†Ã#v]¹ÎWÄc‘tøžè*Oëü)ší¿h/ÉX]~Iÿ1®"Ûcïßÿºü…ôUóÓÜ…¹Šwòü@˜º4K§-3²™>ç|0X£‚¥rA·Ï°“(òœbI†ˆÈ 3RŽ_\˜ô”e¡cw‰5ŽÏ™e>MZ‚·Dæÿ7Ãû/@fãðÈŒVü' ßÜ­þa¿¾4°[›dµ¶Ÿ~@=²Ÿ"Qb¿ÒöSͯn¯nnX`)¯n~YÑ«›ïí¿¾úé-ü¹ýzõ—«onÝ£–>ä\ší)û¢1xpó õ|¨Ès®ÓÑž&Ö cçÓÅ?´CÛµõälhÔrâwu»Áf/‡uîcõ¾½w¯ý: æ¥ô¬š‡ïF»v<ù¿¥œp¯ eøîé› µ¬¤Ê“Ë›zß6HìGUáÓ›ŸÛbwáà:÷‰ý¦i|ÿNuè¨ÿp˜Ó\s7vírJ+>z¿=ãq:å°œ1vzœò šö×Î^J¥òι}‡D°õ×å„š< N0ALcÝg;ûéߎ‡lë”$ÄϬ ”’SüÖJ5PüíWy‘Îã̧oF-wcÜžJìܛؓ…/‘Ãpúòæ¦/>MS²}3fm·¿9uíoåvèoöÛú& Üþó? ©endstream endobj 7 0 obj 3577 endobj 46 0 obj <> stream xœ­Y]sܶmý¸¿‚o‘g$Š€pž,WI”Z‰*ÉÍC”™rw¹ë]rMr-©¿>Àŵ´,·ÏD,yq?Ï9?%YJ’Lÿÿ‹ÍìÓìSBÌšû³Ø$'׳ãKZÀJª2E’ëÕ̾@ÂUJóD¨"eEr½™œm¶ëjS5C9Ômóúúß3šñ”ž¿^Î~*»å½YVi.8Ç岫ô"i–K†‹ërXµÝ¦×?^'ÿïXÆÁœÙþ(OÁ)Î(˜ò<Í ÄÉÙìøì<º]5;þ-!³ãŸôN.ÞÁŸ³¿%™ž[ÿM¤En›Hü僉C¤Lx—ßµ› ;g)幋ï}ÝoM€Œ¥L \}»^cÔ"——Õ¼. FRɼ‰mœ#ÊIš'G„¥\˜Ÿ§Ýyvua–y–Joê¡Öˆ”)!,6óîüû÷æ\¤²ˆÞ84«à’ÎüÕ¶ìÖ’(R^ÐØÒÕ‰5D2ȦyÚ¬‰ÜüÀ”“‰x»m"8?»¸rË*ã¹Oèö®´ë4Í”ü¢5ž(Iáò|_uïÐyp:S±óPÛ÷nÞvÖŽ„VðõÂ(¡†ÁöÍDa㤩 Þ?yóÚ¾×wu\F¥wô‹v·È’¹Æ÷ôçz‰Ñj”õ9Àú üík×ÐK*0PÝ@V˜FJr·]¹¨0åQ ”Ì"‡~Ž”Õ«‡~ì±.[Ÿ:ïB‚Ïšýö­+ÀrI@añ@µ]}[7vœAÆÒ³Öm‡8Î*t€Ù3ËŠ/†iˆH;oX+JË}=Ü9aü1¯ÇÙ”› ]QÁð¸Õ¹6À"ZÊÐxûVúÇͼµòXaa¾µêò©‚)ƒtß¼>D¯ ñ AËÐãYåÈ’J‚ƒÓLz»s›è‚°—Å“P|¶¬K¢¥r½ƒaZZ‡@ÅÀ-›%ê½"ó9ÿOe[&T„Æ·¡B@ÆÇ´±imå´¼ ®‰h¢÷‘ÿ¡QxÐ:Ág\®°7‹TŸð€?ÑÙ!ŸH³lË¡¤$è\¯kxAÜÚ€f¹VHôiiX k!åä9ï!ávoFÎÕ•°w{¦òM¤)ò•Í•æ‹P²f·™Wæ0‚Å)™î…ª?DT-B'‡NÈ| wmïJ+ÃGÓØ,Š•—Fý1:åúú}w]Щ›É‚¸1¹ªªàž{þ•£_èÜ3ø^Œ¢À½n›àgúS]뉆9:™®ºÖµGÔu“ÕœnPCo¬6×µ$#X}Û#D(ü­Æm„£ØKº·]ÆĈР¶a@U¾‰‰ïœªgŠ?•ù¡j–®`†•‚ªt N˜Jy±Ë¥uÕžû\Üu³Xï–6ÛÇo£oÜ Ð‘þÐC"¡"3—”‰½Q€öyBõ… 5OŸvm¯ñ”,ZÛþhÚ1#>²®¬ûàfè©ù£Ë|Tôˆ.³PÉMùèd^èÏQK]¹ÝbŸ ˆA¼8x}@°7_Ó‡¼AZJsþꣲ÷·ÝêyåcÉõ`<×$Ö-U‹£ª5Ó“ìÂûÁâ½ÎÊ#€:É ›Œ"]+ò”®õfOé:¡þåܱD­A3Ïu³¿Ii¡NP•¹ ×åf¾,ñõ"Ę þBdÑn¶õÚ s-ÕèN¡q_F#è\b…# ÒrÊ M DXÏÃVDÚvcd8Í°>ñ‹vY9êçá–+Òã’Gmõ‰‡ @ àrÆ ¯šÞ)ÁHŒ:f؃Ô ‘¸ ͱ Ž«õÊ“j¸Ç›ïån@èSGBzmwë%n$¨7­Cz:1ófÀ!kµ3z•Â²¸ lAS€$ŠëÇ À<s$ï`jÖ   ¾}ZH÷Rh!PŒyø-&*£~6úݼÇŠ,ÍÉSí3Ðty¶1–F­µ@)PÀ¼ùg}^yàn×`Dx°«¶•Y– á,qh)2Nzµ;^E(ÔÁ@Y5B ¬[Z­§¡á»Z¥ÑØO-úáqí$€ ÁN&kÔðèè™ö7v,.4VtºÄà4Ë£—>4@pTÎe媜¹í¬ˆÿHà”ïtž¶Ëb> stream xœ½\ÛŽÛ8]Ìc…Ÿ³À´Â›xÙ·$“l˜K6Ý‹Å󢶕X3¶Ü‘äd{¾~‹on[£ é†Z«NU¢H\ /þg.·W¯>.HÉd!Í•k¿`!Ë‚É…@BêŸpÛ‹›«g7?/†n__=û÷_={£ÿ{ñö%ü¸ùqñ—«W7‹³˜{¦eÁõ£hÌ£à/_÷(l ºËíâÅÝÕ³wð¡B!…wï¯Æyà–¬(ù‚+Q¨ÅÝöêûÛz94»öow¿_Æ(‡ûîVWßïÞëk‚Jb¯½üéÍ­¾úêîÔˆ¤¨àùç@¤*À^ñ$š?k‹à&@-Úß¾ñ8Ôýo›†L™—0;-ÁìÙoïëΘ¸S²òŒÙïô¥²PR!çºúéi1J±žÎœiM‘œ+ª ò­žE6û7®pùµ°æŒ$_{îy×UgŒï 72 ×0e14‚ 'ôËtÏ !p3W14Œ‘ú2aç›"†J»!71¸,J3×몫–CÝ¥p#38 fdp) £’—e32cúÚÙHÉx1Ö/8c_›{æð2¾b#1víªÑE6…™Ñybx“%0#32ÏŒ€Œ—23pMQ£D_­ãæPƒá‚JGRdÆe*É!0ÂAg¬ïY‘š©$š¯–8%cÌ6E *È%49H>=Å«¡2z–$èÙ¿ZeH JÚKÀŸ¡Ûm¬zWÄ«÷×›¹›„ ÷€Ï TË=™gລh TŠ’$°'32×-EÈpJ·4×}¸ºHNáZ1šÞ uW¹Õê/0#38“WV„NIJÏ,qyfdFf˜ÁEŒLð”Ä2×3ôØH,Œ;î«é)#34ÓJc#p ÄÈ Í´Ò€)‚†©<“Ë<3f›b#—x½URê¸ÿëýïõòܻόÌÐ<36ºd))#34“2„Œ¡ ‘ Pçàš"†~©—¿ó-±‚ÁÌðmx©æUÇòêC’îÈŒÖpÓ.æ„ „U’ÜÐ|y И:ƒËse®)®à’^ ñ-!_ªIª ë¶Ú&q%3Z¯D<\&0JX"É Ì3Å#øLßå‰2ÖQ–P¨L‘‚ŽÜÛ®i‡ñµþX‘š«66V2ŠÏduÏ‹ÌÐœ‰ ÊSÊÍ `Ì`R’ (T&d!F©õ®®V)ÄÈÌ툠a„9OèisC3 Cªç ¥e®)^Çùõ)ãeAˆÝõq_·Ë”J’œ¡T’] ª#e¹=74“3èá(Á Jæ›â×ïÞòs£Ä…ÕíÐÕÕ6…™¡ùj°a^ªs;7<32Cs½KM¨„1spMƒ‰òz”QY`Ç‹¦ý‹ÌÈŒöÔ¼ðÐ$Uç–<+2ó¥Äc)Ús¬)RPöÕ[ç:ð’9Vì—þK*%™Ñ¹…óãD$¬‚åFæ+I@†)OI3€Mqƒ ‹$ #7·÷»M 12Có•$`È£s2Ï3#34ß—DÐ0;CYÏŒÀ¦˜Ä%²UÂgÇ~¨·f` ûÐõÎ4“P’^·äÆmò b1p¬_&°&32ý—p# o[æÀšà Uà¹ü½,…ÑlXœxaûøRvrC5Ù(aňI”°ê‘š~ÕÁ*UBó2ÓI„’hl)°šýÙÏM¿L`Df\nkkŒ(,eB½É Q ÍŠ‹VÌÀ5u”Ï7c4„5´än#ðMû¾«z§z¸–¡ÙÛÊD ã©„õ“9Цèñÿ?Ê»z»K¨FÜŽÿwU»Új&ÔHtÎUœºO;j“{Æë £Y`…Ê”-fs My}Æ£&“•ßjë<Õ%ïIHûŠé„4Ù Õ&&™‘RÄ NÊ*ô„Éšd†Æ0XKX€:MØ2Ø$éËúÞšTQÌ®Ml:4»Q!é ò÷ã]Ïú¼qo72‚SÙâÉÙÝèÖSq? –Å~œS‡µ-Ô•§£\hO{âï»Ý7ƒù8˜¤\Àß(ãD›äZsQ£†_ ÅÍÍÔŸæÂÍæõ¾5Ýß=\B*c‚³Åá‰ä§¸Vª()”Åk½Y„_{C‡yÝóÂÌŸnÙoþ0Óú=29´ÕI÷©DÃügo6íU ®[B»ÛØèÙ”ˆ3ã½?0 aï‹Á‚P°¸`Uwõe‰½Ñ>s& ë•;¸×EñpßlÿP/›ïŒÈÖ‡ ÂÑýÇ0¸ÑÓÌY.:'ôü—ÛóqUУáÌÌBÿùšÁ‡´ ³ðÄ^ÞLJfYm6'4@Ê›ö} |k¿ëœ•‚'ëj¹¶³@,TÝ bј¬”#çìdô^ÑñiLï¦ñ£Â”Gµx¼Moã‡ø«Fš ¦ûôwS%=H3"==¸¥§ÞÙÎQŠz+¯›V±éŽ? üª¦mÚfBªPô$ãH˜ÐISëj°¡,‹žcG«BoØ»õh©kƱÙßyÿ¡;qêìS³òÉRI¯/"ç/»ýjô Ô=Odk#‰§ù’H…<ÐU˺ºo6Í`èÆ„öŽçrH·;ÏHfaĪsy—H?s ŠxDíÿ.ë°—ée,”¥‹àYÓAâ/ƒÃÛjkݪ‹«òšw9.¼aˆá"$ 죣Õ~°á…B€ð°£ñð€mÕ:!§>Ž<§‘e©HlÇ`' ¾p©8&S2æÄv磭 ÕžÓÚ’#Tði[[pê0˜<9!#…üÜÄŸàf)jÌfõÄ›£ßmk;¡(°>»€`ñW‡TÝ}dêš1m´÷±,Ò4p8Îi È'a~d´³î Oúµ Èþ fo=OOi(œÛð-"Úðž;Áõ‘!{û-)à;¥Žãˆ„€±ó©<Ê(0Ut”œM>`Ǿï£/—‹äøËeäq?;¾A N;.E‚èc>,ü¦]5ND·YíDz âGo±xÊQUøt$Jªî1TLó3ä8_áPè[›öxž£Ã¨"ísí,…j1²h'¦s–±qÀ¤ª·~eaè¾Ù>Œ¼¤àXèrâ^[ûpTû¼¢:È_.%@IDeÍ°ðeYÆC¬WEÈÊîâë€Õ÷²Ýq°žªK•öó§lâ–†8¼ûÏÛW·…:e7Ð8ܸ\×Ë?œ‘T`NšóoÿõBôöÔ8%Ø0è [ ‚1ˆó¡±’œ)­{ ŸS¬­£Šú»7Uç`È™jë,!üg—»Í&$6‰7¨ŸM£H kßl†ë‘/׶ ‡"~ úuJacZ‘í['&ƒªk|i‹øØÕ÷MgK!DA$°'Jøðéö­ÍkQ³rrCQàâdc‰·UýP·«Þb€ÀçO½BÅQ7r0œÉYú8zåuŽ`q9Ñ8Çók†QÊ–p‰> stream xœ­\YÜÈ‘ä7ýŠ~Óè¢y$¯ÇyŒÖ³¶gz×’±YÙUœa‘%Òôü5ö÷ndfdFd1«ÔŒy€ÍÊ#Ž/¾8¨Owq”ÜÅê?ü{zýéõ§»D?³ÿkOwß>¼þÃiO¢:®“»‡§×æÉ]!¢ê®¨‹¨JïN¯ÿ£{Õ6K7óï~~-²(¯’ ^|Øßõ,I£4—ͳå(õÃ2Šã2Ç¿ûµ•gµJÓ«¿æu”Uu‚ý©[V³ÅýÇ8ªì³lÝÞY•uZâ_žÆIïSDiåöÏrj󗬎jz}ßé…šéY_£Œ*¸7þMËÔÉù^ÿ*ŠÒýª™ñ‚]ð‹ìõÒ4Êê"»ñæ"çE?N³(‰s±9¹ˆKûnÛô½}7¯Ü»Ë¨žíD ‹ìn—d‘f•uh¹Z2áÔò¥[Žx´t'\Æ·- ·í“VV%iõ‹~-ŽJÒž8‰ªœnZïÔ“¨¢¼pZy6{€ÆãŠkÚî{XO  £‘FEæÔð‹6‹(-˜Îô[QÁ=›ƒƒ¬KwÈqÚ£5 ²’s35'¹H}QpÑÉi'´„,8söt1»úçnì™oä wšñ) 2ô"Jh‘WÓ¼è§uT‘¶ÔSs>ýgeTgBë?/®®ÿöÏßÿ¤ƒ»¥Ð‡ô²¨îN‰ˆ’¬8Ò§O@áN?Jýƒ´â‡ZžÏúiå¹{jd†o§¹ÈŽímcán;ŸeÛ½’{Ü2Ï’C6öÅ|…ãX8|÷I~Z»IüÒv˱±bOè.óx27Ì£’ž^ÀJB«õ †Ùñg²VÁ­¼¸ˆòŒ+±1^ ^µ+*xÙíå«ÁÈ(¤²«œd3tÃA‹.Vx`i” êÌ@…Î`Ñc':bŶûs7Ÿ+Ø…ñ ‰pÐô«Ôn‘ŠT,6ª(H„{°(½Û-JŠÒ*‰ëÞŸ·dÀ>ò›¥QkÎ%ýö<Év<ןˆ£TÜÊøø3x’1%/gvK…Ýf‘´†œ pv¢P@Çõþq:Ä¥$)Ä­KÏò Š=.˜ØñDÙ¶ã°4Kõg¦“„Û΀®€VbãÔé6´¯ gYV]p‚ž5&&×ÿ¼Z6Ó¾ûÍÙp»Ý˜p™ãµ}3ÏrÖP”$Sä~7lõÎÜ´ÈœüÚf6çVÞKv§¤Ô¡Â>š×G´“Tù®Ó¿bâdÝÍúé¼V Ò”âd"˜Ñ2XÕƒp³®ë ë,÷÷x‡¬Úp†¿ÛN>mƒè«¶“C‹`\ÒÍ1x’Í ¡K‹|W¬%iÁ÷p”Áa¥œè Á:»¹SH¡ Ú¡ïÚ£Bšâõ2 ·tçBþITW5j.N0\)°GÜÉ辯r&½'¤~,B7]¿"ªxÒ éá6†÷ܳÐAdèéÙ¿}·;{y2ô1d0¯L‹ã;ü­Ž‰Î¢;eÏk¼Ϫ´ŽíÙž°±· üí+¤ÛKUèªcûVs>KcŠÜ9ûpb«Ë€‹³ ×yVååXÊñ# –ué´ñã:0ÊÁ®Ø¬]ÑÅØÚÌâôÚ[ÈI¿K¿×~éÎÆ߀òûy*4xTpäù!‚˜J-/ô8'ö <ùð{„÷š +™ÿz‘™AÊlõ4Î6€³“^Ãn'ã’Š©NËï¬ó%ÙeP2wqrôèq؉æí‹®¬ÅÈoø¨.¯`÷WÁð-9V·lÉÒÏWûîûâŠ4hž’W~0þRi²j%„¡ÒËt†ÑÅúu+'•, úŒÀò³R¢l“u—ü`Ìbk¢T¢^)`ÙšW­~× •%+¨í#4ï„èàŸ¤Ü?6í/åïi2 ‹mÎÀ±œ"§¤ãˆõ9¸'‘Ö¦ŸG¼'#­k¿½± 1«ä"Iõ³då)÷+VItõ£ŒJöRž¶!äÄvº aíT3ŽQè<Ã:†…/–¸°$‰±N$YûÌ©l©XÜ2ñÜßÚnQ§µ­¢˜Œ,•Ûœ@=ý$ÌÝ£ƒ*FÓ1Þ{œ±9LÒ»¤Úb ¨7E6¯ ˜r6,7K8>wpQ¬E´æcÎÁ‹ítÛœ×T/Êh½1‘.gA(S „«ýÞÕX†€ˆÇs9¼Ä`)•HrÔøé]Ñ„…Yswˆd)7‡=dð¶lâGž40^8Ûsˆm-4ãü9¥¶XÈ*!z:µ<ºßÒ‚p*å{öT¬H×X˜½¬™¢€£ˆÓ¸ž#´‘Š¸4Kô»0!Ââ^¡Úµ<Û„ÓÛèJÝ>˜Ó¬“Š©ˆÝYq3§ –Y†P‡¸†ê(8þŸÑ ¿Dˆ•eF ãCƒgÃürþK ^ñçu°U–:\P­±?ü˜æwŠ ÁΪ™µKâ DGÈ -ãz±œ³´‹ýè(¨ÂÁðÞ¸,7Qà²u¶«r ÷aÀ¸*«ë‹¥ú¥~nF‡,uºû@…D¢¼0(ä¼ †:çU½ëÎGü8ˆ{cÔÏyªî :ßp+ž¥Y ³÷ʘóûõ’"½l^ÔÕ®”Žƒ²q@Ì8¤³û/[û Ê@IE…ùyÞ»/R±ÅÒM_ðß[˜ù"·XvµZí󅀶^YYCØÀÁ|Õ…j-CˆŒÕV†9A–ªO#FV‘¸ŠE¸ýŒð´%ËW'~¬ñiù‚ÐÚºìyáÚ7ƒœà­O§uè}0ŠjrÔVe(Ç*ouÍÄf‚ŠßÂ]\ã“õ1ªâŠ‡g{Ù6{[H|„|ò‡g¬bdª…êlé}e43Mÿck¬—à%’ÆP*-eûìÿ ™’M®EÉ%Ò뎟GÆl ƒ%£Q¡e¤¤ƒ“\Žã~ìǃ^¿ˆÁ”.ƒ Ó9œûŸ •U‹Yðd1M×úg…áZ QgfªS±žLº(”µ‡Zv)Á2ï²€p¹’Z›´%ÜiBœ.”´< ]Y*ªÄJÅÄ{*JÑ-鯹Ú£l±5”çp“nBa3J=ö®¶àD()éöè1ð{Æ Nt$FÔŠvì‡yðËÅ ¨2/ÓÚZiAJ‘Ñ®Ö>f[A‰)ïygY¨.~ð\’åž,¯ÐoF,/¨š×ºÉfãŽG¦³có þX]設᫇Á­V4‚+š˜e•‘²8».ã èŒò~m98#«6pp895Ϩžêöƒàn+ 1J…ïL— „W®ãù¤º (ŠšœýzŽ3zÇe%¶<«¥è î ÌÁ½ÕdŽWo|¹Óºž>±„[“*œïô#>ã2Ø‹®9%ÿ´‚£¡›e¼ÍàÕ—YÆýŸÍ€—šsm(Ö6½hÁƒdk›¯U$x™Æµ+ÙÓïm·Á«eÿÙ•[±ÝÕ¥C}c ]"áåó#òši˜¢·ª©xŸ’ÑÚ•ÿaÊÉY©*Þ^ˆýã:a˜®£*Ý€ªçÈÿµ4O£õAV5yŸ]ºiJ‰ö$Ïã´àY T24F—‹Ëö9CÜq²Q9‹y½Ëžë[0̹Ó6³%ˆ»ñ6½+¨ñÈz@°HÌ3଱i0¦E^¹Pźº“ìq`@aJ"‡Îj±ByÑ{\z¹µªó;7³…þ2*i•&Ù PIºžÖÊy˜$Ö.½Žó^š¹Ã4æ%Ã0C=uˆ³K„R`ŒŽò;@,Þ¯º&÷`’•YÒv†Ts†ùv@q,/é÷ÿ=t¿¢ {³ê°  ;~~¾#ò)T'ÌIõãÓúÛoÛH†}ƒÙdÅÈÞ—W¿'ëæ2›¥yl쌄ÈTÝ‚ëò6•œé J>÷>‰Y©Ñî ú´.ÁU^ßšÓëŒYjqîzäî~»ÿ}q{±ÒwnŒ˜×ëîÉ®íîbû–A¼Zgaöµo©×ÈêèA¨û©=N£Ü»éÅ’3¹ŠvIüu´süZ ÚÒÇx¡ñ Á9€oýœ|›Éñz–1Ù‰Z]6ÊëšëŸÕÄâm/«‰ù ™ojWjb¼ª6ž×ÞŒ¦ªÚ­ðMßïþŠ^ DÄ™V7b­/2½:P‚h¨CÛ´Ëjù Ø>«´XÛ ¼~Z°Šñ O¥‡L´~yp®&W˦Ϧ~à{Ççnïf±xFd ›÷¶Ïãöê@°žÖ·b¥35is낵B“iWÛôù85’RsƤSh³©&ƒ³›ó¼N¦Ù>ÓÞŽ§“‰öiìvøM›z,¼pfÃà ªýâu7¨Â\‹'‡d›j_Ø#ÀóÚªÍ"ÊL" R|¶)ÅûE¥k™Ï=Rv‹q^}ŸHQ¬Xg¡Šµ—zSFžð©&Oœ©/Î’1X§mæädh@y•$eˆìDžB¤Ûá?p‹E}6wœ Î÷ ÀÝ'cØYÅËfv€‡ëÛ¨Þê¾ù‹P?Á†OD+6iQ±dQ1.RaŸÀ8‘³î3®î0„>­qý÷œ÷hx1ÝÁþ°•éUƒ¼ßRí—võ 5¡_7Þ­\»AÍ‹»Á P”;Æ×/|ãã€av¾ ì„ò±ØÓv8“ Ù¨•£HlJì²Ê¬nlC+ð«eÍ pÞš´—S›PjáQYMñ‡[cn>¿í²q$ó\'0Pœ­8X`ÛeDÔ×~¸~Š´˜µàíª8~¥úaàtz @ ü ªvYéAýÁ4ì¯ß2Ö )Djw|0ñ©ÊDæ¦Q€¡ñƒ$¿Ø¥¦ýC o~âÇ'§nÁ»"ú vr–è[`)¨VÖb¥Z³®~Īp ®æ-@ƒÈñåH’_±c©VªøOµÞØ€B9ûŒreECpD9–#&r9üw¹ÙœOþÞ¶4ºËÔ*ó›÷^F;Z¥çýS?GtŸ3LJ+nCHÜYÔháØ´G׬۸!ÿÒç,1I)yÙ'4Ÿ1/¼¥ÚÉü¬Ã.#è(}3Öæ€uÕhHÜO¾º¯¾R§Ð϶ÕòoÁÂdð%_LÙÂ>–tƒ8}ƒ¶ªÊS= ht™è,¹€¬s?cX›Ï6!u 7e_Çy_öamÒXhÅóŸoÐ× š} 0æS3¹Ì„režÑ©ƒÓ§vjl>´ãÅÏIn@¿í©Â~Êiô[¯œ[ó2é›3ª>;yž}Æ+é~Y¸ä)•›gßüŸá]«ªˆ¦*;çôÑ»uaÉLcGX¤u®_‘óYŠ¥±ŸÀ&$̃tårR;à¡/ËöJÞ#£z_áýÓü;:õmº yï\‹]Ux q±ÿl¦ÿüú_ûd#fà|«O[°÷”à_ü­¡ûmpFÊ›¨s`˜(öpðÂ;¾²Ä:œ'©þ û!…úäÀÏ)YŠÐ<Ï®çDÿVꯆP'¬1HgdY¸ES ¿tF ϵû'} $£÷p÷·×ê¿ÿ«?´endstream endobj 61 0 obj 4927 endobj 67 0 obj <> stream xœ•[[ܶÜ>í¯Ø·$è®,JÔ­}rÝ$] q\g[­ D«Ñ‘ƺxmÿþÞ’‡<‡#ÎŒIÀÕPä¹|ç;½¿Œ#q«ð¿ÍîâýÅûK¡×ìšÝåŸo/ž¿IJX‰ª¸—·÷æâ2—Qy™WyT&—·»‹o§vW÷s×LWßÝþ÷B–‘Hã ž¼Ý\|ÛÍj­ŒÒ¢™]›ÔZåU) \këé“ZMDTTyŠ«ó Öàü×Ú¾ë¹UI«()»ÇØna}£O‘ÂS÷—;µ”EBVv—eÆË naÖ6ݽ^„#$…=Â};¶ýlöŒ£\¦¹ýÃ0îôE’"*ÊLÚ#?Öfë’_dz–íFo"@ÒŠâSךåDF‚o¢¯'²(/ÝI¦z×â£lç±–­~c’GY!íñÞªMÆöNK5-£œä´Xe”H·û‡nÓõjýZfi$“ìòZÀ¥þk­þPD™¬b»ËÜNæ¢HÚgëfÛFo¿Ó;•‘Ì3™ê²\?pk®–€ýêðWoê~3ì´õÄQ,œxnÞª²romG½C±“ؾBd¥•»­•%H‡^x?l·ƒ=íò„"H²(¦;Á÷S¤×ÁÞèt?¬O7裉$ŠÉ¬¦õ–GB¸M»~olÞ•'tz5ÃõMž¿¸ÔžgõZý¨Fù_^Á¿•ûýN?yÄWeš)1wYß;“QÎöþýɽó$’%ßú-øqóˆ—íXI퇩›;ÔZ^9 ~0Lr¦_ƒ‚YZ×Ïíµ±Ì\D²*¹==€¨Þ~÷G-vØþ–$öo"Âå,uðñz6KcÑ#&®×/Þvhây”3¿?*>‘ƒÅ_æ)˜æyÕˆ¢Œbp3z|ú´»¶ža•Šä©ÛnцZ½kéÒÉÊré|À7µLpØ6w;Ni“€êÝÝF¯ƒ™¥©Ó«~XÓëÇ= ÕÔ ½Ö‰¬«Üߦý 6ɾà€öî×2-¢ôÍLâ±6ñ¥­—g,­Ð‡ä–†‚ÿ·>ù`‹ÜIïÃ*¤ÔÛ¥50q]È(-+mŠ ÉS€.}STQ¥Šóµ)&Å—™bÿΪâËL1W‚g?ë;# ›”ÓiQS¸Zîƺh‘Yœž?í[‡§Y ™A  Ê@Ù¨Œ¿,ÖfžT3O(lê·áMÊÜíê,<>ó{fã2ª(t“uê«p:ÛÀgl3•Ü6Û~³@Š&PeQ;u'J?ÑdÕQœ¢;ÁQ)xÔ£=¿$=ôüVÎÒw*\n5; «Ý16`icw‡Ì&!«\,·J”Ù»—åV"Êé"]Q´Þ ã˜Ñ¨p$Æ-Àaõ¨qIÛÖ{ 3»ð>s—â1qÅ  =º®FøˆË(ÿg*:!€¯+4PAv È,qDîÒL„{Ý´«¤=Mõ£ EQeääkè ¡Ùˆ„ØÛÚ-¡ ¢È=2ã®wCÇÌϳÙÎTc~Óõ¹ê»iØ.³E¾J8h Tu˜¬`ßÆx&fz[qN¨ëûîmbÁ‚ä^ ÜVÃ4·‰ÁfeæžOÖñ0¦8[o'kà,L©VÇVN°ØvcbK»Ø‚‡K±åG–%úæ” a“*¶.?:úK&Ãn†^¡6  À?uÓ^ß*á”D=®We$“l¿MÝçöt2öΕG£[Z‚:/ágQvž§¦•†ý8äGêy¸Ù\w½uÙŠ»ìÛowÃ4o?™Aöé›Ø¡K¥*Å°‹×Œ  ÆB”-oÐÆÀ2bá¤gÜ0U<—FËþŽÒ7eÊî ÷£Q'°íÒÏcÐSò[±6ã¡i–A«dáeZ;Áýغ³Ñ›ähìê»­åG Ü/Vy¡"HiUéGdÀŒ°2Ãʦ„/M+Ïö®ða–ƒªÏ—F% Ñ#wꘟŠÂ]h0ÜÌÁ¹‡Çr3bL]R)Ó®ßôhîyˆZ”D-ž“©,$©N”žõ"ö±C¬HrJ¼Ú‘·Ñ¦m .3ã–Œ— D‰¬NsiaŒ|)MRߨá6Ýh1á " ^,á÷ÎÒ5Û±&‘U¸JnAXöüMs82VÐy}{óóÍ¿¾G–órÉÔÎ3…IË`B’oA¥…®o¶ËÑZ–À9ànúµ…“²ÙS V‹…¬"*GrðVIRAÕjM±á.(tV Á,â@\ MðàÜ£F'…–ñŠ›'4ÀêŒ t"§6y…>šJ‚L£dpu‘³j2H³˜™„\lšaƒzÜ@°Ñûd¥*bÙ÷² ÆR‹û¥oÕ›ð4†%âð—K8¼Téäšú0F<$‹š9ƒÈ#.[ ×UjeÊ!·>T%ÐÕ’àéÕ/·7¯~ºyÖ"åƆÁm«x‹˜>†ÚV"#TõÇõª­þÊŒ*¡:o=Ïín?#¼–¬bÎ) íêw„öM˜à –Fû¹ÛuŸk§^UP"Ròd~Qx½w-÷9CZÀä™ü`ý>ÎV!óîX@2e Éì#©Ô…¢‚ÓÁ,G dJ•žuºêçÇ2` ¸9ø™½InUjN&.—è` +ª"xªŠ•ÔÊàHù”ùY½®´Nˆ…,r: ôªfØíKµ!š±¼øIG’pÒÁ7qÖÙº3»YÛ©‚¼å'T¨7z¸1ëD¨ct[ËN!|3Îbk •_[ð(«S3xa$Ê+`‘ƒ_›&¼$eú8Š'—"?ÔUâ9¬a4p…»JreW.g‰ÊdGk˜Ç3äÙ“-ÞKNÿ¨MSò ŠÃfV£xzìÐÐ*ÞZ8W:!kyh%RJê«ÍkìC/_¼ ¡4Ø`A8‡š,€+ªÔú6tvžj©—:u¶fõ°ì0øôÒÕ<#àÇÎÎ^óò/Á³Cä`g7(&TÍ ÅòŠ½@)2;Ðþ®Ø3[Ým <^f©£´!$‚—o –WªÔíLkM1GìO(5–(5–ˆ”<Ý嵉µ_0 77  ¹³tà\¤_éK=›§)ïnLÝC_ck`4Inš(†ïÞ4ŽfˆÜ—XA]™×åŒ „ÎÉåYžºþÑhw´É 9ƒçžÍ N®¥ þ ~mï4Y.ygZ«ÎbHfãñÉy‹IX‡!TH"*Pñ4Ba&º‡Ô1’»‹F,RïÇ¡i7hý2çÌ5X\2P[pý~éšwŽÄ0 úŸ¹LÅØÔ„4¤ &8“¾Ø„©<¹Çý°`WòòüQ¿¶&Ì¢Hˆgu–³`9AÁXën¿mDjê¨)èÚçhªàÎàâ ¤­1K fcE)Ì`Ö ŸXsñk c‡ %)¹CHž/3¸ÉÌd©=‚úåõ4µ£½¤jÜ÷8«N,®ú+^=‚ƒ XKE´Yãª@Þ¨RÀš„i¼B~V@·<æî–)T¼=¶ó2öëõ#5éÉv#n†e~^¹ªF•ç™2 ›z™ŒR%*æBÆU&(F{ö—©!UüªQàe6,ÿ#â—pŠ†ðU2.즞\?*wu¤‡§aš±žñÖ7BBÆI•CÚ²Þ„jâŒX#Ù1 ŽŒÝð"Éσ¡1  1=@=S°c8‚]Ì‹ oÁæq~û¹›šoÐèXµV Æ`#²Ë ºx¨2«Ê¨>]Êó¨@áÉfÔ^]woúÈÆ—!ëbsO6·Èy´A6ês=Wó'´þ”bK¾X×u%&i¨ø˜ú –æSêÄÄõ`‘t7Œ®•ÁnŒ©)\ÓËž°cb›* ô.—ŸùçwÚOtúýÌ ´{°cpF9öÇH¼ I@x¢ëš0yt½*wØ;©„{=z èt꜌ãAŠÜ Ë„¤,ÍܬU5w;‹ ‚5 A‹j.Ùþ9øsaÁslïQÁ—q›§q˜1+V¥[à Í1eýý¸ôpà‘î‚h¶Þª¹Bl–¡!Ù¨Pl´-¼ù=›°vRfØÝÛy¼¢ò;rþ Ï\ÂÂ5ï³D°:“ªÀm¶ucK Ö_N—俼¹/dÝŒi¹ã“yÝ[ÑG”•Ôî:uÊRA—׉ímäÍù¼ÀÑ`‹ÐÈúì½›t$§€Ms7/.JÕíÎ6×ÆÁÎàiófB“Jc“]€Ví"6kµ£x•e~è½BŒŽ¹Ýº~ïJŽ`¶•òœŽ­ ªŸ‘¬Â¯#}|¶UÜ$ÐÒMÏL™´dí¯™ßcPÆb¥ÄŠé¿(ÿ·¹c3_7ìÅGªöc»6ì ÖPh’SÉáN™*:®|gäèO¥°.ûd?\·¤7{ÓjZkpE$‰ymzÁ ™¼À)I4 椅_!Ûc$Ÿâ±²`ÅÐz™‡DDUå0Ã5ÉО¹†6cì!ï¿E‚Þ'‰5a,ã)`þŸí†5¥‚s›vêF;)ȪnoY5/4鈖*¶¬ë5,À…îž’h<0¯¢Lœ7> ç%yæU 6lºØu×c 6[½PaetN%ŸÔ@ÄÀ 9•ËRiŠ”'o€Û.ÒX@ÁÒá0‡ òÝ¡LXé@åHB£AœÛÆâ²Z9–Bb¬{åÆ¢J.\«ç8Ê(²¤*gqdú¢ Ìj¡,^¹$"_Õvý<æ~Xƹ5Îç¿ë ÈR™fLèÔ9ïéÏ 7„tok—¬+ÏþéŽÑˆ™îÕh\]"üøêï62“í¿üéæ××kƒ6¤O!ÙW½–‡Gãm`s©B-®ç$Ž,YëtÖkívã ÍæmWrêë‚×¹ qYÈfB)8»üÌûD#ĪY¬¯)ð© {ØgnòA–¼ÿíðXž4¡+DAÆü—‰è%£²8.–2¼Vn- ³ONÀ‘Ñ4Ùw%?þõ3J$¦£¾˜·FiÀ„ŠC\Ñÿ|ý ¦Špkv¢z$¡’T ßNw)ÕñÂhn×ͳëÕ²3sýÊiK]©í};vÃQ8§Èì0ƒU,wE8NTòRÝ ì1xh®l–fÇ‹RÉßuæ¿Š4qÀ¼CšÍfÈž}Äû¤TÉwĈ1Š·6¼¦íËüjfíã+”ºjVHÁ«fST…_²}ª—òüLÏÈÂ*Ÿ¼í…¨°Å>»xDä\Á"¾‡q òŒ„íÙ1¿ëú%°Ï‘ÖôŽ1Rv“05mkËñ,Tkƒ/‰ýNŽNÄÄFÁÁz3¢NKÕ¨m~‡c ÊýÄŽ l:‡ÁÍ@$6àã³úÔ ÙFc³Šàà–®[»^AÚSZY…AŸ%ஹhƒ{›’™Ñ¯|Ä̤’‚éÒ¯ò‹&8#e”}ô±{xD§TÝTt¬¾š9k#V£ÎžœÝ¸àD„@Í×7÷t7ÿZB͸xÅÍP“„ ౶NÆö¦ÅY¿%PD a›6À/N ÖÎeŸä|l×û’”ÍHï0sòƉýßej·­aÉÀVÙ[vÆ/²½0|8`¦M‹^”ñ†íÖ¶Hv?a<ò†²õG(‘¨ÿùн L¨ÖLJ@õËëDçêQi¼š –…›Ž1úŠ ™ºî'}w“¥Ä'ºp» òRó_g4‡×%¤f¹úÆ+ô2Ÿñc_ȯÐw½ní¢Çy£¿ÁéÕ]º¾«±!“©¡úcß6]½ÅÙ1ä ¥<9y°Øn;_w¶ÉTÒg0Ã^™â0Në£:|a_:ÕëÈü¡›q/á_líë‘M,®Ê7ì´':Ø9¥‹k¼~~[£¬3UrÀ?Ù~ªé†ø”ÞK|>2w?د6˜EOóм³¡—‚Ûc=nžp¹¢Ïë±½ZßÜ|‹áÏâÙᦌ}¤ž(´ÝØŒ•Ú~²} ÖåuE>,?4Ëx ]±Æv{¿vuL ¶äÚϬF±Ö ÉÚ)ÊòÉYû)wÉ«Ób?ôÚR^Ê\ñÉ^L8ƒdTË@ã éûÛË¿]¨þ—‡š¹endstream endobj 68 0 obj 4673 endobj 73 0 obj <> stream xœÅ\moÛF>ô£…ûPˆîÉ pÄŽÚ3`'®-·8À_(Š¶y‘H…¤âø~ýÍr_)­Z-{P+j9;ûÌ3ÏÌ®úå8 Ðq(þ©¿ÙêèËÑ—cšD$ˆº‘ ’ãˆÆA’Ça”ˆ¿ðÔéùÑÛóËã¶ÞäGo?FGoÿ%þszuÎ?ÿíhz~ü«˜ ¾Þ̓ƒ)#ÊÚÍDƒðu3¡ÎPý'[ŸÎŽÞ^ãFrt<»?’«@0¿°šG§Ç³ÕÑÉMµ©³ü¾ªšýçˆâ€$H˜5[<äb ‘ó«±Ó̓Ä0 õàßÅÐtæ[bIüW, Áô ‰Ü•Í„U,H"xVú¼–KJ‚õÕ}7†‚˜l/Ó¿&Œ)W›>êš0/³Þn}È›¬.ÖmQ•ûíc,ä®CìÛƒïˆcD¾a&úÚHy=¾„¸óX‚BüûÛ.PN˜kÚÙ÷!6¶U˜  ¤Ôµê¦X­—ÅYªA†S” íhdêhɪrQˆÇÓesJú# –Uó}¨²Î=øŠà±ññ€F_sÀ×Èv|YÓ†àkd« ¾¬Uÿ|°Î=øŠy-¾_ŒÜ €×ÈfxË® kd£ ºŒQçeVÕužµJÍ„ØQ3e^§m¾è>bîGYµÈ`è€ÕìÁ2ºÆbŽZ‘ Ù."kÚl•A‘µjT°œ=0½*þŽ #œq"aÄ’¡0Ù.#kÚT7²UFŽUÕj],sYZ‘€3+¨,ŠEùcWHစŒªáV–,<áa¤†Ór±ì`ED…B™ï²hVtß Q3÷|YeŸ»¹£ Áfî¢K¶o¯YسØ&ÚŸ/¦³>À“{Œé_@„ˆkG,€à‘í2¶¦ !‘­2¶V½@„ší0 ‹ˆÕc^˜1·â¾ýøûùÇ“«ëO³éÙL>ß7‰SPk±žB@•í”šÁÕfÙk€K_e!ÊC=”.7ù™x€‡÷ ¡¿€›CDª ‰Â щ#ÛemMÂÍ#[em­:ïèÅÄw€cª‘å×¢|ð!š„A6¾žÎn¯?N~¾þtéƒsLƒHó°óN„tàÖry{1;¿º˜N~{q;ˆ/pH+ÈÌru­zs¡eïO¿ìŽ!Ÿ9QÀŽôƒqqÀþøã‚ñ8½ýÃ’Ä0>¨:< <Û.Žiâbl«t\8V—­ì‘ Maàö E Æ‘i›>4ªŒ‰ÉRgôu<9¯ÏUÇAB‰V7]ù>€‡8bŠFï1ðš˜!¬ôǶËК6€#[eèXµW4ÏwèYvéñ"‹5ƒ?dÛùM›*I,¾Î,§Ëç¦À±€qÈFo ±Ö¯ðÉa0¶YƲßÀod£ üŒQ/Þ]u T¥"@n%pÞØS™-6úøÉIõmµ‹×¼®«2¯6žÃZÑ ýNGvç÷RÍ çøî^­â;À>ÀÅ{€ SýAñlÀøǧ2:`ª×BácFã€Éæ‘fíìþûRcæÒ 2OËîxŸÜšuž² NpÀ±I¤pÖE:_©zþokPBG¯z¬ :R1MØä:²]†Ü¬iêù±­2ìf­º1‰P)›D¸*¾mÖ¨B@±ÎÒM£ÊÁTmYÚf*ŸF¶Å2O©ÄÐÃoèç’Á–óê¼ÝÔe¾’ŒpÜÀbþê{¯,p5UåHÂCìÈvÀZÓ†¤ã‘­2€µVÙû&Ü’GZÖîýZ½Ì•=5=³Ö‹÷§Ó‹_ýL¸ûÜßTâ`€‡ú‘ /`3Þ)…B¶WY>|š_N½æÑ$`øõ%Ö›»'¨PDÆ/±B(U‰ÅCÐ=‚jd»LPYÓ†d‘­2Ae­zAäΟÛ\tv¥òŒB­žÒÚ={3õaò#WßÈ`Å‘íÐfuÚ<êxå®jne¶` wÌ{.Šf=Ô8w¨C^¶QNÒmBQÌù€Ã¶±íê@©cÚ¶ÁÈFu˜&Ä1j„[%CàuÀ:÷Ü°£ —œÀe°‹âš¤$‹\¹„ÄÆ%y¹x×E ‘5'T,’Ý=̓81 öL;p—+ÚÇZʾ8@¶iýT*yˆb³3ógUå0+uÄ÷täV¡D-AܤM“×­:$E6÷IÆê_ílÕ%PŒæí¹Æ СQ´lH@#ŽLÓ¨Xnê<¸ûI|4ÁQGlÚS×#y*íˆB×Sõ¦l‹U®­B¿‘¤H~Ùy˜A¤Xƒ”3ªÉ†­3ùßýÈʼn0W‹ Q÷Ào»Ë;´i’Ø®±Vÿ»§y ÑNѼÇ|i<â0`cD©@8ï>õ\ 5ò®9äÝ._l5&ºÞטlÔ¦:פï«<ûŒ9]H_Wà—·ªJÃöÄóìâüæJ•þ42ß÷EÐuZ.ª•Î¥ÌhUå÷‚PÃÝš&$‚­c\FÜ„‹Cc„ºÿ¢25 l}YÛ·-"{W¡\oÚF)ñ„›qûä\Ç^‹ù«Z* 83`RGg°UŽA Ê!}C'¶ò•r#Ä–þÂSÑÊÚ•ˆ5sƼ^×Õº.Ryüá’$½eÉ0¢b*³ñýË@âX;[ÑÌ„‚WA͸ ‘–eÕv™ª‘Jˆ i¬Õ¥"(Jú¥W‰Ý):’â! Šì» ZçÍfÙêêß0+QÍKÅGÄÍxbgQœ#Òñ×r1q»ži¹[ÒoÊj ôTüW:ˆÅ€æ>/`'óºQ ‰ÅbŒy¾ûù½õ‘-ät an+M2 ‰¸AãîÄ{¦ÔsßJº·õ °o)(ŽüB;MÈ‹¾wmÛ);{|w~óëµ·DK²¬ñ˜:w"¬[dÛQŒÚ {áÜ$¶éÅwnR•ž†5Ü*¯u’Qø‚qŠPaù*/%ºßùV;!b ¼Ÿ` `SÙJ1z7cârkY,u[Žøñîd™®æ‹t÷ù»“o25÷¿qw²È³eZ{Þpgb6%ÆÃw'«|5—ÜÈÀÔÈì0UÞ mÐNï­Ê\(Ô¨‹¼»Z…Ãéñ¯s“ {5é}Þ>+ƒ ;ë%ÀËÅ?™´¡PŠcÔ½ Ê>%š/RQæ¶B¾m}OT¯ŽÿøÇ?w×4­ëª~·;×)ªpÏâ5椦b¹Ìvz^M뇀Îî©b½¢í0™€z 8".¾Þ¯ºF¦¢ðØõõ+ ¶ NX¶í9 ¢*Ë62s‘Ï-‡•òÝ`Žm&ÒLß+Ž½¯Wºw; ȺQØ8+}Ì*†bá¡P/»°Çü¡ï˜?±·¯Ô&ö^íµ±ÉEIÕ-^ÜA±é¿Ui¸·xï=9íN‹¡÷šËéåéôÚ·õ"/Ú×.‹¦ ´XµÄ9S¦sw-¨ %E¸»2ÿA;ÜØØ#æ^ÍÀ»ÑÒst³É2Pò­Q 2ÛºÈЊ™ºWC¿énJ%˜s)n•fuåçhp7)ÞŦèE~?L9BÉs%©Õ?tÍo•3¸'rûìö㎮¿ëàªÀƒ(·Ð5õIJ±ñ7x¬#GË ‘#Õ7às¥Fúéù…ãŒÞÊ_(Q”ÀˆÝ–¶ïDdûª9²U£/x**Ì" =µï‘ÃoOr(vܘ>ï¾ÞQÈÆ„¼qœ1fÔfÂFêG ˆßS¡±®N¥h0ë- :Ä;ú³·i]Ë…aæõêu"C[Üb↶֫ý×ú6ÞTN{Á!¿’ºlÓ¢l<(óyÎ'Ba) Pÿ³σÁ™bСCI;»–É1.à`vYÄ`¹Ph ]D{]³\V»ÉéI1\¿Üy$½ReÏÕÞvK܈0“®R8ýü´)çÕ7õ.ç¼:ŠœP(Š8ã.Bgˆcª$<›gð¤Ù §,Ž\fIGw¼±û…û:•=‰[æ:¯·UýYlh“™*˜`J+L 7>£=- ÅF}šLäH›tÙT Ø¡Íâ›&¿ßÈ5‡®Oui¹÷¸÷.¸K+ó´Qu"àƒ™%öú~¨È^­‚8¿G'®æeíTØäΔ¦€6uOvѦ’dçâmQ§:uÛÒóižfŸ›w:mNÓe„l D¬A窔6ØŽ…щ=Ëäo@…,çÖÇ÷Tó´UÞ¨l’XØûõÎIŽKôÛ´8«ôâqÝw!釬Pò‹)œ4‘ê†qä„ïØgUÕª«ÂDPF}E–mÃ…ÈAÀNvó!žQ>ýª8‚Û ÏuñïÆNÕùLt ìŽk÷xî…M›]jÔVöõ°b¬^ÌA9-»Ã`8ðÆ z$>q$þ^ZS+„±‰"b•·E¦T&µàPR£gW“[l$/¥è 9¿×#èüwÿó[çÞœž]¼Ñp·ìvy«Æ”¹¸êîÿ/ê3ˆ›·½‡©T?ûí5¼Bl7ƒ/v•¢zr‚»S+I‡D>Çî£Â…4ÖK½¹=ýûjz囘ˆH;ªkäÀw %檞áÀuÊiŠM™ˆ\–leâ\¼Î®v4F³)Zý‹çn M'xä+2Õ›.òy*ˆÞ¿Ù]¡ùóº-ÌÁ0·M“oèJÎy_ß}g0@¼màméñÈs§ÎéàÍ«Ö£„y›×«¢„²P®¶ ;1 H»µ¦LÝZêBA´.êzäBmoûg¼—¬•©:¨±(½Û.åÂ톂fÞ|‰FüÅ:ósiÔ¶YÍs å»®ê«<Ò¸ÙÌM§­'V+ïÂú{:ÃÞ…a[ïÚLÿZÁ“N"6m–¸ØWò¦÷c†®ëÞ¥õî Xüûºc)zendstream endobj 74 0 obj 3752 endobj 80 0 obj <> stream xœ•[ÛŽÛÈ &oóz[°8$»yË>­Àëuff‘q€P5b–"e^vvöëSÍ®îª&9²¶AQ}©:uêTuëËÆ÷‚¯þà¿ÅéúËõ—M0=3ÿ§Íۇ뛻H=ñ2? 6‡ký…`“Á£xg±—†›‡Óõ«Ï¯úq7<ŸËóë‡ÿ^Ç‘'à …Wöׯ¾ûüªiõ\d^FŸáç×êi{A˜„_{;øüZ¿¿ âÌËÂÍ6ž”Ó‡_™>oökªgAæÅQj&§¹C/ÊbÁVªç†çI`Ÿ7Um–”f^”¤Óš¢ø[ÖÔvËyøôlµõ¥¡ÖÍ7è‡7waÊ· ²Ð Ãl³ C³À‡c9}ß÷|?1s=–MÙåCÛÝœ»þ«ÞHÔÚ­Ýòó¹kóâ¨>‘¡—ea‚Ÿ´‡É¢—%i`Ö£' b/Lí$E{:Wµ\^BCtàªö4™¶•ÈÈ Söƒ~¶Ñó§i}^’ÂFÍúúiÂÐó3ëWXs]•‘ç§"6㶸dÁ– sUÍ£6£‹ð ûòýÏoþùéý§5ƒGʃv[žz%ò˜–ygwº•R‚O…›iaäe„Ù§²Ó>“^@°AŸéýI5LòfúBàE‘ýB59jBl`,Ù6ÚQ©“£¾Õ¼ôš± b=™’Ñ$Î÷WAÒÂÓ×Ç‘Yçmʌ͵úõáØ•ÆV Y0¯GM>T d«_—NšH½@f¾qå¡íNc­­Øëäuçäußb˜qFQxÞ{ë¡oÍs{ÐH$ ÍDÞL›„h%¾zÖëSK¶Tc7½‚+Š k$_[<á˜IbÇl—{FËÀ£Àîj´ø„9Œu?¿:h(À ƒu_jõøÄ¿ÝX~~ýÆ€œbÑq£O†ò$sM^Õ#ÚÞöÛGhâ…´Ï]Yj“/Ö ‡vl´€3/#nïwÇ®ê‡ö¬íù^È‚÷Øîõþ„2;ùØë T;%þ>”å~—¿,éîÐi €uqp«c1˜AÆP ›)Ì÷R ¨«ß¦g€¡À>«ÛǪ@| ræF˜+¤,p.;…ó¼)ôæOoî fäñј<¡DT5´,ƒšû·ï>àd›|7=R˜û5òâgA‰|·ÜJîÍêt®ËSÙ úm39BL'b6= ÉG°N¹@ú°èY®[è£À“ä…w?}¼_[ž LB!§zAD¥!êÌg&=çÝPÀ>]=E>$™ˆb²j:wi’ TÆ·&­Ð™.îË¢ÚãA¥´CC‘—’A\Z‰Ö»²ž,Û«³f0p2÷S\4‹¤p=Ã6J\.˜=K‰;D³bÐѪYC³ ‘fí?my§™ ³Á“ƒ0έ˼p>Ÿd‘ÉŸ‰—ÒF\ÔM@O "û/=cÜwQe„‰MžªºF û„/qHüIl¯î1·Jzµm–Û=Ó)q¡·•®à\|+5WW… Q¤ÄùÂ5sÄ¿Á%‰ÉÔÛã Á„I›CòÆñ!ÓªËåæ' õ¡G8Çr®;/e{+Om7íK¤^F9dWûiû<·ä»¶Sáåi_€•Ø¢p"áƒæ“ ±…~[zÉa6rWžKk)È»0ƒ“ ”J0±o%ù©ï¦kê­T¢+Í\—ÆfQ7‹Zxcn™Q‹:ï{t‰OžíÊ}yÕTÓH\bÈüÔ°¡Ê•9ç‚ÅYŸàev2RÝy]ýŽR1äªe÷¼ôã®êËÂH0÷õÕVd)”§C×ZŸ9Cþ®4‘8fÀv芃ª^òÄJ ‘Ê4H5ÎÁVª;I@7|ãÄë>ÉÄí>M8‚÷F]³xZMõ»)ŽTÍc]FF hR£4Ñé¼uázøƒ§È-œU2¹<æpl-!1S³¼ã´ýtçƒöÉøq•Mæ-¨‰¼Ã•E‘α½5Öÿ¥jLß.¤â<דƒ¢†ét2&ß™ÔÉš ŽSUeÙ²ç”?£7%ïGbÔ°Êu%AŸŽU­(ù /lѲ7àcS­”]û²rd&Y†Ÿ «K./i òÖ¿‚c–׿'ròÄW:·EUWÃ3JŒ,\Šá¬‚HTά˜ËÇ¡='ú•/_­à<‹yQÿo –ƒÚŒûõÖ¤{I+øPõgM:1·ÖpÌC»$W»³\qîÊòtÆcÕ× gÍu§‚ÕÒÏU8}q,÷c$¬N^«ve¾×)^Y‰ž4"3µŸà‚ônÇÚàŸõi,JY¿Ž51OŠpî¾4²0öFg$·©Ž xGj8.—Àké¥óv”=PhJ‡˜‰ Y:ä™#ùškìջͱǺÝét ´MD%}µ7ÕPFc”MªB·= ÈŠVq'b¥œ_]ñeç±M¬92"K´Vu±ÆØ…s¡”5aÆ FÙiÂ4û„Pò£í?żM3¦S-¸E×ÖIšZ±Î²?ˆ%,¹ôTÇÎAŒZœá#Ö¬É%ò”ã/§?qsF A!cÝŒRUúo¶BÁ{z?2`Š³ÂÛ¾Ç4 ^÷ãtJœúѬ8W¡ÇÆJ?|¼¿5Ÿ&V/·§“–°1dÒ,2 Q,†G™•¶÷粨®tVÇ͸½ÄT+îþ^›¾óv¬jsbà€:Õ//ÌŒÒMX\Cõ‹J—U°ß¬á ¶©å¨yÁ’ÇcK•;Zi—Œ»FÂÜ«Õœ˜óy·Go²C"^=š!öåWµ‡•eˆ±ƒ1Éø Œ3l Ñç™?'TÕBR—ºy®ú³V®Ê"ÔÊÍO»êqlGHÔÙB¤ñ­Ÿ¹íÿfèò}U m÷üý4ªpŽŒÚ“!FìªÍÑc§ìe¥KOGDµ‚¹ÑU£ŸŽˆ : kþÝ/5ؾ2ó'$® ÓÁr ë5¶®S÷¦ÈPçÖ5ìzD*Vúü&ËjäMifý´N]ˆKS•Ù2sJ&A-Áì'…6Õùìl ³È™ ^i #Ô] {C€ 'f"@'~óõ¨²kxÿ7ÊàÛ ¥QK€2[ suÅ ¼xgÌ /7¨×íb!˨:ú 妧åP/Ñ£jQ0¬Þ€ìgš(JÔq|°âŸÀºr8n‘3uˆÉC§ÉOxØ ¸éÄ ØKGŒ¹2Š)í$õï/õîÕ£¼…üBJóPÀ²kCÔtŒiù¤ê—ã«W²r ƒSiD;:]g•Ÿ?Þþc‹,*ÕE ÷rIrWu9™}zYòLŠ-ͶÞ3C°"ùQ—z.ɬÙ÷||î«‚÷ CÁå‘Ç´ÇËœÚã/u›tÿ†Ýæ˜túˆ]›kÏú~®ÉÑ좾6cîªk>ì#~¤šðÖƒàEvÙ·¥‘E8õÌ#é ïW¨}qñÂf^c—˜Rz/9¦ÌÁk,ùGfÈØ“ô}kHž"tÛ¸§ó¨¯çè(Uy~qæÏnY­éÊtź™ö6cøµ[kN§7ìZŽµ=rm 1ïSúâHÄoÚŠÊÜqO ù8ã/u»K±¦ŽÖ.u³‹Œ9'È̦¼ƒ°ámuó3ø˜6ñsÓZúàoÕÈðXçDÒvöž…(›Ñè+%ö}¢ PÖ‘H@]¶•–pe>ÐÅivþ¹WWø *Š™ÁG¨¶™õ¹HîišÙÙØ©r¶7š> \$øJ-¾Ûäw¶k^– ½ì¬ŸÝ¾ÿ5J&{s’›d@Ïùʬ81¸|[5¹¾ ¨:ý©í”𠜂¿£QNŸ²‰„ ¿öCW ÇSiN(”¨ è‡>ªp½1Ë„f‘°M¹Á¶²ìV’HBÅ’FŸ_ È3Y‹TæZT¸L ËO1‚61ù[¨&ÝBÌKÕ_á'hž7õçÛá/}endstream endobj 81 0 obj 4225 endobj 84 0 obj <> stream xœ•[ûoÜÆ.ØIÔ é;mӦקÀGsä’ùM’eûKr¥3Z£*ꎒèÜ‘g’g[ùë;Ë}Íò¨“ –½$wç=ß̬ގ€ŒBùGÿœ-wÞnÍü˜-G{ÓÇ'4• S2š^ì¨È(æA2ŠÓ8HèhºÜy¸Ì®¿¾Ù¡4à¡`ðÊt¾óð<—k„I ¯©µYU6me>—#x˜èGmÕ½NƒÐ½ónÜ­mÓ­¦KcsØû«bÑGE ’ˆëåuy^}è–%­vYûf÷}מ½’-Öyw‚ÔíY”›„.³Ù0%ð0ˆCëu·–4Jˆáô²hÚ¼îvf°Kb_ãU&×Ò enM+Óв¤Î‰©#>/Ú¢*³EG–ˆSýìû«b>ÏËš`.¨@â äò˜Ç4HS:ƒ 9ïN¯òFI9 ·™HHûº/ò:/gJ€, BfXf?t¯'AÛ×»mEKâÖmÛB1%÷¥V*mÞ´EyÙ=ßX¹Î®²Å"//á¡bДw¬E±a­c, B'ûãó7ùL™‹šàW ÃîA„UÞ‚y®Yj¹.Jø cˆ²€n¾È´Œ@ë`6æäö*k7­Æ+9±këF}M¥ÂKí•^E$´W†d£‡y›U¬:Ã$AêLíe]µÕ¬2úJyg_ž}«­ 4ñUrZ€ýhŸŽckmŽ Ãì¤ß¤Ž¬BŠ0"1^QVJ®"`îëUV·Zû,²¬VÚÑ#÷¹;hŽÿ-W‹¼cŒIe‘[r‰ C"ÏV _pÚŵÒ4x S¬é²Òñ8&8U\TõR;t$s€%þ½ ñ£B'lº-lJ¡n­:—þ©cDH¬<³ró{ðcЬ²Aß™­Dð"k:îŸD!Κ”ã”tx0}~üd¼|¸79ÚN”¼¢€…†”ã#µK/÷² tªz¤4*¸ —V£Év ¬êj¾ÖL%Aâr•AˆÏ¹VɇÒԒ׬Ï-«¾C+©ôÙCv‘+üÙÁÑÁÉdüôÕÑþtrÜ)…ÄFJƒ" Ó0Ù´VcfùªÕîÆœQ^(Ñô #`‡ÜÆ€ÓéîÑ“Ý“'㎶Ž"—x€ZcnŸ¾Ò^ˆDv´¿¹¦Õì­ÝEÍzÄQ<"Ú ”AôŠe¬¤©ÄOòEæpa$ôªÄ¹Ò¹ ‰Õ> ±üíÚ¦è>ã$…p 8„˜Y›ÜÐP“çK}2!.K €¹!<¸Ô6çAmséºhƒÅRɺõÚ¦©fEÖêì—Ì%”¿PVÛ¯–˪;”s™†ÍN/Šfõ@¿NãÈ»Š4)¢¥½^å›y±¹†Ø» ´S{,¤\ÍG;=Ûí"­FˆEQAl½,´aÐ^Vš¾~y0>~:¨\ƒ÷°ÝźœI¸Ø±À77wg³ªžëHÌ%È$=ÔN$À¥>u@MèÜËÏ‘RÆn+Ícp‡€ =›øñ*kt §nÿÁC!Ô­òº½Ö{DÄA#¯Æ4f€×¥™Sœ¶eKæ †Ã%U„b.’Þê !¼ØqmµGýƒ xºÃóE¾„”Ú1À‰[s³™ QŠ@‚7çŠMTð¬‹E;VÉhM€–&ÿÝf\ýo Ø…”IÌš2Ÿ€£„1°ô?õ!T+έ¬c¤Uçk×y»®u ɤøÈ6âC¢ÊÔY¥Ê:ŸU—eñcv®`ŠÈ¾çù'Fîj˜3fPA­âý8íêÔŽi>R(C¬û”²ˆ 9p'ÙØÃ1• Ì2ê8ƒVí@h‘”™æ@LûÍ/>-.×*u2) +4>¦Já4L¥à¼価8MÁ7šhTç ¡QC´¦„;‡ôJE\·öÓŠò^Nž<～ ¢´/T£m¤ gÕ!Îʪ,M8£Nò—Y[t/Cäv@ÄuJH¯S"Ã{lµÖZ;³ºÌkÕ ª’»ƒ\$ Dè 5ÓÚRýH±\¾C½døk ¡PÍdBÇF:÷BÉ–t)9BÝ/dZ°âU»±‹dÜDµ4|óUÑvˆ@ÙræütòŸ£W‡ƒôvuïÝƹ3÷ÀÄî²—Fö>’ß’˜)JÌw²#¾)+íH¡ÃvÄ鎺6\cû^I]æ…,¶u,@YÙƪc¯Jçêú@n‚ìÇ,ѯٕmØZP1aò¶§Ã…¢ú‘QC'ÂXöcfaW³ŒúœËª¶jtîÒäuQ­ªPG¶É[£^Úû^œðð`ÙèZÔÊSÒ‘ˆ<õ %µjñN«Œù`„…wˆë—¼zùìd÷ Èj÷äd÷uWuúÅñÁ ½12ðƒÃµ£ÍµéxjP§£êõˇ´Q’‚µôø„Ñ‘?¢_á„‹ƒrÊ.•´Þ† \üæT—”áj—¶A-Ä‹ºZj{—Q:Å%Í ö>VºWϾÕa±^ùå;G³ÊgÅ'ºæ”Hd³ãŠâg¥¹¸6ù¡jÔñ ]jßëð%„ëZm†¯ìCQ-}“ÛBâbajº aïŽ:•˜‰ÐXþƒ<“è2`ÝŒçÞ§÷‡ÔhFBLÈnɈ‡xé>¨qóæ)°‡7ÿü³m›ó‚IŒ7ÿîÆ­iÃÖ€ýàïnë³òþ?ýÙYýó/ù‹_Ýûͯ{ï«û¿ÿݶãºñ–ä?å·rBAÐ1¼L¼ãþ }ñõçüÓYýÍ—ßüâÏ÷FúØO}J>ÿì/w „‚˜%»¦¼qaÆBä!êR]¬Hë¢úÆ,ÑÇ潬!}%[?ꉟôóumò" Eºë…"\ìz™Ç•½ò& TÈ\ܬ=8·/ æ „ þ÷õ_±â:^¢Ø{•›W·ªTšJ±dj´âóÚQ xŠy/¿õî|ɉ·º¬q;‘e¦p!®¡ÖÛ-wg·”rU¹¸Ðå€ð€Ø…½ë<ªÎW5ÔðˆÜ˜ã+“CÍ{¥ˆf°­ ùFÆ,@ªq¨çÓ‘|ï`:ú—¼½Ê‹1£®¦ë.gËë”`‘ òçl¹³7Ùy<9µõ:ßyüïÙyü\þµ÷r~LžŒ~²s0Q[ ^gé’¿Q‚«@¾‡&R¥£îô‚AÈ‹cÖ½ÌÖÉ6oÂÒ4U†¥=pa3Òeiúø@?e}äl0êŠÙfkà%Rûf¦€‘¼E½8Ów!f Î-$^åÙ ðGŠhN=¢¡fvõ«½–üÁ‹ƒÃƒ£éXÎä†8¾ ¦L=—]’„ÛËkv¦#ž¡ @fvŵ¢™ËÏjÑXØ‹møŽ „Aw £Ò 1Âztˆ4±20×a™ .îêårµnååˆGke²µÇ{7” *›LutÄ9®»3 ›Y±c«Õ™7uÞd@¢OnV»*GÞ]aÂWê4à§Â1]iR6ú£Øìuº;œ>œé 9&)¾èeÑ3ÿ1‰" 0/Q猷[þÞÚLŸˆuX˜P²a~_ ÍdDh/H<ÐMCfÕfï°F¡å·ÔãnQ‹ß)÷cÄ…ú\Û î´WS…AY¥e³YÞ4¹ºÆ%/ª…ö"{Ñ>Ðá1bö·:m”¸ m±jÍÕy¹€º{~¥€„k¢å¸É.Ìeˆ$"®W37W8ÒÞUà„ˆÄá1+.¯Ún*D‘¥ ÝœZh¦ ôx7¿¸ÁbÑG¬P°pF> stream xœ¥[ÛrÜÆ­Ò£Þò|³]E‚×¼Q²ìȱYd•¬TeˆÝE„V¸ˆa>$_’LÏLÏtÏ.HÇIéAU ˆééËéÓ~¾ˆ£ä"ÖÿðÿæðòóËωyæþk¯î^^Hó‹$‹DV¤wÛ—ö’‹"‹ª‹¢.¢ ^~]|s÷÷—ieE™Á w›—_ÛŽæa‰ª®ñ¡jævè'ýƒ,ê´(ðßéGU$ê$MðÑ`~?)£8M+÷Ú2/æ±È£¬.r÷YófÅeîŽÿÅ<‘ˆká?øI?„;Up˨ŽëDßé*)SøÍúâ*…[eæÕ»½ýd¥U™âïÏjšQ¤¬,ÜW§¥ÍËiÕ•?šÛ®3oWQQøÇ{i.Ÿ€æªÒ}BêG¥5vÝ*«DT‰{ö€·LªÚéHŽÊ~D/éðy/gw6I /›‡yTÐÙý0£@)=œ–­y7JýÃM«ú¹{4êÉàGL1j™$‘(„³ê­š·¨ÇŠä0Rd °>úÇQö5ZÇH@hÿí^©Ón]¸ {}íÚXËÑö»K#H%‰ÿ j´®œ97ºHZWNŸÝ°kiìv•åIT–Õż’Y·8Êyß˃²rÖÞ8 ?j/rVÖ”áñ¡)ËÔ›òÆj"$÷<€?ÀÉÖ@Y•¤%Ç®U ‚3ánaŒ“G3~;[_‡/'NŽvê¿Bg­oöÙ¦¬´maòÂê´ƒÍa"*c¯›Œý4ñnrUÓN ¸;òØ‹Ýš[‚·&UR<ç®döÚ¢ˆrÒÒ°E?+¯¥y¯&ç¬u|n·KDÃ*÷ß¿·JJ2o—eÆ ¸Õ¸—Ç ¥Èb/…6℈ÌNldðáå>r¯0Ò+’øalçY™—…>L¸R“>›½j ²¦`µ?®ÝZ]¦L—óÞAPM"¨qVŒ·f‹y¬ €ÁÿÌ:ëZE„Y;…1ž”>Æ?B8_¦¨œ†ƒÂàüú=@˜ç>D—Imƒ)€ƒÈ\~šT?©èã7FöÔT@ža²cºs¥±?fHæ¸lí?fñÃÆxoU†8<"ZB6pZ»´ù%ÏÀB@4àç‘áp씎iµ1¿Iž¥švBpßy”-B@D,…Š+èõêÕ(m¶”Iòí0&Ô¸@~âo@"XÆÕAZÈŠéõw<¯2Ãá ×3Þ¬)xx¢*âÌëþѺ^1ïS‚i¥Ìk´ÎÚˆ˜¹ö3Äw{«2ðj‘{á»öÐbp‚$Y~"FðùÅ„[F‡íù%5ÎN'"¤£Öø€™ÔEÙ)7%Ǭà¼ã%˜Y~:ײîÙÚÅü{80ƒZ˜”c#ñó†Tèr[LÂïB€û'¤rkuHi$’šûÈÖúx¡”j‘$$_»EGÆa–ÍÈw¿³`]W”EL‰kiDꈻ´¤49)%O¾ooþp·Æ]5 fr]BHˆ‡ ½E«P/ƒÀØ)+N2ºö¾›žûTpáþH¢C†+Koè_ß¼º5‚¦<5G ¤Åɳ«‚ý3/ÒÁÎ ˜§„„ú)Ýx¥ `'î­s€¾2€h “¿ 1*('Zè ‘t³ŒŽÂéŒío}—~!¹«‰BSÁÁ˜"7K¬²› \,ŒÇàúŠßôÅj.e~¨ÆÇsšj€ 9Ž€ø ;P ÊŸR0Øè¯z›±mh GecéJhW ÈÜ;GîZ¹Ÿ†#ØrzŽRå5?ŒeK(e()°œ)gÉbé6HOªœ¤Òœ˜×—3.6´T@3Gs,O{% Тáú“K‚rê_z—÷c*3!ŠÇA6ûóüþ`­ æy²¿E¥”!ïÕ¹ObB¢Ý*Íb$VvAª¾B¦•êáöñ9<͸êæQ)—ðrz¼­YàeAþ°oí !á³—l§#^'§—y0Ýr âk—n–yMVðÂí®xd¾ÀëÈ'Y$2Omäh \!YØBk i1.‚*;ÍÐá¡Ï{{QõòÞ PË ]J¢ã„£2Ì8>ånA0{­f « {ç%a_›ç܆:aw]»ó̪kAŸ0ã2Šz´coCXvEâ"x™Oª¡TLªaÒ¬ÝfíÖ¼´a¦Tx:x:£NZŸ0³ÄÓomßóØ"IJ!6ºvÓΘL˜•¬¿@®ç'¬æœD9f5hqŽÚŒ§4ûaòµ_L€,{ÞöÇevÜÕ<÷¨â"gÓú`M1yž¥æ±µmä(탆zÝâ¡÷+¬Ûo‚'µ Ž£:v²AûA¦ÆËÚM¦£jPÂA¬¦×Éõgl&õ—¤øf$Ö~µÔ§%ù™cû˜—ÈUŠâ´MŽ6!å‘Ç ò¸¶ë\,_t¯î¬açè^í%š$¡žÌ—Ô9–BTþ­~¤‘–Œª1À’4p•š\ÅG^ú<]>v-B»ûÉåÑ’©ä_Ó‚'îñNk7®ôŸº×õpXù„I°æ°+ú7Žd>äÞµSƒÀ³ïëîÕÇo"L\ú˜ÞÞ …}¥ç€?Ὢµv—vËѶŽŒËÀÎ3YÛMn\Áš5,é1ôŸÞ¬+r·Oý@9ÀûJ§6;[ íZÞW<Î7z¢Ù§±å3¨ÞÕ9rÍ-Ô:±…•Ž{*i½’@=:€Ñ*]s£1樮IXÔURž8X0’`ÌQ‚®+!(8+cÝ-sE¨|Õç áó`«ÙLæ(G(?l4jW¦ŽíŠJ×DÊ©‹Ù×bÖW"bŽ¡ë#4›oí9ʧŠuîGkA¡KZ=6*ér=Qd—OžìOG·¦šÊ7dbV^ì]í\@¡/‚¶Û§¶wŒô ùøÛn”Ž:Tñ28+óÀó]5}§šb8`¸*jñßAÅ:GÌÅ“P(tŠ¬hØ(x‚ʪVKYóÍùxN¹¸så:ë;­ñ‰î”¼I§n´|L ^¥'rç ¡b]†fߺdÁ¨ïÚ\„ñ#äL—qõÎ>ãVšûé©ÏT‚Ëä•Qt¢Ì¬UÛ‹£¤QXÙŠLw0æÌ*uÀ^qÖŸÑÔ'-ÿŸÍ7à·Y ~E›M£æiê{°¬éðL/§ä‚î†Á–¾!ïžÚ¾ñ¥O+vâ)ƒ™J&RP|C\›M·:ƒ”4áý£i^!ÇMûOëdeÆ™ˆ蘱8·åÔ΋d¶JÏöÑ9½Ëœ”ü 5G|ë°æ 3íZÝí'Æ¥Ðá‡%¼ØuÐõnu6.ÖY(˜ Ë™RàNóë(ÓŠÐc+q:P ¢ßí—W ÷³Ÿè€²ñ–çƒ9g•P“±6BM]gHbÁ0]3N>Œ9;ÝÍ£ÞXÍ•÷VCm%‰ñ?„]¾Þ5Š‹µ¦*ó0ˆGgVê{qd9áÛ[¥6÷HÆ3M»ùp Y[ è—ÍÎiM·lÏ,°Ÿ øf^wÚÝ ;8+ë#a{" ÏbÌLù jæk£ê¤k ê5:[kò·r—k53lYz»v`ŽÔ4“v€r¹ýÖâ[C‹UÔâ³RíœäDvÂiÊS?|’: ‚صD¶L®ºgUŒ0 «z¾ŸÜ-:¤EîLWÑD"»ÝµãÞØ>Ëù®Âà¦Øño(”(šŠMæP=v.–Šßˆ¥~u çCTš +f6¼4ž­‚L1Ýy…ü1'Ïy{À´ Bœ®£]%±ö‹ôâ P±¨ÌÛ%†&[E»i°ÐÒÎåY¿©³ÌP?n…‹Ç™ÈùV¶4Ò”j‚ÿºð|z‚vÒør<2°ªì?3´×òp@“°ÖÍ;¹[ÚÑÖ!­._ì•Ü`ZO’sn^œûVðëß¿þÃ3£kYx´´ûY,ŽZÿFÒ ;+y¸<‡nRVyË®óE4›/¸ÍøÜ®PÅÏ_áæ§[cmÝÓ"Ý:²jšnP†|ƒ$&³·'«-}eÁ¶Rž¨7‘$°VÒzñå‰i¼þ®š9BðK©£‰ŽœóT°:Êx¾Xbg=çÞüNkê ÷#Ëä¦ùÁDmýþ+9“UñZ,0ÓÃ~À˜ežaÛ¿íÇç×Õ¼Œ½Ïhœ M¸´~?á 8y·l\©…ôgë€wËl8ÿz?¶Ó<­ò˜/¡|Øe°(y2¿•‡ó ßÎ :?'«…ÿÒ+àyVG5Oz’í=î0˜zÊðí"{׬e«©Ô<·¸¢°‹òñ0ô®KÈÆ=wVã|cp87‚ÍAûâòü­omŽ'/èÖ¯äh!Ä›'=wÞnE£•z‹7ÜX¤kú²å±·3ɸù¿Í'àü$®ªâÔì{96(jIu±ùíØ°–ÚyÔäÕ‡ö8tÝ%ꎙÿÕØ¢dßžx'nõ÷ã0˜¸Óŵ†\w“­Ú»–b¦¬—evO¤êj‰RsF]À +l‘™ p4! ŠÒõ”¬‡pú=–’MþŠ’±”ðƒ[ÑÕk‘”/_áÔ*U–ê𺦴öÞºßé‘óØZvný!ô”æ·Í~Ôwô‚ÜCˆq¡µÃÚñ¡Ü¢ÜIù !úGóø u(nw¥eÞ{D@=':ŽH™-üÃV½ß+¸‚žXÅuýùD‚þ|o— n<½eFTïýˆ´“õ>†&Â<ÌÆSijÍ£·(ßôýb+C`8l«èý9TȦ}Ñ ÕXGñ§aœ÷¨ ¦1M%n‡íü c²YË1‚L÷3ˆÃY03C³×CÎê涗PaÇåÔ·Ã&Ã%žÄ³Ó¨®j,Šä[…!ò”ƒÒ~ž¼¾~x0@¦×³ Ì£c?}n"˧tb‹n×ÀûÙ5lZñëÕ÷» }#¦Ì{}\yqú|þb“¢°U8Æg=Ë¢£k—06¶ÅÙ$3mÐÍòÔ¢Bº‚ ïm†ÐwJµ Õ±èq÷]ó=Þ=ã3²×²6ïø3$¸±^͹ñ´‘¨²üÅòA5ž Áç¿K¾W##L«¬ió§v·Çèa=‰ÕZóà²2ßÝ¡¹' 3¹ÌÃý¡› ÝÌHaY݈‡¥6‹‰»®D›ŒÒö ’˜w°’5&÷W÷;”l²³#}8w½Fâ¬ÕÝæzÿ¥ãm 1¬Øb³Åœµu°ï¤Û™d‰Á‡a¸’÷g+DqÊ CBòØóJ#Xn6£šl z¥f簧ѩ âù~ Auã.ˆm4Ó`0ˆ™W|dqÊ¡R®ý›X–ëg°3 8¢Ï³+Gßù¼æšÿNÂÙâ H÷8µØ«…#‹ÓV©¸$6?(ôÖEøÒºÑ$Ÿ©¢¶Š¢¦?¸½C™yÝ÷ÀMÞ[úø럳tó—±Ó-‹KLÓlŸý»-6%­ c!lkŒep‹Þ,÷=E°–þí2Zr¦—ƒØôÆ÷—™óÞ¶e Àκ8?Ír;Ln+•í ß z§Õq°ei8[ñݨõÌà<>¸ÓRWn;„°ûöõí ¢Š’ÁWUbHQø§>ë<J°WVò¨âS4¸;¨äv>)N'ÝíYÀÕ'2±õ•Ð˜Ö… ý;·d ZŠÏó“°ŠPý®í•rÛȧ¬#OhÕá’X¨Ç¹ÃÎ’ó褬ÿ•T­Â3úöÍg¶™ü^£Û%‚&[/I²qØÌŒ+&V‹¿f+Qr3¶vö©·,Hž•|Ùî0iéê“Ž¼;•ºÝáŸ"P³‰BÿT£ë°Ç•yÒW¢‚ùý3Is¥=* ùoL–ŽšápÍúô¹Ðe˜;üúÒGÌR"ä­ÜHôæîâç—úßfmsendstream endobj 126 0 obj 4682 endobj 129 0 obj <> stream xœXËnÛ8Ýç+¼šI„æKÕÛ¦mÚ¤Hc£LÓ…"Ó±¦²äJò¤™É÷Îå›NÜY $I]ÞǹçæÇ#2ÁúÇý­6G?Ž~LˆYóªÍäÕâhzM%¬ d²XÙÈ$LjND!¤“ÅæèøköíÅâ¯#"Å9ƒ#‹åÑñëu_c]¶z‹g¨Dº­‹º]ÖwÈlÄnãºl—ÝƬ3„ ÏÜú¨ÀR{§7X†° Œken.7}ÙM9Ö¹;#¨ð绕9ž!JÀwç¨Ybˆé(íÒj×VþsN+hîvª²iã9ËÍ‚‡³ÑXÉÁë`x=ŽÛ—Óéýý½±#QW¸=4Œ¨Ю­Oõæ)ŸrL'§àçæÈp«w „!sá³¥šºTDø€“ÏéÐWÓ;H•þ­OÉ ²7n]ôœ îV—«Ÿ’˜Á·êÖ-ʸh¢ÎP† ìÓI1ÎÌò)‘@"&§”¢L˜Í¯â*þ°11ríÌ2Í^"w;„î“yY}Ô‹`žˆ`M©MÙÚjpTä¡oj[gŽ(‡WªW-²1ç!¯4¤&ÅA9 øZu½OϽ+C·MI)CÏü¥e¯Œ+ÓëŒíuMŠ"ÔêM}WΆW-lHÌŒªl²x[gÝÖ•ýšHÆù` †²øu·ë[{òiSÄð剽7çö 'øæ˜Ü¼xI0~$87' ç!ñ>¤(¤-<€$£{…ÏþUÙ¶¡M¿²Žkßž BŠèÑeÝ4Ê”‚ ”å\¤Î Di½Á‹nW椄gço{µìëïƒjmÀ ŸS ßS4Døª°Ô¥óÍÌ;ä'0œ™ƒD ›_m¶uïkÅ9â4iÄÝòÁÅ’˜vÜDSnòüAG×zÕÔåmÝÔãƒãVžÅS+ŒIŸP`™Ÿ®y2:7jµ¢ö”SmƒFr…}Ým6;Ûo‘Ä»3[†¤«__BÞ~ŠòhRgÆy Çè#綺åy€‡ãd‘LàqñèÉÐ{רyéسÀæí0ëÓrù úÃ)Ža‘caôàH ³~tõqÑ•„À¼±Ï5‡”½£'š1š#‘$å3ºzÖÛYÚÛÈÖE&íñ¡[·Ž»X&žÐ2ôWÔ ëHü1ƒ7¹W±ß\l‰wó®N|¯Ê€oRä…-³íã8[ºâ@é>"‡f‘Lä¸åaíªÃ$@T!²aŽg13õ`†!%zúëÞ?lU?ߪÊRðs&öNóÌÝ»qnéú諸ʹWfúBÏ%4A8¢¦péódY²ƒ“Éð׎™éO9"2a¶®]I Óºu¥á2@qé‹Š#¢µS@I¥Ç£w J¢çzd™3‘ÌšµÎ¨ï&5†8°ÔÒOšqã–1ù¡Mdômöi~>=ÿôú|17PªÂ¥«ve# ±«)§ÀÜUžz³xFTN+Z7Áõ" ¦À¤oÁ®p%HDTœ ‰LØm—Þ®ÖŠqÒ»„»QIqM3ÄT§¿üÍ8Q×€àD¤]û†)¢íy³ÿ±½¡  wYCmL@úhÐ1GZöÈs¤ 8±®Z—ÀC•×÷y8žÊ)šÊõ0œa7ÿ|ܸ&‘ÎÛƒRjïË«Þ!1VWyí˜ÌrÊǵ›¬H®H$­óí”XK­ð,èÚ•“z@Ćm+åŠA¢·µ˜Ëèß— ˜I¬ýƒ›26åEéE&`ØŸ¼ûELG‚4J;òM9–·å ¼Ôˆ­0FµžcðæøËÅ›W¿òæÅ¡1ô–¼×NžKômy§¬ÊÊé"¥æxÂA3xOf;ûàÓÜku$è ¸}_Grö×5àÎs ú<¡z}¡ïæO²=éæ;0.Ý0ßm·]ïq›á”û½ ƒ>‘¡B½rÓ0‘çw½‚žr:W"ãßb$oÞ@{<"§qÓ ç!òmßÝõåæ°8‡tÁƒóówW³O®5eìÀdî%e¸ŠŠ;èÈZ·‡g÷p.À±Q¿'ºÎãâüËͱ–u<´ †ñM2š‚8c'®5hÌ1àƒ8ÍPØŽÞ£Ez³vÙ«rpÈb¢ÿTá !Ó§»'oà·øÀ¹.›•ËSR÷u³T·02–£U~uO½Ù6õêÁCˆÇaŽÁÕC§ÿKá@’(ÖÏÜÍöq[7»^ÂSW¹o„LçgÝnwãAlè—P¬àùÙÙ™««Œ¡-ž“•ÉG8©# ËÒügdpeÔѤe D(þŸØ=kïêV©þú4߇YúL¤ÒÂŒHö5y¸>ýÏÆžj‡£Ô$îl1ù|¤þYÏ…±endstream endobj 130 0 obj 1833 endobj 5 0 obj <> /Contents 6 0 R >> endobj 45 0 obj <> /Contents 46 0 R >> endobj 55 0 obj <> /Contents 56 0 R >> endobj 59 0 obj <> /Contents 60 0 R >> endobj 66 0 obj <> /Contents 67 0 R >> endobj 72 0 obj <> /Contents 73 0 R >> endobj 79 0 obj <> /Contents 80 0 R >> endobj 83 0 obj <> /Contents 84 0 R >> endobj 124 0 obj <> /Contents 125 0 R >> endobj 128 0 obj <> /Contents 129 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 5 0 R 45 0 R 55 0 R 59 0 R 66 0 R 72 0 R 79 0 R 83 0 R 124 0 R 128 0 R ] /Count 10 >> endobj 1 0 obj <> endobj 4 0 obj <> endobj 16 0 obj <>stream 0 0 0 0 32 35 d1 32 0 0 35 0 0 cm BI /IM true /W 32 /H 35 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡ƒôÿÿÿ>stream 0 0 0 0 42 41 d1 42 0 0 41 0 0 cm BI /IM true /W 42 /H 41 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡‚< ð@ðƒý=< ôÿôÿôÿÿÿÿþ×þ×þÖ[[_† P EI endstream endobj 33 0 obj <>stream 0 0 0 0 25 26 d1 25 0 0 26 0 0 cm BI /IM true /W 25 /H 26 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡Ìßõùß´ôðð¸<ýaˆ…ƒÿ‚øFy„`ßü,=­¬qþÿ¨€ EI endstream endobj 43 0 obj <> endobj 44 0 obj <> endobj 54 0 obj <> endobj 58 0 obj <> endobj 65 0 obj <> endobj 69 0 obj <>stream 0 0 0 -48 60 2 d1 60 0 0 50 0 -48 cm BI /IM true /W 60 /H 50 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¢ Ã0¿Á0ƒì#óõ‡½ÿ ÿ÷¾oïþø{ÿïpû¿ýßþáÈ9¯þ¾÷ÿ¿Þÿ¿óÃ~ø|š®ýßÿ‡ÿoîÿ¿xÏzÛÛûH6—†»b¶a`Á  EI endstream endobj 70 0 obj <>stream 0 0 0 -48 41 2 d1 41 0 0 50 0 -48 cm BI /IM true /W 41 /H 50 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡IGÁÁ G€‡Ó§Õ¾oƒþýÿÛ¿ÿÚðÁ.> Q®A‚øKô´Ap\è f€ß^CÒÿûßÿ·†Þïë  †b°kh € EI endstream endobj 71 0 obj <> endobj 78 0 obj <> endobj 82 0 obj <> endobj 86 0 obj <>stream 0 0 0 0 75 73 d1 75 0 0 73 0 0 cm BI /IM true /W 75 /H 73 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¬•Fÿòkµ¿þ¿ýÿ¿ýÿ¿ýÿ‡ÿ¿÷ÿ‡ïÿïÿïÿy°ËÊ»‡ü95_á»ÿïÿáü7wÿÿ¶ÿ÷ì=ûaéä0]Àx߀€ EI endstream endobj 87 0 obj <>stream 0 0 0 37 28 90 d1 28 0 0 53 0 37 cm BI /IM true /W 28 /H 53 /BPC 1 /D[1 0] /F/CCF /DP<> ID &«ü„¦Âÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ™Øù5!{÷ÃÀ@ EI endstream endobj 88 0 obj <> stream 76 0 0 0 0 0 d1 endstream endobj 89 0 obj <>stream 0 0 0 37 35 90 d1 35 0 0 53 0 37 cm BI /IM true /W 35 /H 53 /BPC 1 /D[1 0] /F/CCF /DP<> ID òk½÷Ù°ÑØo߆áÛ}†{xaï°öûÛÃ{ðöûÛýûÃðüýü[ÿ^°¡I®¾Â÷[k½m¥°aãÁ…†N  EI endstream endobj 90 0 obj <> stream 66 0 0 0 0 0 d1 endstream endobj 91 0 obj <> stream 70 0 0 0 0 0 d1 endstream endobj 92 0 obj <>stream 0 0 0 3 66 90 d1 66 0 0 87 0 3 cm BI /IM true /W 66 /H 87 /BPC 1 /D[1 0] /F/CCF /DP<> ID &­iÿkÿÿÿòEn[ @]a-Ã_‚4jZè, ºëK_Òá~—ÿ_×ÿýüšþÿöÿ‡·ûí÷Þ{ì=¾C ¨0{*jnA¹oÊ(€€ EI endstream endobj 93 0 obj <> stream 80 0 0 0 0 0 d1 endstream endobj 94 0 obj <>stream 0 0 0 -2 76 76 d1 76 0 0 78 0 -2 cm BI /IM true /W 76 /H 78 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ¹@2ÈqŸ„œ@õƒÐD1M ß@øA7Ó[öã ÓíïÃï|?{ßßï÷òj¯ÿÿîýÿýáÃÿß÷þïÿßû¿ýÿîÿðÿ‡þïßÿÞ?ýßÿîþŸwØ# å \Ÿýÿ EI endstream endobj 95 0 obj <> stream 113 0 0 0 0 0 d1 endstream endobj 96 0 obj <>stream 0 0 0 -5 75 73 d1 75 0 0 78 0 -5 cm BI /IM true /W 75 /H 78 /BPC 1 /D[1 0] /F/CCF /DP<> ID *ÃBïòjG@j:‹!(Ú÷ûðõ·ÿ¿·ÿÃöÿðþÚÿß· ýýÿÍ‚Žß·ú÷ïýl?¿ü7ïÿ·÷ÿ°ý×ü7ýwíûÿíÿðý¿ü?¶¿ñí~ûÿáÿ}ÿ÷ëx€ EI endstream endobj 97 0 obj <> stream 83 0 0 0 0 0 d1 endstream endobj 98 0 obj <>stream 0 0 0 -2 80 73 d1 80 0 0 75 0 -2 cm BI /IM true /W 80 /H 75 /BPC 1 /D[1 0] /F/CCF /DP<> ID &`CáɨR@îA ŽÁý¿ðíöþû†ýÿîý÷‡ïÝÿ¸ü†‹¾ÿ÷ÿwü{ð÷ÿý¯û§ÇÿÞÉÃ÷ïûÝÿ÷áä1Ÿ÷ÿpÿý‡ÿûïÿÿûü.ÿß]¯!—¤þ  EI endstream endobj 99 0 obj <> stream 81 0 0 0 0 0 d1 endstream endobj 100 0 obj <> stream 85 0 0 0 0 0 d1 endstream endobj 101 0 obj <>stream 0 0 0 -9 25 100 d1 25 0 0 109 0 -9 cm BI /IM true /W 25 /H 109 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ß_KK ¥¯ K_ÂZ_Ö¿ ¿ô¿ ý~½~¿ÿÖ¿ÿÿÿ ¿ÿÿÿÿÿÿÿÿÿÿöÿÿÿïßÿïýïýþöÿöïßíá¿ßo‡¾ÞooÜ@ EI endstream endobj 102 0 obj <> stream 88 0 0 0 0 0 d1 endstream endobj 103 0 obj <> stream 33 0 0 0 0 0 d1 endstream endobj 104 0 obj <> stream 69 0 0 0 0 0 d1 endstream endobj 105 0 obj <>stream 0 0 0 -9 25 100 d1 25 0 0 109 0 -9 cm BI /IM true /W 25 /H 109 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¨ÀlßííðöûÃí÷ûo÷ïðßþßðÿïïÿ÷ïÿÿÿðßÿÿÿÿÿÿÿÿ ÿÿÿZÿÿ_¯_¯ð¿Kÿ Zþ–‚þ´°½ip´´¿¨€ EI endstream endobj 106 0 obj <> stream 46 0 0 0 0 0 d1 endstream endobj 107 0 obj <> stream 107 0 0 0 0 0 d1 endstream endobj 108 0 obj <>stream 0 0 0 32 73 59 d1 73 0 0 27 0 32 cm BI /IM true /W 73 /H 27 /BPC 1 /D[1 0] /F/CCF /DP<> ID &ºÓþÖ?ÿÿÿù÷ÚÚ€€ EI endstream endobj 109 0 obj <>stream 0 0 0 15 97 76 d1 97 0 0 61 0 15 cm BI /IM true /W 97 /H 61 /BPC 1 /D[1 0] /F/CCF /DP<> ID & °x4·û÷øo½ÿa÷··ø}¼û>Ÿ·<$ûØ{ƒá‡²EƒƒÁpZ4 °]Ð]gØz_ÖÖ@û´°¿¥¥Ö‚ýzÂ_Ö¿Ô@ EI endstream endobj 110 0 obj <> stream 142 0 0 0 0 0 d1 endstream endobj 111 0 obj <> stream 82 0 0 0 0 0 d1 endstream endobj 112 0 obj <> stream 84 0 0 0 0 0 d1 endstream endobj 113 0 obj <> stream 89 0 0 0 0 0 d1 endstream endobj 114 0 obj <> stream 50 0 0 0 0 0 d1 endstream endobj 115 0 obj <> stream 117 0 0 0 0 0 d1 endstream endobj 119 0 obj <> stream 72 0 0 0 0 0 d1 endstream endobj 120 0 obj <> stream 74 0 0 0 0 0 d1 endstream endobj 121 0 obj <>stream 0 0 0 7 61 76 d1 61 0 0 69 0 7 cm BI /IM true /W 61 /H 69 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¹€$Ziÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿµÿï\5ÿ°»i¶–KƒØa°a-ëC‚ü0°`²õ€€ EI endstream endobj 122 0 obj <> stream 93 0 0 0 0 0 d1 endstream endobj 123 0 obj <> endobj 127 0 obj <> endobj 131 0 obj <> endobj 12 0 obj <> endobj 11 0 obj <>stream xœe“{LSWÇïzÏNnn‚m— 'ó‰ñ…š‡bT$ˆÂV`Á|/° ì6ŠoÁ½ÂSÀBàñÀæ íAÇ^CÙd8È®ÄÙí(’.m4gVÊôŒ^Vq’œ@N6FÐÅ=ÕÜ2ÁE¢u¶«ë>$‘àìK1#l(RÀ_c~„”¼8»í¤Oî•(À(q+ï–ŽY†k|$ò•ÌîBÂ{ª'f¬R©,+G½Æñ ÇÛøýÛi„]šÜ Š¦ÛçFF}ÐûT[INB„¾:íºQvaTgûi‘%NEý‰pšê†ñ¦²½V’’ëÐ(@$|9<óÕƒéÑŸá3ø‹b.õÎÁGîåVC’êæzuÄKkÜG.%ƒE¶€¦äCí-ã?<0È® çÒÆ·AƒÜ²œ»²N(™¶B2×Ôê±M ”½íÈyÝô[˜_D¿…gè4I÷×t×öÃ9x»m¢ï¾Çëƒá5fLíÎÜ:°ç>åºuÄ7•mfO.pG¥y¯…Ô¡a;ØÓ`´ÁYèVõÌÕÜìB‘3Yï}œÉ¦®^+DÿÀ}ã¨uŒ‡ÿ¸NýÊjFF-0í.5îæç ‰¦ .!Š":ݱä%‚ú®½+XàùU <ð†¿³Üß°7ü|L"%ŠOa·±cÙK„¢!óì ƒÈʧP ›NS/Ö ’h«m¨Z*ª*,fiªä¤áaSÆÅâq8{:.‘ý€Ût—†rkE±Iè*Š!yV52!jpzÜ‹B&ùÆGl(wàhåsZQX W^*tõ_rô+D¡%6ÝRÄಅåƒ-ÁÁ ƒC0ì/v‚Z endstream endobj 132 0 obj 1345 endobj 9 0 obj <> endobj 8 0 obj <>stream xœeUkTSW¾!äžck™6w24E“Ô¶ö¡õ5­…¶Ëªø¨-RÞò°DˆyļIáᆀ‰”Ç€Q¬UñAÛÕVk»:®™…ΪӇ—vuz.½ü˜›ÎÌš³Öýq×9{ûÞoïý}*4„ÌÖÝ 1[bW%©Š”¥/&hŠr‹ƒÇO²vY»\ȽÎÿõƯëDï-[’)&'#¿#¦G)¡@PÚˆÖh %ªü‚2ÅsÉ {ž_µjõÿNÖGEE)öþ{£Ø¦,Uå+Vò/:¥Z£-R—½¦ˆæ£ÕjÕ»Š|µA[PªÈÍËSæÓRrÕÊBÅ•Z¥ÕjtŠç¢ŸWlX·n}¬ªh_y©â·/UÄj¢1Še~¹:·äÿo(ŠÇl)ÖÄFk•¥;ËT‰åI»Š(êEjõG­¥ž¦â©Tµ‹zŽJ¦Þ¢^¢R¨—©¨XŠáé¡B©,ê‚`£ RðSÈ{ÂDá½ÐüPV”&:MçÒ7ÐS(‹5‡±üú1ö¾_ü·጖½F¶JŒJK™Ùˆm^A’!2âMz«õÈ°œ-BpÝë½Ù„ýÜ°}él·Àv¼‡˜°ÝbÞZÍ'èÙat†l•Ða û!@RO²O )~É^—½µàK®ýäñC4—·Xñ6·²Â”Q'Õ“t?Ê8ÔÞïqy›ÚåÓd‰ˆøè“«<Úæƒ`‘B‰Ñ‘rë‰Û­¤RBé'˜ëq&:Œ­ûÄÁÇódÛ¼ð(»BrÄÕZ߸¿Åœ.çê$Ø,©5ØL |(µÑìLŽ£3§ºÂd=>ÐcŸLú–„’gÈ£Û¿y!1»$9[þ5r6$ë ¬IF© ‘â$G¦¿œyƒÃœ0}stfÂÈ€Œæûgÿœ4"`W“HIÆ9ÅoCä+ž5ŒV Õ]Åä*íøÄ~¬d°h$ë½=™¥*sŸvDaNöÅËýðÕeBMÈLÍ"nŽ<#iûóñWá*ôhÚ_Â\ÿ£R{WE€]°v‰aŽD] g:ÈgäS ³º†,Ù躺ʪÇk@ê{ƒ­ 3îòòƃ¯'¤F'¾{+C~éÀð¡ŽRPK³ 5©*u{—^¦ë­ì¶Îb·®nnmlðfbZÀ[×ÍÕáìï«éŒøúãK×Ζ½3"ç¨5GͽÐ'¿zv@µ¡[æûÏ®DœîJ켬'w%Óc€Ïöæo—sévÚ­ñÎ/Kr«Ó Ÿc’~Î=ÿj\né;Y22‹ª]ªŠG¢IªuˆL¨±ÞM€'ÝŽùb!‚íÎÊxŸ¯ö¡ø#vO0߉ø!·Œ³¿‡Žf? ÒÈ/Îm 'k=µ‡¯òHä`n#*ŒÕFs¯’“±ûƒÁ<Õû†ä‘â¹ù?“è P¬M™‘»ÞÓÐ^ßÒžS¶œ3#ˆ¶ÛvÈîC»š­ð&Õ¸D™¤T°ڲ2¦«¬ÿXw×±þ²îbyû¡e¤<Àr'Uñ±ÛÄr?œb"%:šYVVc³#ì`l4º13äÝ¿ß]‘ÙÆÅjC.ìצIhÜÊsûz•-Ö&”â7Ó²¶nˆ¹@ÂÒdeôW ꢙ½Çë‹hƒŽdwŒGôÍÍŸþšô ÷øuùŠK¹Sp_˜;5¡Ï–½_è=x4÷ÒåD% J奄ûj‡Å+ž›';xbØÒ³’j:ËÖ6-g2É]nb†Œh®Öc‡4ÌU ÐT[,6m¹º¢p^áñ‰`ØMn¥©õš! sMèõ3©7NŒíë“MNŠ"QcÝÙÀHÛ^©ýægì?&Äþ@Hš(Éb-‚6[d5¯Š§ü(ªÑÒ70ë> ]†n.÷ÐN²I´x•vr›D=ttûI(àót¹ AyüÈ£!"ÀfkÅ+µ<ÔYÊeò¡âÜð¶Ïuú¬ݪöØ`KÐÃüü,?'àõ.&øý¼Aµ»ÜAƒúS‹)CÎAl1'æ[_âC) æ6ÃdAƒ»µ¹¹·{²cðTW¿ž¼û&Úl Á))ó¡„zsÌaÒ„&‡:§Ïvj#å\>oxG|¤ñ¡ƒ E ÖN“’}ˆ<”weS|êÁød™aVÕ— Ù ±DÆà¯xoKÕóÞfzÛ¡› Izà¡[¸—.½Õ¹ôŠúÍgZ• endstream endobj 133 0 obj 2252 endobj 24 0 obj <> endobj 23 0 obj <>stream xœ}WyTSç¶?sΩZª¤© š`+H¯Ö¡Î·uq@D* c @BBÂlÈÄì'3„!@  ˆ€#jÕçô¬­Wëmmoµ½ÕÖûÚZ»Þ>øñÞzßÛ{ïZï­÷_VÎ>ß9{ïßtÔøq”@ ïò[¿q˦9AqJ™ö½u*E´~árþÂLÎSÀMÇÍpÁâ^=y$´Ow“ºÁ‹)à|t“)@{¤q½J¡‰‹•'{ù~üîœ9sÿùÏÂ+VxEfü~ÅkƒL›èåC~¤Ê*µR–˜ü×zR­PÄEyÅ*2Ôr­WDt´,š¿mO„B–àµ)N§V«R½|׿ëõþ‚ ý㔑)Z¯@•2"ÑË_µÂk»×Yt\Šò_ (ÊgûÚÄ(U´ÿzµlCŒ&v“V˜·;%È/!M¡ ^:nÙÂ÷-^BQïQoS;© Tµ‘šOÍ¢vQ›(oj3µ›ÚBͦ‚(?jõµ•ZLí¡–P ¶S{©Ô:ÊŸZNM¥””;åF‰¨7)1õ5›Ì–O…P×k‚/Æ…Œ»è²ÔåÒøÙã„aíM—1"¦€Æîg»_ÛñZßÁ„UÎOÜ01sÒ”I×^|ýº«ÜÕâúõ›ßøx²Ûdõ+ëð|äÔ´SN·Ç°tªH=ìiâD:~ešBžÀŠÔ1‘»3Vyú§×ôK9ƒÔÖ<)aø…†ù$¿áÚËŽ¤3¢n´Wo\g&åîÓiB×áä„5½ µÁn›`x£SœOG£CMû`Örvw5#ƒ²yݳ‡ÂœL@I²µ š gÓ¥º^wH¡;WVÇ¢”ª7É óþpV!«‡Nf¤bÅ?@þ/8_ˆƒiWî"rpnwbnA N ‚œ‹ãÝZz §Ò„"X|†AÙæƒfV ¹&¦ÔP‡ºY°1¨¤¼ªª’=´7;ªíž]õêÝRœÇ ý¡¸|Rlp0ÑŦjtŠ…æñžË+v†ªb$¢ÁŒ+u‡óh ˜éÂ-8&")+±‹ƒžÀô_ß²Öeˤ¥f„PÄ‘ý É݈=Õâè½±åì"<}öL< Kþê “~Ü~ÿª4£AèÊdµs+ùgÃB˜í%œRŒE¾oãéøgÁT?Išôšó‹¥Gâ«Ax9ž—¼+ íøÀ††¡R2‘¬SìÜ„a³Ã /,ã‡ržêŧkœ¥7ÊY‘îF…Ð΄ëkHkÜ=œ eîäUæ PocÂO+­¡ˆÅãVxao©èžþ¹ïo;¬çÏH¶20EŒrM™}Zrª1±{4ÿ"·^»ÚÑ®•ÕJq>CöŸa+tÓN·o¸õüF2‡—‹q¬†¶¡zÝÙ@v$‘¥£@]ŽҜ̪ʌFôËù0¢An÷HŸ°{L£+55·«â4ÌýœÆT´ÅWü‚[Ëc,ýìðkdX]†½a®8`G‚vz¢!>W…üÐö®Ä¡Ä‹Y÷ÐÏ,DÝ‚q0éL†¬_ÒmïZÍ:A¯¦³äFc:2#]IJU€ã€åiú~ÏÃá8fcˆúìZ}÷eéñæfÛày¥ÓÌG4¥:àÃËÜ„+s“u,ß©"×Á\¹‘BFä"³Í²YQ¿ZšÿâLºÃÂLælH‹~±0þË—d?Ò5?b—€Øä] ©Èÿ.S„1*¯´V×°¢¥Í6{u³çc'žŠ'«ãí=:)äâïìì†Åí·l%j¿"#E£Ä†Ô®ŒãÙùwY(¥sÿ¢;“Ðßj "ÝMYæ‹}°ÏWs`ò£sÇŸÝ–jk…Ø ÅÅ0©áä9Ô†U(JÓ‹TE{YžÆŒRYÓŽìÔ8ݾ&­VÁº©¢éû^,ªGaš´]…¬H¡» (`a_Db/˜‚IEõøª†¾•Û¨#¨11°”«‹v[uï½ ñ›:%­{jסehnÚ’„ƒq¡’·"ö ¾fPÊYWxLH=c´ ®€Ôå3n‰?fP¸ÑšGhÙî`6ªÑmî<X ®Ìåºæ®KŽ!¿ '×$1ëòÈÄ*Z´ÝNg÷µ€¾e[‚µajIŠ<'-aîá ÏXèȶ¹]âùqùîÒÒý¹=ŠH“1,›<°ÑÁø—jÐ v1Cmý•9‡,’Fu¹±Ý-m½RQ÷`\GÈ>™zKˆDt÷+²Ÿy\aÒ“VP\4·»¡o?„àž1_L½ ¸TîmñEü#zNYÃTeQžxâ2¿¹q5ñv•´YÛ¨?“ö¡:J†‚QdCÆ­dVô›q»9^9m׃8pƒ?~;ôÓç½%[éÒÊÛŽµ5Ÿ”>ƒœe6rü`‹½ïâ4tÒpLÕÆ>¢ñû#{ÄäˆK-™ñ¡AI¾‹BíMå–6»ÖÒä –qfñ™FÙ¼yé±!2N<û¡±û ‘@Nî¿øÝËD7÷%¡ñÈ- }7Ÿì5˜×œe\›MH<âdæ—dT£Ë,d1/ »cj1Kxö½†ÎÀ´\>›À]Ljîv×T]xz-SÞ.iÖXÔµÛY-ê†P2/¬Nny‡ èg[¬¯ã}äȨì‰IÛ,Î1‚ýcÄ° VµsŠ3¾ÌTƒC¡ÇýZ£³¦Íy´Õz ¯Æ÷&ÞFL?ÐÐ÷ójuh=;âÏ u&ÓJ^M¿w2+«L¢¦°·•(üïBˆpÒ#Û¸{bTVRW\F©*³–:=Ÿv‡¿½M*MÊŒËY}˜… ž|†ÏàÕ€`ˆïÿ*!Å{°RCû/‰:¸5ˆUá‡ÌÖþ¨»wNûªO¢±¤Ée¥"•±þ¤.ý0@îo%Ö˜ï6ó‰Šv=ƒhž]dæJ3ä(»r²Cd:ÙF^j¨E=,7™Ù™bÑ/áryÄÁŽøÎŽþ¸®pÞÕÒ;†§µ§ÛÜ*A¹0qªè!—ΩÄÄ\”J&');;“h¹±8¥‚´g I(“yâéËWa·ECÛab ôN·Ž$ì±iÿÁU»ö9ÏÉ$êÌOÙDŒŽÒeΊJ+ª@–‚æœó™Ý9ý¯¾?nBl;.ųÿôÇ“)NtÖãÆ©žOO¥ÇœtÊ­‰¶­lœ¬Û ;'q¸ûgy®÷×9Jn¿M¿QNü6¬ˆHH? #8T˜ϯ6 pŸ †ŸjTyFêl¤ðh™¾ì 3Ÿ[J™E烿겞¿J¼w4¯ O´ @K]  ^£µFã’²ôa'³¸ÌX…>g9oä…Öã‰ìQºB…#£ p¨ð(]‡NÃävÄÁó ñ-xÆŸ%|.Fû2²ÖðGýêdV—¦×¢!–#ôj²Þ/&ü«†¹—פ }£Tf‚³#\¿ÚødÚRXu¸ø°£À’ƒôÈlÊ0ñ›øMwn=Þ©e: j3‘l”@ѺŒø‚±½‡”ç•¡3,ÐŒÝñ#žV¯)7 ldÈÊU&zcDyÅæj¼šÜþ­¥áfkçI“eã6“hÌ?ÚSKwç[²Q22ècꢳS q¦¾‚êÔûiwsÚP%²V•ö³¬×2½ùG7ú•¥»oÆ«µ·ÌM9yµªOÇQ )«h+!e-Ó’W’Ûê¾#Ü4L›/ðM¡†ùœ·µ»¢¢¥ÔÃ1†t~ x¦DòJ¨¥» ¬(f´Ñ˜Ì´¸¿7äP#:ÉrßñÆÀ¿üqÍ|ˆ=Hð ˜AÂ)o‰M¦‚‚‚ÃyÈ#+§Ò*…Zæ/«/bW,\½wM¤CÓw²ÍÑY›[c°JÌUe¨Œmj³v]mQûKÖ1xbìþ´M¸25Ž ÊÿÌÁ[WNÛÎ_–Xö6§ŸCý¨ÝÚÓ§krý‚·œ«i-b•©­'¯ž:õe“{“™Þÿ=H_ÃðŽÏAÔïÁ&×bø¹Æ1_Ìá™kä™ËK`™µ±¦Š=²6Õ—×{öÖ%ïÁH£>¦`l™ò¢—cÅ¥|qs=©DlO6`´4Âhñ¥f’»‹ŒÕNaÖÃMÆ\r|>9¾ÔXƒzYE;²qV˜!à’ø찘á“n¼åhºL$6ŠÆ!#'„?Ò`^ΑnZZ¾#÷:øºÀ§üüJ±@˜ÄTWµV9Ëkë´¤„HGÄ Z‘–éK”‚›è`eÖ¡‡,w'sô©àÁíZ'`º §!Z:q½!×›Äà94±Úy_<躃>÷øÏUŸcjß´X¹$::-Nµ†zûî¶Khu¤7ÇV§V¨ˆ´„¥%ìß»RAô6™[Ì Bìè7Ûyî“Gn`Ÿ5@O}s•³‰{®w؇{³7j»Ÿ\>W)Íd¾NìÈ<ÇŠî¶'6<0m½,t§6Ýr<^Ý«´*+Skã>ºû> ‘ŸÓºþÄ.iª#³:ª}s«·ñèµiý/xû®Ù7+HÒd– &ƒ ·ÐæGÀ¿ïðJ²*ÄÜƘ€UD?ð›¿s®2¢_àžÞ0ë&¸Ð¢gÛiüÎ[XFƒ Î ñy~fÙ×¹ àåŸ]à]î´Úé~ ñúø?~ÌéËÈòøNu1ù±»ÃÂv'««EIÂ+k’›¤‘ï¹*ÿVÀk?Ã̗۾Ăv©Ì¢(YQÚüÈÝ5ÍÆEØ ØFwL¯‰“&—}Òëõ?¿µ× endstream endobj 134 0 obj 4137 endobj 21 0 obj <> endobj 20 0 obj <>stream xœeWyT“׶ÿbLΧuhISIi:8t²jk…ÛÖ ‡Z”yJ˜“„¦ Hd,u¬tÐÖVÛÚ½·ímµ÷¶ÞÛ×óÑã[ë}¡÷­÷Ç[+d圳ÏÙ;û7lµpÅáp‹Ü½o÷ö=/„§g'ç¿*ÍNÌѬßèYyŠñá0O,`žä’7ȱ?>ûcïè^Û¼ð¿ÁÝ˱æaŠËáä×¹¤2E^zjZÐÈç^xáÅÿûe½¿¿¿ïaÅÿ®øîHÎOOÍñ]Å~)JΒʲ“s ^÷ `wge¥ñMÍRÈÒò}“’’“<Ç$f%gúîJÏJ—ɤE¾kžóÝ°nÝú ôìÃ…ù¾óõ ’úûú†&§f%æýÿŠ¢VnSä‘&È’SòRóÓv¤‡†ï)Š(ÎJ”g^ðâÚuÖ}L²ÕWñ*ñB!èõ¥:­¢8O—´_øWx9æMÝøüÝ©ØÂÖj.Eë.sÍ-tyý<ɼ2¹Bp’a´B¦Á{Ç]vG££~¤žíèR9©rT:ËÜjk*ì£É÷è‘óÈ9åc±ôƒ}H ‡gÕr?Û¥.´¹^Ù¿Ò̈ôà4¯…mû—Õ“Ì¿Æ8€iîÅ6e.âñ E%¥ÅP*£ÊÝ|Ð þà—µ/|ç¾äµ@Àھ÷öß“ÿ ˜ÿ×£¡ŒÝ8ÐxñßñB¼?¼ó»çÃâó"â%_ C]DQš&Üóá烅}†OݘÚBhÂÞ:Ü'Æ5ó}ù1ÎÀh˜Ã¼ˆý„1[röB($ôæ\TŒè«¯Ðø ¿üC]oÞ@öpÜÑH8±ŠäôØòàOñ§1º{ó2¦ÆÅ%f™Á+…M_;~®@‡Ôþ*MøËðp«pbç[¶©f<¸_Žiþ%WÿÈQ‡.§UÜœkÓµÝîjmŽïÚ¿ï€,.W’_žZó:íŸù ¹Ê‡íÚÒÜìNäoÔ6ÁM_ÅËПÑßts®ÏrÍÌãB‡ÑZkºÓZ/!Fõú½¥ì9½í6*p‘Æ…h`âl·ÉZ¡k7«› v ;œ-=ƒEîôÄœ‚Ñ’¿³ ~ 0U,g«7ÏXñ+n¼¢gŒ6°àø—|ÑÝÃe2oáèfTÌöH±¹Ðâ-k”5ä½v[ÀºÀîä2$r…Bi¨ÈÈÑC1ÙJOe@ }àËø»7¿ìŸô· ÀÌÄŽo3¡Éû@]žšÁ=8Ôm±Ö˜kŒàª¶×˜à8Œ9û»{œCpz+ÚÕô·|òùƒÇ…ƒú¯ S@ÿ0¨I Ù’Dx¯„ôN¶›íãg% øGáåž¡Sý]Êìfqkš-’è°œ´¸ý‰ÞÙÔDº¶R7³Ö­ió‚ìÿÉ A ¾†¯ /Vâ'xZ~uu™¾¦¦DÐÕihA‹¥°°>×çШ€°#·c$—2†Š[ò!KŸ)Jϲ·ÉÅEeíš‹t Ygç›ëëØ¿ChGu;ÛÂ-†žîÊVŸ/>¸ôÉÙüÁýÃB} mVuB·h¬¿çÔžô íb'ÿO–ö9çaé ¶iÖã{ÂñS}-£@ŸíLÝ)!Ñvë4!†?i:¢Ñ`iƒ~K<÷—àÄüýqb|UÓKóÊÃJD²r^ ª¯5BЖòɃL; e!åìù,' 1élžóý¨Ç˜ß=tÀg|æÎÄ¿ ‰EÁŸ¨²UÙÊe¦H Ék(3H@6­Æ|ôSÏ“SâÉ©™îkp¦ä£©}ÒfYg‹òrœÊ+ää uè Ä¨0rÆY± Kž!«IÂsÝ[/K®îº—ŒÀÀ Ñ8Áe›ýRÝÊ6x¿nšY2ขì›]!¸-,‚¿®b!ÔXc4ˆõe†2½.9´)ÚɺƒoÀ›y®ð d3¯ƒß9í.¼èsóLëNÎÏl4„9Bت)ÝTņ:ˆ2–8<¡‚|æ°Ïzô¬Ý®°ia›Ç²é«Ý̬1Ëõ´„5fUNÈAW­«Ô­!6ï•ØjpT9ÀÊZ³&ó‘µfQ*4RmÖz/!cÞu£ÞXnR˜ÊM`³Ýy?Šox÷^3™ûØÝóØšdæ\œïïãÿžä2˜± á¾­ù›Fö1*9úÒÐ\«iÂJýn}rI¶,foÖVØѲӊýqè}†àÓ¦¦¯Ìì‰a9ºehÒÂvš|ˆÈ¶¯ýñf̹9tmTÜ1n=_ÐØ1åŸY]c³R¡cúF=(AeÈ×ÊÖ“<ïM¸@y ì"hk2Ÿ6³9Å«ÐñJ›Öa–›å&Å:ã½;*«¡QGm–cõì®·T¨½Ú¢k‹Â>ä®·-Û¢6±äb±ÛºX)Ö{ÿ@´Ž”zƒ Dfh°6±ìŸÞ­ãÆ·çŠå‚Žsk–ëšã Mü¦Z[-ë¢Õ¬âç"ˆPk+X„i(°¾´ÎÓÌO¨².R™¬Û¥œ¥`ÝÅÐKŒw‡—ë[¼æë9ô‘PpR­,­Pù蓉`º¢WÕQ8œà ú¥mÑîâöŽ£î¶úš†³¤ÚZc3Ý=Ð66Õ!Bdí>eyBra±:2hgÚopð•;\FŠŸjRB5e‡@DÊùø ¼ã»G?‡/E¿üå‹gÂ# ¤ˆ3ÓU™ÊG+¼Çþ1<ð1гC7½·vÓ ÙEBx¥Ìãè<~’ÍêÎܳnv>ãâ3ì«·Ådç¦Äíx5mõü£ÇŸûÛÊ1]…Ó™¶fï×ß—Énæ_Õ~¿Àoöoºgzfú†?½TÖìýŸ0xóîÙ)¼q¦¯ëø©ëúð"À¦üüÊýÃgrÛ"JK¼¿ ìNëÙÚñVÓX ÏhüdAÒÀìÔ€k‰÷²b7sÀÃÝü¾Å·ê³,Yr»uÉRŠú¬<¼A endstream endobj 135 0 obj 4317 endobj 18 0 obj <> endobj 17 0 obj <>stream xœe‘]LSwÆÏ¡Ðs¢¬sšÁ9G3Â\`Q²9è@¦UüZZJgK=m‘•RZDÀ¿X*­´¥”‰|TÐ>hâˆÉâB–‘¹@¼™ïÃÅêŲ‹Ý½yž÷}òüòâXl †ãxB¾âP¾VÖ—Öq½ëÎh}œoÃ¥-˜ǹk=yF¶Ú¤ÓV˜™ôÇŠ223ßÿOÉÎÉÉaTÕÿ:Ì~ §ÓV2Û£ƒU£7²M¥ùS&/º­×ëÊ­¾š­à¥Z­Q¿9;©Ôk.0_êô:–5Z™ô¼ æì¬l¹Î ²pÌ1£AYÉÈ9Ì!æ°F­³þo`F|QfâÌJ†mÃöcÇ1vËÅò02ŠŽÅb,6ƒoÃø1¶˜ÅõÉZ9 À¾aà¼pÜ‹¯HÅjdó†MÇ÷&Å‚ic\ó£æ¬Kf‚’q¤ÅìFAÔÕðMw'ƒE<¸§S‹,ÈZë¬h¾‚j¯Ú›I,ˆ&ÐJW qUhŒŠÄþˆý/ëÇlñY€KË•í*D~¬X‚”¿žLzºëëÚèVBHyíÌmó"Ç‚þṂ‡ );¶ ï ÔËtزð¸ÿ—Yºúv\4ùùl½7aè¤Äy¨ä•Rá('Ž4¸kQ)< ÊYWROrÐã'ä-Ž.4GÂQb2 ·w\¶¹©¶ÛDäP04L'ëÂçNkØ‚sTâü"!áeöA~w¿þP¯D° /¤f!j®8Pr^·µ~í6·X™uð𮃣çWKéŸ !º@ª ‹œ_²RF!' vûÚ¾í@­¨½ùFcŸcª.„È?ŸÌ½|®Ž¤Ñùßh ‡÷‚}uÖ;”¯Ê]Ý]BÄøÝñÖïã“@‹`6J·ö˜ÄòOÊŠ $;),…‘²ùg#ß/ŽR&w•Æf·"™±îÖ Ó+÷£Mv/Ÿ?€`;H€R!5)q™7<•:MMMW¯ ™ýr‡‡†›Äo{§‰·÷Ô>•ß4:òÞlèrx(צ6ÔFúBžfƒ¬œÊ%„ÍÚ3Uå¦RƒU‡JIùƒâ§?MxÍPîSw.ýˆ"¨ßso´Æ—œ¸*Ü•²ú*‡HƒµodvlìW-¤EkMÙø´iÈ÷ã3@Ã.Ø!íÚn©p’O¸:\Ñßm¼î$^<žPݵ=B2-¿†  >%ˆÎ–£.§¡“æcoE¼ž0"çú „$2~¥dûÒà!$U^^é…"¯8¼ ˜Íáp|<0½ñoaØ?W0Ó} endstream endobj 136 0 obj 1007 endobj 31 0 obj <> endobj 30 0 obj <>stream xœcd`ab`ddst÷õqÑÉÌM-Ö ÊÏMÌ«3LÉ(üfü!ÃôC–ù·Íﵿ®ü2`]ðsªÐ÷~Áï-üßk˜‹{ç;çTe¦g”(h„…kjkë D ---’*a2 .©Å™éy j@FYjN~Anj^‰µ‚3PuNNf²BzNeAF±BbJJj H[XbNj¶‚[fNfAA~™‚†³¦‚‘¡_fnRi±Ø­ ~ù– > A©é¥9‰E˜2 ¬†FÆ&¦ B  " ¢ b l@Ÿ3°02¬f4g¬büö«†ïGG÷¬f^šÏøñ!ó÷í?-D{°Ö²OŸ0­¿¿wî¤9ýS»9L©É–ÿÉÞÕ\RÝTÓTÛ‘ØÅQó}Å,v›žê©Ý»9~¼aoîevýÇ¢«ŒßO> endobj 26 0 obj <>stream xœyiXS×ÚöŽ1{o[µ•˜š€M¬uj­³VpžGT&Add&aN ¦Â$Ìó<£8‹óì•3u ó>­B-¿Þýu!¯|êŒÿ²bÔ“àƒw ú]‚ËáDfY6JeŠˆ@ÿ€¨isö:íÿhîÜOþõÍ";;»i>Šß¯LÛäè6mþ'Æ/D* õ ‹Z9m#^xxšˆB9ÍÛ××Ï—½mŸwˆ_ð´-!2™4fÚœM[¼pá¢Ý¡>Ñ‘ÓF;m·Ônšý4'?ÿèïˆÿ¼BgûõŠ°Ã®»6ÄI}wo”ù¹íÙ~Äas„¿ã–ȧ­QÎÛ¢ƒ\¶ÇïÝâ½o§<Ôg¾û§sÇ,ÿ„ëa;¯Ðnþ‡+x­\ؽhÖâÙyKæ,ýhÙ$N 1‘ æÓ 7b±‰°#æ™X@Ì ‰-ÄJb!1“p"¶‹ˆY„3±XLÌ&\ˆíÄb±—ØA,%>"ö;‰eÄÇÄ~žø”˜K¸»ˆ Ärââ±›ØHرÄ*b 1ž%„Ä"ŒXCˆðÃ¥„5ñ1–°!Þ%ÖS‰I„Š°"(‚OÐD 1™Gˆ·ˆ÷ˆ\Â'/ô Îp6qúÇXiኹ—ƾ;öàØ/yN¼Ëän²‹üo*žúVÑŸs÷Í[ÛÞþðížñ3ÆŸœ`;áÂD׉ïX¿sú]»w›'͘9©ÝŠoÕÌ—ðƒ&™¼~ò ÁZÁõ÷ܦŒŸ"2" ˆHÑ<Ñ%´¶³~n3Þ&ϦÁæèÔ¹S·LíŸú×÷ǽ¿íýzñ8ñB±J²Yb‘<ÆÉ{ø䟦Ϝð«r"YÞÉüh¶úòõ¾Œ¹7âüTQÊ8š/ó pQØÚl#7¨s[%L(n?ΡͨUNÝÓU`3=â@ñÛÁf•rC ¾AδRÇà^9qø°@×næ gxŸYpH¯-¸‡²˜«ÂXùŽ$ìD³âÝÓErèf¦ÜcuEúâ£dŽãAÙ=·Hf*ˆˆKÚ—AËaž™QÃD¤`¤QÅ“™4ö”¹há0RfŸÙ(ɦ’ÄøÔ ]Z²äcT(˜«+N5‚B(3z³hòQQ5©¥š¼8H¢ ¡>ÉZw Ä(E@eª –«€$fis䆸ì8@GÅÆF5Eô\?vÎ8-ó™OŒM…Uz‘‰Â'&Æú çÊS¸é)·„™.ÈÕdº._é&A™pÒ¨\Si% 0Q®ÙÊ"ÐFÃêXEQ3 «B¶KìÕqØE¾&Ê-'¡ ÒPA}çyv½GHÜέâÇTr–›"Pã/ŠÃÏtÐÞaxõðËL‡ î›ý#½pçgúû™ÛOÚŒš#’Üè¦À •ÜV‡ïK0Sk²ã*Á43›‚Ù#GyÅ$Ìgnñ&/À•ÑÎâ™ÐTz‹WFæß5™.ŠIdùˆ§d&PÅІ‡±¬­c×qÀ Xü‚ õŒ—½·p.#›ogA+hõò(†S|&KÔRÁÓósÑûˆwhë:ß#U]1éÉø[8þß½t[Ìîu”0oáÝžÃا\øJ+€³OòJ(EF:H´Rင¹B¥d¹ÇhwƉ⩼Ì\èö|­-¤üšd…‡ñù©ùyÓÑäûKᘳ–£-’Tv/Ž€ää­F¡ ´­Ëgðȼ÷àÔàÁ}„+eøˆÆ’ÈÂÆ ÃfIß~?ÃhL%.´›ÅÅÙÙ' rª#­8Õ”hQåûƒ]4zA9­•“½ 8©ë =²‹âËÿ 6S)¼ën œRLz T}Ìß»8ÒÜaSR"Œáź˜ø„X”ze®[ɼƒÀ؆ìrÙ¼Ëo>@cÀü†e'œ.ìøÆïoòÀß.>¡eë7mµ"{àlñêp y —†Û¿…ãàÌs'cw‰›‚MRóºr”CKãÊ c3ñ‚Õ­§0úù¾2Ÿy_Ÿiù€n1hJFX´î×ht4_Sʨu™êBp™†‹¨Ö *mÅ[ßÀ±p&|wóW;{Fìõ”<¤tY{cÔ.lŠàÇ‚†³m÷×"qÝÖm<èÔÖ †£¬t†5AªÃ|mîk½Âv'àUvNÑ‘Üœ~‘†ɤ«Úúˆ¦Ð6òýà8¨ð <è#Ûì0Lï,ƒÔ÷÷ÏC¢Goà¡Kp¦ ðQKûEpTIKiäE²rÕÁ|ÑÁanÃM‚8gmLltd„§ ³* ™MÌ/<ÓH%‹ÖòjÈüÁ Ât§Î å&|¾Á8¨)¦\Š’ò@Í|¯¡öóäè„D¦ªµIÑò „d±–àú˜«à†Ö©{Ï.5m#j"|Ž…svô®ã|éá«ßï@š27v”kÃÊÄ%áEÚR@WšË*ÛAMziF xNôV]hj»®U‡¬þpßÒºy8ªOP©œ¼—T é‘ÍXž¤]›üFaVé•Åà. wPðÔXþ«Zƒ¡Ú\:8ãc‡ˆŠUefE‰¡‘zã©Úao7Ìï¿1V¾Ìwpµ@Jò£qÀ+}h##Ý€wN²!EŸ^Jià|ês`RméJ¨Œ"“}R••:Nšt§b>Œ ërskÅІÄQ¡,]DW“üæ4ø!o¤Ÿ÷7ö»ó•3íT?\Í{éÕÎí§\c-(Öçgº:?ÞS‚ô8œ¼3Ç0ÙDmÕÇ™À9FSM½ÇksóS´…âU¡Îè*Si]sŒ%Ð;,j“›äLÛû¢ýÕrÌ £.ì\bSªaPg¦ü[0þam— b„‚Î5T,f¾XCtžPV Ë ôüõÚ×ú] ’ÈŠ8]JP˜:Ä‚˜¢„îØMûeAà½ï‘ç÷÷Õôœw4–6pé`Ïz=ä ÷eEäƒ`in­ÍËÏ0dè9ݘ‘ ÚA—©±¶¹ÎÔ Žƒú”JUý‰ŒX š“?Ó úëfµ¿ãZ_Ä[âXßWi0ö—äÀoçëZkâBKÄeEÀ—v ðØã}õ¥XÏ Èðä1Ä°#Z"@¤~eߊŸoÛJºî]ëøz”—=ÐT8“Çúðü¨ÁîüNq§wSìíÈ£.«à/¸˜0fÒ¹e$z1Ü%èòÖÓîMsâ9a3{ñÙåÜg©Ó¾£Á?8¼¬ÿk÷@wßÑò!̣ȾøoÐú–‰„ñ *a¥B¹ƒe& –,Sÿ,ÿ'X0¸m5,׌‚{M6¶OwhgRO@©²hŨ²ˆ´ f¾E]a.A»[Sø¥ð¼.à’ §ò4dzzbr¶p"Ðfir0+åEGg‡Û¬rrÝèÜtø™»d(¨5¶4„ˆ<ƒ¥®!Æ ¹8¦:±R}ŽŽG ¤¡ ; ã‘oŸŠÓ+±2•êêjSËl^ºu<²yO›W¤%ÊjP+êj¬8׸¸Rl"ßXo›Ó¬õÞd|)èh(íôñjÿÍäF­Zµ£î÷Þ[ Ë7ièNýì}z…ƒwä1D³‘×GµëÎ:H®oyéÇ€çNjíj¥¡'·rè2LíÚ“Ìø&+SÐ.¬*Ï`fwþ³0½dèuâäD]b²ÖÏÅË=>•æ?Ó$ë’S¬AZfº>æÿx &—7xì¨:Ù,VÆDÄi£èˆ²ö²vþØÄ>gþmS«Nxmuéõ§ø?ì]]àÂSbY”eÌÌ¢ªQŽSR`£V³…Õ ­‰Úž“TÀÆR©zÞA)à3²¨(©´"ª®¾²¢¾.ª2L‚‹LÕmaPw Åªþ9Tý8…ßÌ8c{Cò§F¥j4q6Z€›Ã<šß\|äH^°ðŒ Qxƒý`eŸ3ëpÇï¤Oµ_¾:'DÒÛxlXlN< Ž"P¯‚äÛ›3‹ŠM6˜þSÍÉx'eGWR— ¤¾zü÷Ï]®"ámÉô!ï>pš>ÓÓq©¿Gîß*n ./qÀÕ y£.öÁv3ç/¯áÙ×\è‘î£À‡llåÔÃäBÍïR¦MXÍV{£™Z—‹¡v›†>ð,ÚÿgWØ6ê?wAûÐY–ðµCNfE©ªØêÒS¸Çßž‰<.H!=4ØÕó—h1ÅoŽ£.¥iÁ%P@š¢RidÑ! ¡€ö néa—=F³TÔ±´b%ð Qµê˜ëÝöÎ’ÚZqo/Ï–ÊN?ni+Äì}̓û„õµ·¯]¨Ï™²‹³°¹Ë3!/Ù™Q˜ T )Q¥JÀ-åD!cK¥fù%„%9Æ‹BYbfI®6s^¼†¿õqÈ Àë¢’Ï p””rê‘®$̦îì¶&ûŇÊÜw†¬›€[•ì¨¢)¹íqîŽú3Ðmrê±z®Rhý;¸rî·ÞèWõ䀇4ÄcDªæ¿Í¸'«‘9.w Ÿ°c….9õù›ÛGS‡bÂUº¼êd±¶5¾»Yt”Ì»;tïÀI†=ý›ÌÝÀ™SR-ÉÉ (u‘Ù"!\£âF¨(45à¼y*©öÔ"e¯Anç*"wáXœZ^ D ¼(¯%¯Ú¦¤*Óó´®Ð}/, ÍSåbýÊ3Õà&.Yø5ÒÉÖå‘ää—táîýo²}Ž…}Ä;oˆ”óø)׌sKfeâþ»©@…{Åp ìU©íSp¶5&Ê>;¡œ¡™ïp^öÇùi·Ä?í9§!FXeeþÎy2…/gv_ðûUq )J›¨äâ> Äär2¥^YÝæevô¼õnöQ–ØʪrKEvFN†A’žŸ‘ tmSE×`mØ^ñn Íß—äå« A4_nßçy±¯»üäEqÎþ²˜nЂ߿µƒ®¡Ð‚s’’“©’&Æ:@ÚÒ+ÉÆRÔÝ'ôa'ôf0<ÁÂÞÅŽ´¼åä™´2 ‚ødYB(š=¢¹ðë »I•À$æ₦¬lìÑŠ3qžÍrj0½XÕ»fŒ M$Œ`†šÓ³)–}ÙZ~ñšË,ž"(Ê(Ù !½( {Ùè¨PW´-Boêà´³H-Rÿ®üš7³«V3µšúáÎbUSþËôëNo‘" R%K3R€ŒNdžÌÔþLUÁÂWHõBèn\-É»‘#2#“|´t-Ì6¾=Ldˆ- éC“¡«ð 8Þ\ÛPÒ”)2¡ÅJª!½@‡«-!!:"$E— PǪ,Bi¢A±ÑЉ±qX™O5€uãÁïÐ !"‘]¨69(M¤„3M”4!ǘk0-’Çð¯Ñ´l]–èD@‘œ”N+qh̘FÞ?ɹõÚ³\33]`Ô籃њüxw Êeá¥tÎÀðŠ0Qû²”… “†­ÈÊ+0ª+{K[ÝW€}\(œ5'V¿£L”S¦²\¢aÕÐÛ\6èse2[ ò§€SR’c2^$5QáY¡Yê2Ð)‚>|Ë÷ÂG×pǽbŹÀÚ½ÀHU¶öô}*9ËU¨qQŽÎTÓ´MÌÛ—9מÂØ¿pá¼áÕ‚”,o¥,é ZÆ2Pnf60º+?Ñ[2RB…< ú _Ã1ðCøÎÚïfïvôw‹ÃóBc;¶|t|5šˆ¸î;íöª¬ããNüuÓ$þjË"ÑMNžHÁH”]¸VŠ&¡o„H¿KÏI¬ÈЋËufPª* N³H´È©s‰-+›í„ÓP+šÁŒO.K-eÛņz¼$]NH1)ÚçÁ½#-,Xç3+áÒ‘•<ù ÔAY˜ S&[ºÌÍŸ8?t½ÜsÌfÁõæþ‹à}< óP@dT`p…¼=×™™+6d‰‰:W—,=²÷ˆ$_΃Ê÷þWë±ì¡…ÕÃùÕð€ O¢)‚edP|i«dx)Õh46‰_T#ÿßÎCÿjÖի꘱ð-Ì~Áeœ†×áŽKë(ßàŠˆ5ˆÈ,­]Ò{ Ãótä%@ÃwŸymò†'ˆòŒIö³—Ô¹˜ý¸¨&½Dˆ¼ÐÁóãq|ÇøîÞ¼dïwpÁ‰¼:‹IR^Ò˜ßÊ6T¼ÆÒk\˜;HºJ‘ì”á¯ʶ#Éö]&fV³Öݪ­n<…{°yÒÈ,Ü@H°S£vÆȇ2圭.ÆT ?N½ÌIÛ'A¥¬&%îJùçå\¡¡‰ 2ëÍÄF”ÿ$Ù3,í° ZÔK‚>}cNiqogC?¨fuU Yfd'!å¦ÒŠžukÖ:†»ùKB}4Gt+é-AlÌ’,ÌÝ{f/FÖI: Ù¥I½7ÊŒg€†’Èmä[ÞU Oç•`Ò×ë,ñ?YýÐ9…ïõúà¦^Ì/®”·½É&ß+Ë€óió§s4³› õ½ôZ«›O¡‹&æSÁMt‡tªDm²6=,ýŸ%›«*4ü: /)ঌßÏs0nʲµà$ͼ¢R²’24© :ÿU¢\•’h“´z%n'ŸJÃr#mH©o¨—Ö7u ½)˜„ß5 ÃIò§òã}EI²21ÿ•ÔlL¬´1€ì¬œ}@ý vÐæ·Ã.úŸGþÏ©æ’¸ÉoK©•:D¼è ì†'ÖY›ïAéM—Sø_Á^†Â×ßNµöÜ°þ|ã…Ùˆ³bÛÂæ°Ÿˆù_!Â.:d«õÇ·BÿðÚߢ /ÄŠ‚»û«ü3½ãСk]‡¾¼RÑ3tT|Á“§ð~‹‡üÎZõw_¾Ñë¹ÅIzÈÉOœ’@jO ÷]Æ\·ìaÆeÄŽVÓ Ç êǺ1iƒØ€²_h{™±uð ÷|´Ž5ž1ßüéÁEø.€64´[Ç!z{ñ,dƒ&ÞY‰3=%ݧÄ>h9âNCŸ„ëc…ð,3AbS5‰ÒÈ#j@¯u¿ß>Wr¡¼FRj©.¬ô—ýËÐ*‰/‹…'ý  «Ž¨o¬©®o ¯ •Œêt=­ÏÀØáÃ*ÁlÒ­y?Ÿù˜l€‡xŽd(:ÄC"²qôCûá-8†ŒAÖÖØ20Ðâïæàeç)Þ²Ap‘­.ç6Óü+¼m6;\yx¥±÷˳£ðÀTÞãÀ‹Ï¹Œ¾/PçqR'"”DÂUpÓWßv>D?¬xø¡ËþèÃGÄÁÊà¸Må)®¿¶5ÝôÓsNËW{Ì_¾X‚¶ G^cMï¢rT¢¹¿ü‰>ÿÁÐÿ¦·ARÿß Úá@³ü'¦›¢ÌÿLc…ÿ_­g1ÚÆ|}Á Ö?ö»ÃŽ|æÁ/çAezU"Í¿y)ºÓi‹õr§ëe±†ª#âв8û˺RÐ}ëáãšî£’£Ý5Cà:84¬1¶B^äi¦ùÏn­n?mýdçÙ<ã‚ýÅ¡2exôSª°ûnóe@_í÷´÷WúGDHBC¥Ê­‘´š¥ýáøÕ1Fá÷^ï~ÄcÓÒ€Ù£•Âoÿè/3»Ýk¢O•W^–¶ÊîG^×<?€ŸŸ×^ª»ÔÐvg(±Dø†Øf_aV[¬`ó£5ÙQkŒðœIâ=)t}Ä‘·¶ •áÊ×W(þhÛ{(™„Éð%½üý$pÍsnÚ,¸w¬¡¦}àö—­£S]8ùÈ«%¯}Ž…WìoJˆ~f_P·®j[áZ0|¨¶•í–Ú‡úotÌgO¢jgÎ=æÀG·¸p;󙺒%Xæô†Ž¯„‰eŒ6%ãÍD¤ÍHÇÙI¥d§å5u%«»Å:rj˜CÏݽnulœ¡"T\U€»¥0UB„ßÑÈûOïÔž8.è/?€;òÇ=ûœ*Ñ[å=Ï„ÿšµ±}âÿ×mb¬…Ùg.²á­go7äÿ¬lü‚ø?ʘÿ¥ endstream endobj 138 0 obj 8179 endobj 41 0 obj <> endobj 40 0 obj <>stream xœ}Wy\Wîæõ(  mK"î4ž€(`¢âF@䈀x ¿€€ \#7 ^áP4bðBQ; ›¨!&Ä5è¢cÌFQãºjóÆÝ}3 Ýæ÷sÿãMW½ª÷ÕW_ ÊÂŒR(ƒC}üü‚g;ÏNÒ¤ÄE§!Ú)Äáfâ_̱®~žúü´rçðÁ%6píMÐ †„7(s…"u£nvRrfJÜŠØ4{ÇaNÎÎã¥_&OŸ>Ý>2óå{ïèÔ¸‰öcÉk¢ã“’¢ÓÜígëøø¸åö+â3“cSí#¢¢¢£Œn¡ñÑ«ì}ââã’““ÖØ;Îv²Ÿ2iÒä ¸„HMª}`Rb’}€ý‚èšøˆ”W~¤¨u#<—&- JŽöž“²Â'5voÚBÍÊEþkBâ#&¸Ì˜¨h¤QÔj$5ò¦\¨`j5‘šOùPc¨ÉÔXj!åG9P‹(Ê•r¤B(7*”šKM¥ÆQaÔ;T åEÜSvÔÔ("eAÚKff[ÌæÑæ÷,|-””•  èú3ÕT•0`þ€£c^²ä,Ó,O[±VYV-Öï['Z—X·[ÿ÷œAâ^5‚ °G0‡tQÏþ†jËK«« J39œ‹2 ´y¹åÚZî7ƒÆY:‰að!ªÕ–çåj 2ÕØ ï5´é:p EPˆÌžÁÊY’L’®ŽAx‰¨WâdŸ­ö5h”ñ²Ÿœ%™¨” G9‹×"  E¹nQö¾%$ 6•"¨l™vp§²ˆ¹ÜÓÞˆo…£ŒÞ³ž[éöp؆ºŠí*æà' {uGìŽòú¢ÝéõkªRøæãh)-…ä¥èªoÛ”Àsç«™ö# Ù‚¨âêlHVÿ"¹4‹+E+–¹z82Dd‡‡9Çoá!÷&‚íùóu‡Nq úíµ|¥JWPž¯Ý¸©°P¶,0Õ‹WaÅ{ÝOÀìJ7˜ýt)"´„Û’µM[Å«ªJËk¹;4Ó¬ï­@†:î¯åYADJy þÊÂdxª,3h vwÀêo‡* ×oØ´^Ë-_å¥ ä1Å»wä>Q‰nÈà&°µ¿v~ó€Àw2 D2ÚÁMÁü±ÀÊQIFÀö€ŒäÎÐ0b,iVV“%ƒFƒ CE Œ¢[ù¦œC±Ç"ëçñ¡*/z„«“³ë½°ÕT¨BéÍ’Öt»ëîÝi#8¬}¥,!²r%¾b5,@‚l'úZûB_ŸÙ Ü8<¬/B¶ðSÝÁ†„#<ÒI‰^@õ,Œ G™¥ÕÆ–Sƒ-ݯyáx DÓÌ ÅÉhPUm2à žôkra^ˆ¡à&MK|²é—Ú/ضe: ˜0«PV~áÚ<]a ×o9K'è L+«¬25…/¬FLS˜ú¤Ùn_·nwZ©vËæR^UY^^Y^T–UÍ­Þ¥)OäóK“\ÞU1è?“R€ÛB$ ²eˆp“e®_Ýçe‡•.° «îŽegëþóÍfißE¾j’œ„0B'ù¦šCM*æÁ¾Uû…aäÇVš¹/Q÷áùõi4žy†½™°ÓÃÃÅŃ°³«û'G_aB†˜jÜ}²&èsóú¡‡ N´÷Ð×áþ'd£Wô9½vkšm™Ñ¢·È²Ì¹ý±áÛØ9y-{?¾6¡!“kÈjÐv~Uô©vOî§95)|š*Ô?ÊUÍ”¾ãÓÔ•ÒL@UaùZr6V•›FÎF¾³I¥+èÏbNfµ“žUÞ8såPFcüNnÕΘŠ R×ò¢-šj°¦r]ÍŽaÇÏèºr:1ücõ–ìRmeŸÈwÐÌh£Èç®ËRoè#Ë#Þ2UoDJì!:"{»þÃÞ“NKÈò–ôöp(CU­ß5Ôœáß>ÆïÒ~’QŸ^µÚ4ÛÂe2i‹ôåý.[Ñuÿ6— ˆ´ ÅjÐõňLã7›*UÂ’0WbO„ÜÂ慨–$+Í€IMÇïhùœoWý4­sœ¿¶Wß“\= ÆتY0î¼2o®{˜‡Qoå @Ç: ¬4ÖO´$=óŒèZ4[-%ŽCe÷rDF®Ž- #j7Úõ ç.Ó|[Ãw'„#MÍŒÛ|gdÉââ¬m…²ÑúP_T–kêÓ\šyv8|Q­¿???-²eÒĹC»“&IDFb2D+LK1Í]¸-š”àÇ«/?v’ƒ¯ÆËšœ|œùeØçÏ6´~¥fÒüûtM¬~¬€¨¶­d¦O%k—Á‘ö]ºÔ_‡È8Á¢;ßµßåÄùøŒúEh#³Á£Ú÷M…uÿ6î4à.À RÒ.%³j†]¾®²z[™^ ÈðFv—ÁÝ yÝÒ! KÓm—ɲ œŒ´rÒ4˜“;e"Ɖôrl(àöP˜!Z)Ù&$Óƒ ì€o)3·”í²h²m^@0Ó`¥¼Ø'E¦in܉6MWnË0íD…E¹&Ÿ.ü š«Fb…ÑÏn ‹›7˾MUORŸgB¡‡ÅSd/`Ðc7Ùù…ìånâ·è%¡¼*hœ^m½Ó+G|wè}ÄdI¤Ê :tÉ÷´KÌûy‹Ôë6iù|ÕºòÝ–’ââõ÷»¶æU—O®\ÊyÓÁ;â?þHÄ›SƒÝ8æ‹YçÂî^üvÏ×gÕLŽÍ|~!©Þ¤;ÃOŸë<þôÄçE‡¹ÉÆ÷@Ù­6AÛÜ0VöÏÒXcÒ9u øTlTBRL̾ģœÝ×p¤)¡!ŠËï5‡ÿ_hµˆJH”>ìmjJØÛç,®ynÍ–”—ð%*]~y>ÙárµjüË€ ÚÍëù oç•Ñ}\R]ª†ž(¥×‰SëˆVÕÕ¡ãËãVV‚•5EýÜU}l endstream endobj 139 0 obj 2835 endobj 38 0 obj <> endobj 37 0 obj <>stream xœcd`ab`ddswsõ ÒÉÌM-Ö ÊÏMÌ«32É(üfü!ÃôC–ù·Íﵿ®ü2`]ðsªÐ÷~Áï-üßk˜‹{ç;çTe¦g”(h„…kjkë D ---’*a2 .©Å™éy j@FYjN~Anj^‰µ‚3PuNNf²BzNeAF±BbJJj H[XbNj¶‚[fNfAA~™‚†³¦‚‘¡_fnRi±Ø­ ~ù– > A©é¥9‰E˜2 ¬†FÆ&¦ B  " ¢ b l@Ÿ3°02¬f4g¬büö«†ïGG÷¬f^šÏøñ!ó÷í?-D{°Ö²OŸ0­¿¿wî¤9ýS»9L©É–ÿÉÞÕ\RÝTÓTÛ‘ØÅQó}Å,v›žê©Ý»9~¼aoîevýÇ¢«ŒßO> endobj 34 0 obj <>stream xœmXyTS×¾>1$çh+1’ˆMh«Õj«bç •Ieežg’„„¦M„) 0È<Ï àŒ‚µZ硶hoÛ«Õ×jï}݇nÞZo{ï}ëÝ»VþÈÊ9{Ÿïû~ßïûa5…`0sº:8æ´Ä-$" n©KT„_¤|ÕjË•i;=o ýmD-Üûc«bÞ¼ë6ô–YðÒL(Ÿ`2qóŽ¨hqlHPp¼ý¢#.Ç>]²ä³ý²rýúõö'Åÿ¸b¿3 .$(Òþü%1 <*:" 2~ƒý|wxxÈ)û pqtpœ½Ÿ¿€¿eÙQ¿ð€0ûÝ!á!ÑÑQ‰ö‹v|j¿jÅŠ•‡B"N&ÄÙOÖþPÔz{G{—€ „p¿Ø¿BŠÍŽÛÄ‘§n—DùÚè´+6hw\°ËžøׄP·}‰aG’ÂýD'×NY÷™ÃÒõË–ûnX±rÕÂÕ‹>ÿtëF aMK‰Oâ0±“XF|LxNÄ.b91Ÿp&v.Äb%ñ áJì%nÄ>b5±ˆ8Bì'>'Žˆ5ÄbâáH¬%܉ƒÄvƒ8Dì l‰‚GÌ øxû¹ÄLâ}b1˜EØ‚"fS .1ø˜ClÁLV„7q‰±“Ñ?ÅfŠŠ¹Œ™À¼hµÇªµœÕÅæ±õìßÉ8j ujêæ©-ÓöN»øžÓ{ϧoŸ^=cÿŒ!ë5ÖiÖgΟ9ôþŠ÷Gf‘³šlÖÙ¼ä8r†f{ÌΘ=Êuârr›c=çàœ[k[/ÛÛ7<)ï2ŸÍ?8÷ùåH­iL¢NúÉæû·¶œhú6ÜΕÈ⥊íì&v°ÛËÞ.ÏoÒ$¸c0<É£L¨UDÞWëe`5áDrÚÁ.™t{:^ ¢[ɳp;+–m=Ìн›þÐÌ?jâžÐ*‹‚ï# }ƒ—ÄFþ)Ð')É^Y|ô4‘^Iúº­!O/€SYÐÈî^R­‹2>ˆ•¨ŽfS"X`"'ä0• IX)TÇBÉlk:EŽÑ#fEå";)»©459#[™&\Œê óÕ† =(æƒr£®WCÑIY“Q¦(@6ÊæiUƈ:Ò åi¼£$B“ ’5HÕ(óD:I®PñIIq¡M±=7Ï^†ó/ á2ú3}SqQµ–o$ñ €‘ž{‰ñåÜ9Æ,¥?âæk‹rŠUW(õ¢¸(dî”I÷\i h£` y¶¿²¤PƒÕáû„(€Žr‰‡å&#é™—R)(&_ú\Þæ.9°Gð„LÓxŠCnÉ| ~¦“ò.ͪg€GLú#¸‚ëµ+(ÎP+|Éß.ÝyÚ¦W ó ¢ÊÅ€_Siªº¼ëÌ:O÷¤ “BŸ¨=`#…æ6ÐæÕC´]þ3š-”GqÇ®.A Ö‰=[ý«»…Qç“ocü>3zG`Ùë<(¥§áݞä1&|­äÂ…çY¥¤8; d*HU< ¤¿$Ó5^’`å ?™,ÈÉ€j/Tž¢d@Stñ)|~rb¡ÐìŸÃ)—;ÌgZ„ÈÜLV´â‚´´¥Bœ«Œ”ƒÛ7p&d ÞxaðøQ!ÂrT˜S-²±Á²YÝgËé§i—®"Áµ¢v“ÞPdÈíÈÅ:I‘™† cªYVRèGr‚K‹Xh‹ˆÝ ª®ãÔÄA’#úO²™Gâ]aá”agY.ë£ëbH1Ç \÷©0‘•ÈV'&§$T ÕJó=K= ŽƒõÀ!ü Û®ƒËš–5¬9çrmÿ_~~yJ‰Ë·íÜáøŽÀÕìÛá6þ#€L î{§ÂWÎ'žê4…£Lû©ªI³‰(“”Cç&ÚúšÍí1˜ðÜ–#-¤?àæè@! ZtÊã‰`‹Z)NjŠ#•ÀôrrkŽ¼\§àJ²5´ZÙƒE1í¯Ð .€ïïúa±«Oìá#R­9’,w³P;q.· ÜÜ‚(Äôܺã¸K[ƒfO–þ×0² ’m ú3èÀõÚây¸ßúÈ+⎴æ¬ Ž°U7”õ±MmÞÇ€8.9~2z'Xezw $~p=‚d ÂÜâÇ-í#`TGé?§ï»?j•A—Ú¦ÎK+yÌ–3'èM\ïÚˆB,—YKšl¾ZõrøRÍÙ>!ÂE*®béNÜ%Pa ÝJT ‡¢VGÂX"tŽ â2äJU‚(4%„ƒè¢$sX}â ðäÂýg£¡{è$i ŸcO]ØýêßaQZ¬}&¤ØæƎ ƒ2²\PS¢,T•©¼ªÍ§æðÁ£ÑÞ1ÂUPöj}Ø·è&lW¤ì°8ªÞH®×*ŠÁ Þ„ÖM À+»àÅsÆÞÂdȰ弆'`·&«,»<‹z«¯5µ€¯@¬#ºþTßçuKÅyŠÊDìûª"%ØAMì"Á:•rKÚ;_ܨ•À= î'á+ÎëZ®ÚŸ¿ØÉ‘I²M¼êÉwí¶övÃÂÑ»žëO¿„›¸QlN<"<|ãÐÇvÑlOà——¦K×fƒ2 ¸Œüåzª JãÙi'3¤ ™\¥:Ž©XcÙuùùµhÇÆ®”–­¤N³9Í™ðcÖD>ï?õ?Ú´¿ˆn'ûá&Ö;¤7™wƘ:z.× -Ì)ÔéÂd!Ò’À#-í@ Æ0ÍHîÑJŒà ȦޡÚüÂte± TV¬ÖªÚXVלhñ‹Œßé)ü+6›£ Ar'Vòdƒ¾W›¡íiÚ™‡ê6L~T[ǤCi·s3™„ë5I—PÀ‹.ŠÎ‹Ô²m;V8Ö|*‰Åuzh¤< $Ä’”î¤Ç¢CA uô±ÏÏ×ôœt4–50z¼g›qóyG5±… ˜›[k ³uÙZ`ÊÒgçƒvÐel¬m®3¶‚!PŸ^%k¢¾c£‡s¹ÍiߨõS³<Èy‹?b­v®ï«Òé{†„yð÷j]ë@c$¢TP\â ü)×È`ïÃ~7^ ´êhäÿù‚ŽƒÉ\L™²A,Ý€©Y`¡&ÏBͼÿKÍ£ÿO –’ƒB¾åÏ»9·Ø»Œ„ ȧ LZòŤûð••)fz™Y^iFáúÛ¶œ2x Þär>Ë€óX vVVjZvvà«R£ÈÃ]° !!7Æn£‹ûצSϼ„á­Ieq œï宯 O§VɯPÉh…ž­+ÊÕ`ö9Ž…ÀU…Ý«L]W›Qn÷èËáÛCq͇ۄˆø2ªTzÔò»ë®4„¬ªÙï2ÝEK:„ëu%|Åíh(ëÔÐé ]BäI‚=J¹³ú]:R¤._SЋü»ßÅ/œüâ{ à2]’«rMæG«XÉdnŽäª·@å+œÃÊU§:«ðúp#霯,±¬W““éþÍRÇÏÞB¹¥ŽûÇš¸Ú¤¢ÈtæónêJšk›jL=à è•·ÇÔSœGÝ5Kí8ý¨^Ä~ *R€ï(P¦lµ´LAž\o¡Àƒ¼¬©h„טØ^4FûQ]qAœ5ì»Ô#Ñ/H$ðŽ V/É¢,æ<(뢷4&6mÿš9îç¢1»7³$³DeL;ZK†ŠÞÖ-„lxèeÝO}ƒ‚¾ÁÑÚ[à2u5D•FŸ>„WÁ V[-Ë$kźFï‚XVÇÑÇh!òý´vëe'áÍݯàðÀY­]­ô!ÁÕýpUŽ´QyžžÞd`::ˆ=ü,À^Êyó 6Ó¢l­Z–ªNMS¸ùz%gPœgŠ4uZú\™“¥Í¢8o. ‹ìu ¾W;ªÏ7 äʼn±eàJk¯ aç›&Ë0óï[ÍpÆ[›Ñ·kñ3þwX"Ír7–g>§ð«'EJ‚JÅn‹++侄 ioÒ&b¥üFp£ÿ«‡•o™P7Np'2I°V¡p°¸W¿‰\Ÿ+ÓãFH\$!TŠ«Ðªš­†›Y#l5Ú̪fWCF• Zê"ÛÒÞMx72¸`«Úp“ß9´åÕ×Þùjt ¾€oÌ5hp¤)0"_»3»8È€*U&KÁñßšG;š€”H•s2?Âb³é£ÇMŒßÂÿécÒ.á‚·%¥ßa”¤"ò±º4,¤Ná{Ò’#¢½„o;guôqSZ»%Þ#ÁÝââotxE›ˆ|¢.Và¹ Ý Ñ¶§ëáfÈxÐz«SPÝS8QÐ0ùÈwpßÂpKÉ–´¢4 Ruœ"z%Šå­ƒñ’€ž*‹ugtl)ÙžQ¢0щt¢|ñ äÅ[ EYE ˆ*J Zrñ]{¥dUV²ÒÚ¡Ÿy%²|lþú’œ’Óx?!…!0Wø:WXÚ…Ç£_xå=Ú<³å3ß¹ãÉÓ„ Êgç”ä৩H†Ãx ŽÈäŽé˜"…‘tÌM)—(ú%ó˜$@¹[2™Qœ”W\†i^µé;¸è©-GDúŠËé—IRÒ¥vñi†>!‰iŽÂZ¸Ë€+k²JyÈ]â>Úf¡)þ‡v­>ò.?WPg6 +J 1z–øi¤?iVš¡çi›[cð0nOé5Ü[è!PÈ]1Y0ÚHºæÊ XôðÛç䫼L<²—Y,!õ`úŸ—ózð%$¨Uš xzÃý˜ó4Í'2ó”ZÙË}ÚƼ2CogC?¨&yuˆ)Zo¿*Œe•=u›·8Çx #N*ըݡ–@¨2Ó÷î3è#㋹l¶ZX¦ê½U®¿ø0‚<'^°n°aðøG¬R\¾Zµ9ùo6¿vÚr|¿Cro6÷€kÔPpç‰à¸ø§"¬JÔ–¯ËÉÉp|5:rì òÕª°¨À#ÂBküqk<ª>ÜuF}íöЖóì¥IœÖ~¹ÐÚskî·;®-DŒ/ö®ØoŠüûrçD¬Oß3wñ“=§?úê·G!ƒhÆñ|î½cÕAÀ•ÚâÄþ-îÃßYÙ3|Fp͇¥€3ð~«†ƒ.Ïîï¾~«×g·KÔ —Az&™îeðèuœþ²™°ˆë³¯#ËÈž •½´}þʼšÀ…VúK¦[ƒ{8ßÐŽ‚ë—鈋Þ[õ ²CÖw¿€Ä¥žÒî ‚“hbÚ£Ïb´IökÖøüýap?d>¾ëô wÌŒ·Ï™°ïö®`ÉÈ’¼âÜ\M¹®,7þŠBi˜ÐòJ4TŸœ*M•eúY\®ÞHnÌI.g)ú5©ÒX ÒU÷pä9“Ž‚påy.òÔ€Tl¸îüáEçCð˜ÿë>v;–p*P" “ì¬HçuýW[Ó×€»â²n“÷²u«„h7rf¥ÐsÉKðƒIš¾þã×NæÓ»þ©ü«Nt ,NÙШ •IýÓ5Xÿ$à®eX ¿ã^UYÕ©çëÑ„N—Ýs×¹ìߤ«D”Kt–·ßRYbpoÂíGOjºÏÏt× ƒ›à\ò™ÈƤJQ‰ _Ÿ9Ý~qîÓ——{øH‚ÑÒ˜„ÃÆ ^÷½þæ뀺Ñïã$ ŠFDDI÷ÄQrË;žñùXjé³ém^1Þ;?^8I$§ýÓ¿,èöªI8VRÊÛp=ª5úAÜMÅCð+ø»þÛÚѺц¶»Ã©¥¼É¾~Io2ÛÀæÇ›Y¦ðp<…sÞ,`ã¯Î>$º9áÌ:[ІGpÃÛ/IδwJcÃ4øŠ…^ýã$pósfÚŽ¶¡¦}àÎ÷­¿8ÀÙ¯W¿=y6¦òXSJ2ïÇÚອÕ{‹·€…àc¹Cô¡(Lj Î…É<ë?–Ê:á´æ°^¨1CçF0gÜ¡gtÙrÆÆwÞãn v—ïųÛfd ߇Û_´½¼rU88x³öî+á4}ºÐqñ¾¹±Q—“—“/¼u¬Ýle@B·´8ð}AprHÈÑ£á[pHãœwìôì;SÛß"àŒùä·GžµûådB.\>†³ÑAäƒÖ¢åèrƒŸ£EðÔí!}ßkaJ ­¤í¸uYƸ,ÿ,/‰SÌq¼Y(2!Ú.0¾ùüÅò¡–a]S«¹:‹²¦¾ò„ßfÂ}ô7\èÎ.¹­®ã^ªNš¨LOÄŠ`#RfgaSÈâ§çf4u¥É» ¼p,¢–Úº)I¢«Œ„UÅá|)K‰ 8÷`ìní¹!á@ÅðÜ x ùô¹T¡i=ÏxÖIfú¨º™Ù Óž½×P0}ú³òé3â$ëå| endstream endobj 141 0 obj 6608 endobj 52 0 obj <> endobj 51 0 obj <>stream xœeXyXS×¾=‘&9Úª-i$ÑÞzµÖ:S‡Vk{UêŒ(Î £ „2yÞ ’@˜gEq¬u*jжÚéöö^ûõyß>ÜÍ}ïíèí÷¾÷.çÎw²³÷Ù¿½Öú­ñÒ(‚Á`¼þqü¦MËbglÍÌNÏZ“Ÿ$Ì<~þGzƒ~cý‡ô!ª}ã%Ï?æ2ƒoL4FÒo¿ÏŽ‡†W‰CìmŒ=$’åe¦gäGOKˆßþÎŒ3ÿ÷IÌ¢E‹¢“e¿½"Uœ™ž=ߤ ‰²Ssò?ˆŽÅ£…xÙèt¡L”!ŽNJIIM m[’05+zU¦0S$:T=-öèwçÎÙ˜™,GÇÊNʉÞxhQôúèøÔt‰0)/úÅûÿû‚ÐÌ_¿L–s`Ãrù¡”±¢Ôiq+óÒ7‹3âWçgn‘l]³V*LÚ–â%bq‘±‡ñ×QkG݉ÐE —â_¢™éÌA–œõ-ûûo¤ltÔhÙ˜M/¿ô²ë•·^966nì¹qKÆ}=>üõW#_ÍmúkæÈ©‘2ÎrÎé×Ͻþ3WÁ-™0f” &\Ššµ;*õ-ï-žáÊqôyÐIÿ9Ä ß~“‹¬+F¿ä€"s¾!ÙÈ“m6·hIíf_‚«¥îŒXQÖ~ ?CžlœÈ?å•4x\u®* Ž§7ùÏ6T]vòìq4!˜ÜIOÀSàÆ»Œ%ª;³è«¼\ê±,A|­æ€ž¯€›ì.½ Ôƒªboððdò ˆBQv]ô|Z¤[g$Ð`ð¡ §Cß äc¢m¬qt½/0»;ÂOOáúŠ=ö20üy'ÑÒàÚ:4ȨPÊ„ÉÒ\º@¢Ö«€Š5%ÊrKH‰\.É«)l¾£ð¼» A ÂñMŸƒÓdK^}v¾B)Q–hB*A•Æ£Eà@Ú‡ Ñ›RHò”O¶ÀEJ@šY6›˜Î–nܦ5ÙT–"+)Çû·èúà³³‘°ážíË(Î7t"Í-ÈÍI“)Š_¯/)ñPÑO Àd&禫ÚYS1±STŸ²ný&4Šà3˜cq$h Ìó|û¬ÍgR`´m¦è7Þ=V|×[sbðògÏtÒïÕÈÔƃz!µ-br¾Qí°i'¦V(Ú{ª¼)(ò1q©44UÍßBíçð·¿s·Æ¥Hv2>³çö7ßõB5·tWd­_¯6YMfePY @GŠýEuÕ¡†“û:6¡é(MEsg^ØúÓÝ‹­÷/ ¥ÌqÃwAˆ1†ÿFÑ,ô݈v+­e¢5 ÖKä½Yi”YÍYi³ØÌ6ó›#$O8Y)Ý>Ü]Ni9h¥ÎWŽ¡Wò>éaYôXúâŽTl“*×0`ìÕn´‚ Ãçm ÃŽWyÙåúÄK¾À] ý}K$€xÛâü¤Ÿ;Xœ_a $¾‚cºÔ’JZ+-ß^s;Ø\ÞÖDr~jªóîžøóŠsˆ+@e˜&Ì‚C@iÎ3ˆÿ ØÐq¯ƒãæžäüzL^¿?a""–­Aã’$þÆòòSµ_|½îZßYò rÝ5ån\SÎO_te.‹ïOS™Ò݆p*yãhþâê¾!½ ¯^Œâô~ ¯p«Ïø¼}€„SYèêÉä yuŸÏü:ЮêË9#<¬jä™ÝÕEþŠÓ+-RÉtÅZ·†*6:ŒÀBê4FEžºäøAÁþBßfì¿ðÊP[ˆØ3FƒESMÏÆhxEÀô.>ÙihŠYПðÃk-—¨×»¿÷ȯ7,¨ ¸=Miñ˾½-•¶-5/{„ï6?9}›:Ú¼¥xZUHvŠ~= à ÷ñ~è0‚›°A£“R«÷–U´ÁqípÕøcõgá“‹·M“nÄ—³/Z=PT6cÑŽýè}žþ¸,H4-Dqh:Å)\Ñx}ðDÛÓAf‡U òIN¯((«?~îØsu)Í„—¹-V!H'9…hæd´tN¦¸ñè×g yã– ©¹«ªÉJŽž£ “­Ya´îV°L>-Hj«Ú ƒØÞy•‡Rh3-P°úÌÕªÊôòÈ^*z]¯Ž×ÿŽØÂ2ŒX_qÈ] Yôb”ô1+Yp º ×é¾Z–Âá9²^úi'À—"†£éTnÜÍ,`éZ£èÚQàÚWvÀ…·š‰Ð^”‡fApÖo_œxö=%¯ˆ™·9{ࣈu÷!¾| Ž}ð%uêôÕ¦àGp6¡•^øL«è˜^' :¾è§§qkY8€Ýîs7%Ð¥£?f žèmñLCŽf¯JhÃ;Iò³÷ȽÕÁ¡»T½ªÒ\Æœ —Àyö÷­X»;kñfªùi±›Ýæà[íL`·ðŸÿ;óÊd4[âP2a…‘Ûc­Ê›Ášœ‰’âv ·òÔ_s¸F5ߥ/>c!ÃbÔK¿^ËÀ()¼ÿÜØ8¡c*>­ó‚ßá/i£šœpzõßïƒoùdzv¢)(-BÓ_ØòàöбÏ>¨Ë™(NæþîîÐY@VW(ò……éÂl*-#U¶  x‚7n8í¹àŠèý0"N~û¼Á‰0µÅÿ¯ÁA7ŽÿÙ:ÔÿËí8 @’„ï#Ö3´J€Z,¸.³ÙïéÆ挪M|:½q=X‘„^Z½:nÓâìÉ€Ü[XÖàsÕ/Sp,½‚9¶¢ÕôÃ6XXßѫoFtÐÑÜïYóFÞ—DÜšøj½Ç[l/.vQN·Ý Üdµ,XP ågvˆN|wëopý1Áçð2Xî6&"XÍ0¦ëv? }^“Áb³ZL”Yg5–iEMmUeMWZÓ®])’=é‚ìéÞìä–!‹ù¢#邇[´í·8×bÀP¡¹¸Ù¨ö¡1#òd› Æçð¶Ø뽦bp”;JK;ÏÃ^½±Áz |> ö´žéj¾>!ÿ²ôy|u÷‰™õÔþ²Üð“þÚŸÃlÅ‚k…Í‹{Ð?øó—–1D9ÊBC#c¹và°9lŶRKÀDrþëï»혰ùÀGì9r­Î T |Áãí%¸NÓèI\Î?»ªÄ{2Ôû 3)I²P’ ÈTISß_\§0ÛкÁaM;ÃþŒ^ö,¶)¸C®#¥ý­pÚ׿…¾KÂI3þŠøÄ$Ç~ ˜:+Ø£-jY}!©¡ F{B;÷þ£„R%ïHõ‘Ò£ š'ÔŸÊ/h»ÀEp«álw]¥¯¢¡SYÆÛ²9¹0C·Àù§Êí¾=^#¶V,HdëÂnþ÷‹Ó›g¾¹½½nµuɆ”å€\¼çÓg?Ÿ†ï|ú˜êÿòÓ#w‹;V5=³¶0ùÓ“¸e ;áT.Ç.Eó˜VIÀí*e ÒÂõj‚–À¤G—/Ü?RpbÏ%*µOÑ ÉöêêŽs-i– ,Î!H1‹Xú"½¹€ÖQèÂß,ÉS:“–ïNü8«:ñxutG0äû²³öoûY!P°~÷Œ Xó°øAŠcÂjµFHÁë- \ ž£š®º êÈnQcÊÚkÐ[³ðz«ÉµY•bØdà+Øv€/{…»NŽ k‘)O—c³YŠŒ4iÄ‹c7œí;Üý鹇ƒW:°sô©Uf‹Ê¬ ¶¢ª]!PósƒŠÆ³/ Tå/dƒ~Š5Ãð,‚¾àî/– Ï͆VÞP°½¢³­½{Æ^ò§egÑÄçJpÜ貕JLn5еIl½PÙ8¬²:¬,–{c‰ÁÚAi±ÏÛÑSy×Mp<bÂi*§ïc!ñyÚùõ±ÔeÓÖí@¯)4v§˜ºeØi¦ÉºèáÃX:FÁ>X1¼cx:W锋åÚ\À×u±Ä³3X’Œy“Ž¶¢=H´ºyeßnêìŽ;¢Çà ø¼j¨ç4ÜÄ ôʯ;ɪR°Ëm>«´[Z ã!É2I¬E¯VK$©ê}x"îò»8Œ? 9Q½}Wo€ëࢨeo ×SàÚ›ïi¸3,öšÓðm xš^Êý€Õô›Ýî¾|¥Ød´ØôFAÊŽ ;³tyzƒ×Ƭv y—‹š¬:›Å¢ãë²õ@OJª'Û›~º*Pyv­W(€¯3–”‡µ˜z¿e>b¹Úž/×GsC0·ü{0²¸â,ƒ^«‘Ë•Z qÈð”û=U(.ö8JHÛîxïYS ¥– ç1ñq°Ð[Fén´’§Øl)™¶œìjy4 P•1õtW$ÍÏΪ*hn¨­mjÎoQ«²z¤³²žÀ×Gq†è :ƒËéíÆî&ŸUT 3I†@q~ ‰¬$Ë%œ4yÙªwü9—×Q^¯(XXYX¡ôèûvùrA"¹tËæåﯿýs‰½ÄîH™HŒ½”§¶¬4„ è77èNÊ­X‰ØCæõü£1?P1?è*pX»züè`W«J\-¨É+Ét¬ù—:¿£æ`/:?zÅ)¤“0£¶¯UaFÌî27UŸSá9æ2V<šcPì]ŽåÌM»vdMRëJýNàÀÿþ·Å¯J7ÄøEì#X0½&·Õ¥ÃÜÖcve¦¡?òd+ ™@F¦WvÜ>&@¶ 'Z± `š])ké« ý2((ò2Ãy;DÿÜÁn{ͬ$4»Ò|mA8ËÊGSFêÛÄŠ5&tzl¹]‰íübµ´`ŸYî= )ÚÄ»Èú¼-o nZV9´ž€ïa0|û"á¬c °â=7v¦UŽroÛ‹€tÉã(Åh ö%Cy8Ûü{ÂÇé)NÖ:L`<ý„Ó°'‚V‡ ²GÁºj¬÷æ"³DE¤ò4)EJ1 Å_£ 8ínÊˮϯÉJ²¶÷¥ß:Ûêj4¶…z«ïÿF³q>ÃË—/Ìpˆ^¸¡¿<Åé `—bÙA1pÙ›¥ZOjy|ù›ÅKœóxŽ‡Þ‹>XßyÓUêh9ÿœËkFŸ;D‹ðK@iic»Ýît9]ð øÞ} ®‘-’šl±RU réJA@éÆš3Pz/ >ãqn–Y‹&‹Uo`}°ÜÒ<ÓÜâsº®h¬%êI˜˜X5f±ù É ´Vµ•T±ÃTÃEŠ€…pÏäŠS¥âpZeŸ ›Ñ¢£ÐFê-«˜øéAiÛ¹Žæ¿\¨¼Ï³ØéÝ!zê#¸ãN¨)pW©4š úl¡ê9—nOè8üS\J—Ú¯¡˜·Ñ`±hvë»rªq8à¡Ùhz§Á•G’¯Ýêi‡¯>H?´¨€£0§\ÝÔ]_õÃÝç9iN™‡­5bÞۉƬZNRâLyΤŒüæ“ŽüÖs…ê¾Ô×ÖöêP~§¥a0lT°zM•ZP Æ£dDóÖЛlÀ͇+J¯z0ÌŒ v¿Áa©F¯}3äU±èÑ4 6ÊkíÏQntÿqŽ‚ F ¯Ä¼ÔªõZ‹ùPz\‰·kr—ºœw5v§£ÏݙטY(5(Å‚]YÉ»W¡Qõ÷ý ŠìȯÏܸ·Â9‚K0ÕâØ¢.0¿¯ä+êÙ >ƒR“?7q¨üE­jyu Îów>×ÿÍåþÃØC{t ]»©¨pkœ:sööéÁ3'šYæÕjLVµIFmFr]š¹hùÙŠ†¾íwÏ \eù󣫥_=Í ßDÀQÃQÜO¬n Em”X VƒÍd5ðÐ#V¦™?”ÝgÀÅ0ÆÜÚuæã•Û“Ѩ‚ÿ 1^vêÒë±e„)ÈÉíi<¸mÍŽè¸ TZjbNEBeYíå–_Žß¥N õ9õùòÞ™[C§€Jyí"÷Ã;òpœ¼u´çª€óìZÏî•ÛòR·äPa¹†[¯2`,á¢C¬¢õL(bù®†%Á‚“ôË Œ“O ï^D­œ 'Õ~ÖøõuHþ0'8‰„Q±E"½Ž¢'_YúäXgyû9Ӫطsí†x~ìƹK䤌 O Ïá^éÚõþ‡y³³s¨ÜÜd9ëÓÎ>¹ÛüEÏ ª®¾Õ‡i€K‰õí«§Üì¼\aN}^S[C]KknC6…_T# FDo£8ßüý)Wøb\s[=—‡Çý þ™Ë¹)çee׉[ÂÛòê…a›üÃÜãôØæW°v”Öx•%õ”£Äá+&N¦N¿Ã \|§µØ¬Àf,QÆȬ@oÕXùJö€£ÖîW)­Zœ #ž:­@»Ä@…h÷éº; øŸßFÐS Åï,P%`ÓïbÁ­ø G·7øYqwnFªV‘-ØqH”™[màu]ïi¾ ÈÛ¶¯,°U”8aßú5+QÊçÉ!dŸ<¹'|XôüLÉp>ý1÷ÑÉ“ÿ¸Š"·.÷wÀÁo‡ÿ€;ÆÍ8ÅrÓU_ð•f8å$Œh{ØÖw}Påç¡ hÌŽ5I“s×k6€?Ê—Ö¬ªHô ;×TºÃ ÅýÝ« z'4rg²àXz53™5²`$Vú1úY»Ð*æCÖI¸‚ù”Uq‰VL@N€·™NÖ tù¯·€‰7#šÑÇ\ø*$Î^ë…Œ¦åWÁ]0 ¿VtY>¨ìÜ÷E¡‰wx±1x N&Z¸3:gmvÒÆu>åsê§n3à¼ý#ÊYµ·™ÈËšŒr˜Jö/íêÎœ¶Üê`‰‹ß‰)•Tçòª”¬äb¹BœÑ-¹A>|λ’>ñ•Ö‘X:ú„7N¢W„àÞ«ṽ—k½¯¼Bÿ%î M endstream endobj 142 0 obj 6195 endobj 49 0 obj <> endobj 48 0 obj <>stream xœ…YXWׄ) Ae@1;X;bǨ(‚( °E@QDPº”]@†ÎÒQÁ6*Øb-60&“˜ãÇQcÎä»›ÿùï.ÈŽùÌ÷?83ç¶sÞóž÷\“.„‘‘‘…»ÇŒ¹s]†Í ‹ŠŒHttнí'ÙI}»H#Töçæ??#wöýx§…ôIOhèá=c#£ÍE3ÃÂc"‚×®‹´â³`±ý°aà o&Mšdëóî‹­Kàæàµmãl  Üéd;[‡„¯±]¾n³íꀀÀÝ0ßÕ!l]ƒC‚ÃÃöØ™io;fôh¯àPÿ¨Í¶žaÃl=l® YñÞK‚Hšáá³qÍϱaK½f†.›ç²)È{VÄÚù®›×-p‹ ^8;j‘ûŸ­!«}£CýŸ0bÒÈÉ£œF;|2Ænê±öãŒês‚Aô'–ób1’@,'¼‰YÄdb1˜O¸NÄhb±€p#ˆÁÄBb61†°#î„#1„ð!æc {—G %<ˆñÄ“˜AL –^ÄLb"aEXãeúÝ ¢Ñ—èIX ‚%‚'ºÑ°$fâ8&xòF³Œîuqïò½ñJãoM&~&ȹäaj"u–îC¯¦O0SÚµ{×M]Ûºùw{iZefavó#Ïn˜›_ëÞ§ûíKz|ÑÓª§Ï_-¼,[üÆnc›{…pÝ9%÷«e„åqËV~VÛ¬ÎZ½´v°ÞeýKï!½‹{ŸîcÖgqŸÃ}þmúïxs©U¥(Ѻ‹°W4†­’†ûU©.(+M)ˆáQ“¢LLP++ùi£†ž¤Å°’ªTª”)1 4í•¢hýt`'B£h$Moî²#§ÁhÃÔAZ*iH´JöÙŒBnÚ(2Döj˜aĪ ìHÐPñ"‡¶Q@@#¹ƒÔHâ…‘—è^’™hÁ®‚zKv§ D"V6U‚aª9¨¥J²LvÒ.Ë& COÐDxB~&³  å^Ä[kF¶Ÿø©.Z”¼òahÅÞ'i7bïwÚ³7êÐS?*ºýYÕa^?ȧŠEÅ;ŠöÐîšýEGmŽ UõÖ=[J#„P Á´áF†ÁP@}ívyŒçÚè¹óìÛ:ÿlj’‘\ewõ?x/ ÒzÉŒc¿>ìï£ñ²A}† G֨ׯ£Àêæͪúó|fG¥PÂ¥¨“•ÛSS‹—{nž!0ÈhjËïÐåA tyrwµo.Ÿ›¯,˜Òu%ÿŒf4í¡V$Ò=‘7HÄaÑí²,%»ÍØච@+Ñ(XIžü°ëq<ÝP"òF+ Ì]s)˜ëaZOzÊ,¬ ±ZÙ¹­«¢dŽ¡ý |¼% µQβ‘ö2JQ{ Ov‰Ú´‘C ö{´QÁï.ÒÛGóÎRT!Žè-ÙHµã"N„@Ñè‘.²ðzˆœlèeêYóí'·V™PË_>¸÷ˆpžyì|m¨Ë ¨¢0ª8„‰ôý ~ó=½>Ï#¼µ=&öôU¡Ny0úHÔ®uÂZÆsáR  Þ¡ÒH-ÂaÑXÚˆñˆ^ãì-H)ÓEPñäÒ¨ ='×JÝZéÎ4^ˆji¸ÏÉÃP2Â>ì†÷þ¹4“Cì`;Ôõl,X¼ú ̵û õâýM~ìÔÈ„ÉL|ôªí»Goxýø^‰`-êÐø'NOs+6^ʔڸᆲg›PµìîüCÓ1ìL‡êVèÞ:L[®Ôß9ͳñc^ÐllgPØx Or…Fáh=Çžm{è4ÀÎi²½Ý¼ð7~ã hŒÅÛn\`'YM•––$ÆêðÖ™ˆÇ)d¶¢á°•<*C¤ ³Õ:Dî$QpYælûC0Õ¹&õmìïí–’¦Ž6LgoX°Y»†B—¤,²ß{A–Cj(UQÔ1rº´†‚KÚ,ÌCíaª ›¸^—Þ8*Vì#)BÊåØÖ†óªÝmf Þ›ü–¯Z6Kðb&ÒÈ°+¡ïõ«{Ï*öV—TELqjá6eúöT¥Âgî’M®ØåÝì^ƒ—ÓŸ[Áø§o}½rYq©%S¦Ëv0¡ÙGÙH·s-Œá¡Žö0Ǽ'áÍ<ƒgÃ)ö…!¸Ïš´•8`× §ó1¸Žm±Çžlt¿úµÀ@÷¿€)˜Žx†zL[îê‹?¦Ùp çÚ¾v:Òiºý)-/~ý¦å·vtÁ †âBSË9¡1C“phíwNç‡á#õ²‰>B– ›g`vº¾Ó[Zúö4%¿fÃŒ(O‚Óí„ßi,¥+r•¿Ü»Ô*´ ÍÞå£m7C8+E8鲄9º$IHPéj]?t+—†GÒ*òz…éèö¬Ò( ìÊ Ñ#í*Ò[Rt¤P>…ÆêSè>‡0úš„&þ <| &`ã`*"ÀõéÌ/ˆBÑÇÃHDlÁö9þCó2RƒEã7"'GN8\ž°?†~ƒqiä(Ü`P§cK) ÐM‘øúuÇý÷Ì|™t?Gûa 4”ú{p;ó¶UZ O9öÑÍ‹j§Ú ÃG#Sdúbtx¡öf#ríiyÙk†0·úH•M²7%&ÑÈí ®í¡>¶Cì>iyñâaóKþyÁ`œÃ=±ßªqƒù²ìœ•:×Ps×±ŒŒ}Š3*AȘuaI‘ª`[¿!ßµ P`æúÎའ›zŠžÚË|uÇeÈžvpær:Û&A‡KP?5?>ñ^?)ßKZŸ÷ÅÅ»:€°€M Óó77º¹Î\0–G}:k“ªßE ¼Ä ñq+Λ¿ðB˜áùø¬ ¤ì‡A Íþ/4Úë JËô¼Ö™þ‡½°I¾0V&ÎLÑ-ˆ£ßù5D´ÀjÏŠ½ Yº²ÀP±É©Û‹R+øôt˜á nc–”ê)Ó 6Qì‘6èR¿»Áf—P•TY ÌÎ,Ð9^]¢VÆ–ñ›vE©7 K„ea#'0ìíWÿÁ"üôLð#Ó-?ßÚ6ˆ91ˆy>È{Mn6ðˆ£Ý|¹)ðæ ¦¨s‘Šú# ÛZ{°ô€ØO3¤‰þXaâ›r{qÃjúô‘#§cÊhnùU+D‹ñ¢ô­n'8!­Øh¸„¬È} ½˜È`MѬp†¾ËÑ~OP "s”ié*AÙ{›:¥8''++Wq²äVq­°G(ÏØ—Ì° Éû‹3ÊmN|y ª$E”žž™‘·lUn…ÔìÍj†.ÌÝh³EˆÛªj:n&áþÿLï@‹‘-ÐKÉN¨t A•„ÄN¨À-œ‰2œøþNþ†Ù8ê=ù¸µÊÅ- Vì@ÉEâ8öÚu~;ØØÏX>'¤2´&†¯‰­Q6§~¡Ú§Ü›°/¾"Bˆd|ÝlÁx×#|Íz”¦ª·ág ù‰øY‡oü¬‘Åô‰ s±70ñ“ß]xP]²“ß°3¨Ø«ÀQ­ÊŽ*cX-%Iå}N^8Øüà³~yŠì¸eI‡½M³u415)V‘Þn½ØÐ9kÎSïëŒ&­feûS‘²B¯ßÝ ©âÒ¦ë5„ÞÇ…]ÊÝÑ{¶–nÒKo?Z.B5êÎ!9Ô#÷Ë#½VGz-Q@QÇúA"ºõô‘Êåð2ÖòyŠÆ3 BM†~aG?ØxF¸Á<™x«¾¬ä–©†¡Ó!HG-±0‚¾wËgÞ\§Åö<¢Ú#" ©‚®úÀ#ü\¹2ÃÆ‘¯l^þÂMëRã’9Ðñ;èËߧ…Ë5×O‰G4`gü$ÜóÏ]’›Ÿ*Sþ¿iT… z^I Ù?û-ªt·qæGú­^º<ÄYpaœi4æí ˜øåÍÊºË pn¯ƒðF‹*£WØ1^˜vÀ”:Ó}„vQÓ¯.ÿõ{ Žî/J)JNËÈLKUDºÄ.×U‡ÎóPá2qÞ)w_¿±§ËøÜÏᾎÛe‡í†ž¢±²ç¿dà+™QlÛvXÃy¸ü¦Ý›URI»'cNÁ11ê”k!Í—Ê8v¯¸Ú¯ÒÛ¦ÿ”ÙŽ«5‡"ùÚ¨ÃÛîl»»m§ª:®&¶bƒ°Žqžå3RÁÎ-8ŸÏ¸™Y®*L} Crî§Ù½+ÄË·mÀì‡;­ç#OT󡚰©¥žE…›*"*j„ÌÍ«g+X‹‡ÂU¿Üy:iö.¯ U"š–·÷EØ…‹;& ç#Ãp?CÕ[ù^³ƒÌdðCh76}ø+n€::Ù"ÝŒ¶+Ü‘ì¦Þ)ÿ§ú"·OôeÅFJs-[(6Ò@ÕÑÁ-™!Úz¶¡•Q‹æy…Θ%kŽŸãá‹á2ò§|¾øÛ›Wkš¾P°‘î'þ«ê¥Nb““1ºšE œÉ3è8uRIY~!–e”v¢ n¿NÚ¨Róñ§Ÿí¾¤á€—åÏ=yþh£/{¾'ƒ/EQ2%Ó.“uÀô„Ù\ã1˜\É°w¸~Z«p«jEž–…ÀÒ`½‹BÎÈŽ”L‡Ól›¡î?LJ•—üÍ ˜ÝAë*½fÔu'éøLuí zj~´¾;IU%è4£Ÿ)‡Y³ǸÞùY?7¿×ÃĤtXÕa+Dý0H0ùñG °¥>U¸ 0’<-¿“ÌH͇»©s”+º? É%Ô8T8î“ŸØPC=Ñš‘ç©Ÿ ä*!ÏuÄEƒã2O—6‘ù¯«Vó_ÒûJ'*]Þõ£—ßõ£,_Pï7˜PEÝuûldÐœÄèEŠ¤t•RHf’Ô)EÙ¹ºÒÿ°º&ÿ°ÀÜ?·~ïB{—‡ä­ÄüÙsœ÷XÜËN»¶øù+{/^U°ñ³iö,˜˜ÌöðÙ삩˯î³k÷N¾=uF•r˜whw˜”‰ÏSey‘‚@ICÝš ÅAé8ËC ùh£È yIQä×2£a†˜ `…VÓye!Œƒ à@|ø¦å …>F–¨X’¾­) `r@©)2Ïö6ÌçFa”ÚÃ(dOÎùð]L …<ÀU~M&´­9Su?Vì-0Á4íL±-ÈÞªCO17w¼©Ð]yur[ŒƒsôâÁ=õSw`]nË@ªÿx©¶‡§þÀú@œ­ï}¬§.¯8;ßý–¥Š¨3v¯V c‚—3ì­Ïè¿]Xtvµ'qW«l¬a[ÚMþæÅSŠ=9ëô•àû˜Ì[Û 'ôÞŠÌnpYÊÃ~\ÑzîåÃÉì'O:dÊã¶ÎËŠv˜[^£€–‚‰v yúÃa‡,pCe÷°Ôm82’ú’ž2Ñö](…“Ïe %krvPWÚ1/Â9ܪÊ0SÓõ´0 Ò¸LMæA-\¯ø²æÔÙ–oN?4BeFQZaZnfžÀª‹5kËWÍ™±Ò—wöX7N@ ƒf~‡Ì¡[ëƒïx5íÉhŸ5“üù>\õ©âÊåßyD`î\tŸ2n»³Û’†'á|†ZÈRífðF2«$QÏÖ§tåI:Á¡±Ú¢ÌôL•Ñ§XqQ^^yž&Håä m×i†ÞºNÅèbŘb¶C1×éí`Ù­ô`ªý´ÁºëÖ9}ÌX †¿¸¬è¬x!E˜ëöé²éSVL¢…˜œä¼Ô¼ô¬4IJMIŠ>wòÆ=ŸóÍ×ê€a`æD0G݆NˆA&<»Ûtü±¨P5q›?MŠ‰Û°vÍ– ™µàæ7?\¼ÙüÕy¿ ûøœ!3?RwÖø*#8 T»ñ_D«­9z$´&€OÖï³Jêû_m É$ t£áÃþ#GB÷w –¶üù—[˜•+ä2EÉêää´ô¥}û—Gº23MHïŒÕSQ^nY¾ýÓC‡©^m- âf¡ìó lWšX^Z˜¯)RÀ ¨$Qoê Ö ÿ¸(nŸÎèÝŠ®o8pœ2FÆÓvXû=@ƒñ `Œâ%~Hã„ë•_Õ6ӜNuÑ»‚kWVº s™1´07Æ-teTppôjœÁš¨ºÐƘ¯„ëÌOíåÝ×u\Ô%‰CžóãÒÒTB>Y²:»0s1XŸ µ¥ˆ§ zäž,kxé+Ý®qWÿ£Fƒ{Nj¼e¨ñÆ]˜É?}j/<‡p×üJ Ò÷ÍÝE.‡¾xæÚå`Øï¡|TµÿrŸgãÙ{- [¤ˆÞœ*Ä0)¸dçç—å*ʯ|Ùð•À<¸ååê6b’P9foKŠ¯ úZtKñ5˜pþ[ˆt¡Üuœvħå¤eg½U‚*=Cµ=Ãz{”!(sUê4´Ôá_)iéi¸}Ò³2²3²2¬sTéùBŽ›—#‡xkݯKsðÂÉ‚R ®‚0ðЀ¯¹;H\„¡H]œ›™½=w…!¯„?„?¼¹ æÙyYنŸ÷U´S}/ÞâØUc˜˜Á'ê5M¦·†Éÿ£—^Š”–µß¿+&P(ZkM®€jZ4AñÀ[²½ÕúõUc˜‚·˜”œ’”žµ=;¿ƒzÖÚé®ólC¸"óíi™Û…tFO$û*w¡Ë1è*¼^¯ÿÝ L"¦¨“¦"°8"}.ÂN °ÒT2­Ç}HbaJq^^v~‰âÄ®SÅÇæÉ%Ï1ýgÏ´Ÿï³ûÔr^Yž­ÂÔ‘’’´­,þàþÜúsqŸã†ÖôûŸÁL¦?ôiPÊ–%<,£Í·VIãªpTUEì&šž43Í>"ˆÿ`*ž endstream endobj 143 0 obj 5268 endobj 76 0 obj <> endobj 75 0 obj <>stream xœu’}leÇŸëËsLÄ6ͧ½sfH1d›1Ý[ ã¥s( ©zé*ÝZÛkW»i×â!„¶cmXÛ™± â"ê“¢™1&Ëb„lJ5 aq†?HLŒáwðlÆkTþ௻üîó<ß—ß1H£B Ãè[vµ¾jk«¶zE¿[ðX¦¼\ÁÈO«ägÔ´‚¦ïî|£¿»¨‡#OBð ð®Cj† ±z}!¿ÛÕÕËoè´½n®®ÞXšÔÖÕÕñB÷¿ðMBÀíêá×+/‡××-ôô6ðV…öxÜy—'äë ð§SpŽíux„C|‹Ûãöù¼‡ù V3¿©¦¦v§»û€àÛ½=^~o\¢Çáhˆb·ïÛÝÜñZ'BÏ¡zT‹Ö# Ú‚¶"’iPÝfÞ`~Q}¨ZT·Þ}w­|K"& æw—È1¢†uÄ؉CÑØ@$Ëp0‹ÿÌÏ_¿òÖW/ãfÏO^ft׿ÁDO• o—ELàŒØÆ^ýξ§}ç›[9ú<¦g43;'MÅÎ/ˆuI.]{Ǿ&u⢺,úÙŸ!n„&×NàÓ§©Ñ÷ýUáàªF–ûS3í£¡Oû9Î$ãéT4⨺äbC+×Rw%[²¢ÄV‚{UlŽßK¬†:¡þ#ó涟žåhì¡dÿ/#‚3#ÅÛ‚5  WâýöCGk‹ÕfáèSø~§×sÿ½"QEn“>RnXQ„”†ªì8¦SñdÆål&–ˆÄ¢!“VÀþ…KæJn¹‘}„ʼ,øÁt ½aV‘N%oçô ]„/ˆx±Ü —÷Èi£a’8ì™Ý•/·mvdŸörçÄÏžŸí;$ué›;_4Új¤Æ™£—?8=œt ŽjØÖ>f “ûɬ¾Ên,ÜšévNpÝYoâ•Tûˆ?ñΘ,rVúDwyîëk&ƒþWiÎ~b×±p|(%é ṿKÙƒìji+¹¿£<Ô+‹É£,Býv6œ|o4}2‘5^ÞOqÉÄUhXµm\¬B&Ìy¢–ÈYãTHThÆÁ¡áHñ`ž.áÚææÍ›Z–L°”gK?˜²Žè=jJ¡(¾a-h+$»¶/'oÉ>—ËáéÇÈšé²2Rö8Bÿ$oa endstream endobj 144 0 obj 923 endobj 63 0 obj <> endobj 62 0 obj <>stream xœeV{TSg¶?1’sK-™SA0'Z¡88>ªÕ2ÖêHm}¨ÔF$@ !!A^ ûñ~C@ÀBD AP‹S´×Úz«¶µ3SÛ©¶Þ{Û{¹ûлÖý«kf­ùï¬óíï±û÷ûí- æΡ{èHDdøÎàH•FiøÝ6­Z‘·.Þ½°”÷ðþsø%Bü&þá—Ç¿DzØü_Øã ÷^‚¦!g!% %-¡Z]–^•˜& zoÿ¡ÁÁ+ÿñgmHHˆ46ë×éÛJƒ*!EH>Ò•j­N£LIÛ$ %Ñjµ*Nš ÎÒ%¤r…B©po;(W+“¥ï¨Ô*N›. ]!}mÍšµá*Mì ƒt¿V#O‘†kC¤{¤aJ…ê„æ_(ŠòÏJ‰Ó*BuÊT}‚ašêDä{j¹&vÕÚ×Ö­¢ŽR{©·©j;µœÚG½Cí§P;¨Hjõµ‹:H½Nm Â¨mT8J½HySbê7K½L-!èQs©Á ‚hAÇœ 9-ÂÂò¹‚¹rNQˆ(Kô ½. ÿÎ3×çeÌûbÞßçožßá¹Ì3Õó“_r¼øb,ÿÿÆ*@à)äÓx9‹ƒ "×™úBd@¦3f³þ]é aWBÕ¾¨±¾ÆQj)ñ±ã2m+®,®4—¡ÁÍrX€¯ødÌ>’šœ†|ÍÕ5%¨´¤Œ+©(©@åÌ9ƒU¯KUÊú“><®¾µUÒj³ö÷ü+ø¥>Í—kk»Ê;íÅ#;ï}'Áî=H€[$„D÷³D…5ùHÎàaÉ ÌÇÍŒŠìt|…± õ2`¥QyUmm #~hk³×Ûüzšu8|ŠFñy'U§I°ÑN+ÊòëÑeÊéo^Ù+ÓFÄKă÷ÉŹwxß.‚ÃR!¿l¼<571ë#ƒÿÿtß³4˜*¹ 3A^rôlZ/b.·Û/Nû¿º/Ç’¿Á‡7º>Ÿà²Îzhs»øÍî_…µðªÊy ‹ÅAË°?~åÇå°ØgÏI’Òàç˜åJÔìDK$~¯Ê8´/"ã*ÂÛgÇ&9‚Hî6~þ x×î 6ºA'yìPƒ£b²ŠçLV{ØhYY^I¿‡“ ôS5…HÆàÝtÌÆ"C ž"Åœxû?úÛ¸Ó2:,ÙEÃK,*ÊÏ6æe¤¥›N æ þ ¶ã愳ˠläðiÚk*>óÊÔ<'Id»p*V²aɆ£™)Ƥ"-Ú‰öô¤Œ¥ŒçÞC?1wæÀ‚aW–Ò%q)lI=[äéD¹‰&S&2£œòµö¨º(ò (¼¯Â18^Å÷ÙÍæÞë\w[›upTãð!ycykºÞ¼ÎÏÿðáj-{ýjÝ|˜>C‹ÃQl9ª€» ÐÞJ‡—e[Ñ–ÒWŽµç æ~õœ`Çmý #Òö©9qø]ºÓ,ªª±Ô70â mV[}›ß˜}/^„j#ö'¥Øúr88=Ã{°·Öw ø@‚XÜQuV R ”³é=YÝÎÓw¨ý9g8¹/é¢ÌI²{icÄ_ÃÂG#ÝO?æ Ø kÙ2Xp¶u¢–“ÕêŠÌRméa&/¦g¶ðûk|@7©t Iw¦Ò?þ–ç °ó.##уÕNËjÌ5¨ŸáŸäЛv© _üòêeÒ%‚A0Ücé¿ÄaŽ†Csóãõé*Ä„©?&”óëþôVGr‡-ØÖÚ ¬Þ×Ü7Ý…7°ûˆþ‹êòPÜŒÐbóMÑD;-v:¼ÜØ€&ØGuºœÕ5…'ë$-º&s;bzÛ;/râÞA•óØ¥nÇ1‰øî×´Û\b»Á <îõ¸¹Ë}û&,ð‹ÿr‘ø¿)>_ÆŽã—iñ3Ê­­ŒóÞw®T5$Ù´\›¡%o8ãM]œB±g³n§1â¿™ö˜“ô±‹÷ÝW7üþÛ±ÿz6 Ù%Ú”QÕùAg[?7øþ0rTž·ú’ãÛm—Æ£~ãÚNæ‘¿6}%G\kÏN’E¦­“ÙZ«ê:müAD^°‘7³Ã-ÊU«2ŽEe]xúCKï0‘Ÿoîyþ § ô'<ÂSø’…€tQNÑ)#*Bù¥'+’êÒʉtÖì Û¸ó’ìçîM§%3 Mêñí²ÁÇé-qˆêZ+«jPª>S{ºÃ8nêDÌ÷·&ÿú™Ât™{÷œÖÎ3ÎNG_{‡)½MÒšQ—ÕÍ8DD~ÈÁÿßy½Ãû[ˆݰ…XâT´ƒÍBy•ù X}>7[ Žs–~4Hìè [x7ñ5|_/úüTc e¦Ãi´-?³™ÑÃ÷zsm~úŒÃ4Äáó¹C4½›¿Ç¢Êò¦²JrHm¥¥Âá÷¤7fÙîEr:—š­*Üò>Õ´|cü ~Œ'„ ™ßÁf½(üõ¸ã»"Ý~HïrÅݽÓÿÁ×—$úº åÉÜtä«55÷sp퇲¿k†w÷aµ÷¬&â'ä{ 7ù"‰ªÍ5f;K¾Â™‰¯ÀN'VQÃ/¤·C6+þ9&1Q~Ü™40pÞ9àRõÄÌåÇj/±{ü£u<Ëc]Möò‰KfNV—Œ.%$v10ezôt½Å0ø-LJJ7iýbs¬W9x‚# ô¥‚j³»ÛTÐëFýi¬Ç2:AÓkj5rLyZ ‡ B¨„y,úƒÉôz!ÁuÊA¯¯4Õ¢ o§áÅÓc²fìÉœ™ÇôˆŠ±Ì㜨<dž`a93mŸ±Ö‘)Cð5¬ƒûÂ)!‹E7-·kÖéé/Š¬hƒ'htàìpü&øKà1ú+Ûšëk-åWJIè÷zúÓÂú[ÏA=ïÎmvY-NÄLví K¢Ùµ[®ëºÂñu(Ë#ü| Ö°2¥âxÔ…øá+}½CÃʋLjJŠ dííß‘€ HŸN½Íâ ,ðH¥kʪËÊJ;jU ˆqÔ8ÆM³4 ÉÈzŸ1ðžvzMivzÈðw²ÝŒ@àˇHÀ_Èë!5ˆRBE¤û‹ˆU­úò~ÏôÀ÷ßz€©#Q ‰…"C¥ÝÊtŠº&{;¯¡äÌlK¨O¯Ö¢4™|ôðæD9é›k˜4~== 3cÔ(ÿÉ#o°BàV-ÿe‚·²}9mcˆ¹u1nÏÎÄÄ•.›þSŠ3û‚ŠßíJ9{Jx›HAàPŽ+¥‡K·g×ÇeĹ}±åÜÍÅß„_ Úzdy¤¤Õè¾Ya!ùµVo(ü ¼âæý¨fùí›èˆ·ðoð¦«÷®ôÅ´øg(ÁË!–ß¡Hüt¿ò2VŠ@ £xÔYÁG|!ˆðü !|‡Xè¹@ìï‹~‹ÿóÇÂKE¹¾ßiÇ÷£Ìèèiºúâ$1Ýš†TÄ$¤êN$~!0ï'Xú|÷WXÐÅ)ëÔå!m|¼2¬¼Ü ‡¬"ç|z: €Ô¶àŠúªü[e endstream endobj 145 0 obj 3117 endobj 117 0 obj <> endobj 116 0 obj <>stream xœe]L[eÇÏ¡kÏ«0mNHÜlOta]ðƒšáÖ¨ Î!Ÿ]»P =кSZ9@-°¶èK?øëJë80VÀˆn!2—x1cÌâÇÅ£ñ¯»]<^.<-1^xñ&oÞç÷>ÏóûÓÔž<Š¦iöeë©ÓÖ×Ë,.7/>ù’GpŽVd œ¼Ÿ–äɪÈóäí_·-ê¹mŸ&ŠapôQ*šGS•¯¿ÓÕîìâŒ'l‡ËÊžøïÅd6›¹ÿ¿®Š]í\©réá×Íwt=ÇU*´ ¸Z¹vÁïuŠœÝáàÙoV»ÀŸáŽ»—×ëéጕ‡¹gÊËM5.wK·È5xÜö®Æc檹7x‡«ÛýÿEQŒ‡ïtZÜ&Šª£ŽSÔkTUCi)¤ØS{¨Ô ]LŸ£ïæämn÷Ê#g—ä–h ‡À‡T“Ý,Ñ#Èã„`ÿzàÊÖ0*°_§,äyÊg«¯ó} ¥P5»qÛP(×½ µËpd‰–K¡˜m}S𿃸c¶çšÿê@fxA\3ôsÿ3+ï®6§-‘â£FRJJï—Aѽõ«¿k/¨ILl f?]Ç‹8Õ7!Äßx"§P?y„Q¦`I6IiíW`(ÑmB‡lgI½¨YšàVDn0¸åƒÐÛH„”ÄÔÄ‚3ø6‚zfcq-319Ø7­Oy጖W ºå/\™¦Ó¼÷Õ&½nó¾Òÿ¦Ò_{^‘蛊³ *plc‰EÔ\à´3Î`û@ø­°2bHbÚâÁ^Ffpl|jjòÒœt~£kIo£œcp[ Ï5¬ A‰iø3£Ì/Ö[fk›¯Þ¦‡O˜Â­§ñüV~š†NxVcð‹_ …*Q'lÍ3GÆBSøG$K ìÞhN’|tEó!4«wþÖŒfõMò7®CQ íHJ³ïsí’öÖ®@ö”èÖ¡5›T£¨ù|h:¨hä’ í&5(1Îxè^ÉiŒ]LÍL!ݽ‹'Ç“ûW]µ9‘–P mD Sœwáx¾”THŒVb]µ‡‚| KŒ#:×ÄrÎ |× ›ÞýSªÆÕ¸ÙË×"ÝúJì#ÊÒ ¿)ì£ ¾ÛªbIœÐê÷˜ÉèD4¹<5?>ƒÑütw“a‡e°Ù×kü‰r¾Ä”Gzø'$ßée }iÙž[Z“y¸üL¦ ¸¹‚½õ!çÀÉ endstream endobj 146 0 obj 946 endobj 15 0 obj <>/FontBBox[0 -37 97 118]/FontMatrix[1 0 0 1 0 0]/FirstChar 0/LastChar 38/Widths[ 0 0 0 0 0 0 0 76 0 66 70 0 80 0 113 0 83 0 81 85 0 88 33 69 0 46 107 0 0 142 82 84 89 50 117 72 74 0 93] >> endobj 28 0 obj <> endobj 77 0 obj <> endobj 25 0 obj <> endobj 64 0 obj <> endobj 22 0 obj <> endobj 19 0 obj <> endobj 13 0 obj <> endobj 10 0 obj <> endobj 53 0 obj <> endobj 50 0 obj <> endobj 42 0 obj <> endobj 39 0 obj <> endobj 118 0 obj <> endobj 36 0 obj <> endobj 32 0 obj <> endobj 14 0 obj <> endobj 2 0 obj <>endobj xref 0 147 0000000000 65535 f 0000040470 00000 n 0000120769 00000 n 0000040345 00000 n 0000040518 00000 n 0000038826 00000 n 0000000015 00000 n 0000003662 00000 n 0000048862 00000 n 0000048607 00000 n 0000111058 00000 n 0000047153 00000 n 0000046903 00000 n 0000109868 00000 n 0000120568 00000 n 0000102014 00000 n 0000040587 00000 n 0000060780 00000 n 0000060546 00000 n 0000108676 00000 n 0000056120 00000 n 0000055788 00000 n 0000107485 00000 n 0000051542 00000 n 0000051222 00000 n 0000105095 00000 n 0000063597 00000 n 0000063031 00000 n 0000102720 00000 n 0000040811 00000 n 0000062144 00000 n 0000061896 00000 n 0000119377 00000 n 0000041016 00000 n 0000076707 00000 n 0000076267 00000 n 0000118186 00000 n 0000075380 00000 n 0000075132 00000 n 0000115797 00000 n 0000072188 00000 n 0000071885 00000 n 0000114616 00000 n 0000041224 00000 n 0000041254 00000 n 0000038994 00000 n 0000003682 00000 n 0000006404 00000 n 0000090552 00000 n 0000090116 00000 n 0000113432 00000 n 0000083812 00000 n 0000083424 00000 n 0000112245 00000 n 0000041394 00000 n 0000039146 00000 n 0000006425 00000 n 0000009899 00000 n 0000041501 00000 n 0000039298 00000 n 0000009920 00000 n 0000014919 00000 n 0000097492 00000 n 0000097194 00000 n 0000106290 00000 n 0000041566 00000 n 0000039442 00000 n 0000014940 00000 n 0000019685 00000 n 0000041620 00000 n 0000041879 00000 n 0000042129 00000 n 0000039594 00000 n 0000019706 00000 n 0000023530 00000 n 0000096163 00000 n 0000095929 00000 n 0000103911 00000 n 0000042192 00000 n 0000039746 00000 n 0000023551 00000 n 0000027848 00000 n 0000042257 00000 n 0000039898 00000 n 0000027869 00000 n 0000032098 00000 n 0000042355 00000 n 0000042601 00000 n 0000042805 00000 n 0000042869 00000 n 0000043101 00000 n 0000043165 00000 n 0000043229 00000 n 0000043475 00000 n 0000043539 00000 n 0000043807 00000 n 0000043872 00000 n 0000044129 00000 n 0000044193 00000 n 0000044459 00000 n 0000044523 00000 n 0000044588 00000 n 0000044837 00000 n 0000044902 00000 n 0000044967 00000 n 0000045032 00000 n 0000045280 00000 n 0000045345 00000 n 0000045411 00000 n 0000045595 00000 n 0000045835 00000 n 0000045901 00000 n 0000045966 00000 n 0000046031 00000 n 0000046096 00000 n 0000046161 00000 n 0000100959 00000 n 0000100718 00000 n 0000116988 00000 n 0000046227 00000 n 0000046292 00000 n 0000046357 00000 n 0000046596 00000 n 0000046661 00000 n 0000040051 00000 n 0000032119 00000 n 0000036875 00000 n 0000046793 00000 n 0000040198 00000 n 0000036897 00000 n 0000038804 00000 n 0000046859 00000 n 0000048585 00000 n 0000051200 00000 n 0000055766 00000 n 0000060524 00000 n 0000061874 00000 n 0000063010 00000 n 0000071863 00000 n 0000075110 00000 n 0000076246 00000 n 0000083402 00000 n 0000090094 00000 n 0000095907 00000 n 0000097173 00000 n 0000100696 00000 n 0000101993 00000 n trailer << /Size 147 /Root 1 0 R /Info 2 0 R >> startxref 120819 %%EOF gcl27-2.7.0/ansi-tests/doc/ilc2005.tex000066400000000000000000000664451454061450500171200ustar00rootroot00000000000000\documentclass[11pt]{article} % \setlength{\oddsidemargin}{0in} % \setlength{\evensidemargin}{0in} % \setlength{\footskip}{1in} % \setlength{\textwidth}{6.5in} \usepackage[letterpaper,textwidth=6.7in,textheight=8.7in]{geometry} \usepackage{graphics} \usepackage{url} \usepackage{times} %\usepackage[british]{babel} % \usepackage{theorem} \setlength{\topmargin}{.35in} \newtheorem{theorem}{Theorem} \pagestyle{empty} \begin{document} \title{The GCL ANSI Common Lisp Test Suite} \author{Paul F. Dietz\footnote{Motorola Global Software Group, 1303 E. Algonquin Road, Annex 2, Schaumburg, IL 60196. paul.f.dietz@motorola.com}} \date{} \maketitle \thispagestyle{empty} \begin{abstract} I describe the conformance test suite for ANSI Common Lisp distributed as part of GNU Common Lisp (GCL). The test suite includes more than 20,000 individual tests, as well as random test generators for exercising specific parts of Common Lisp implementations, and has revealed many conformance bugs in all implementations on which it has been run. \end{abstract} \section{Introduction} One of the strengths of Common Lisp is the existence of a large, detailed standard specifying the behavior of conforming implementations. The value of the standard to users is enhanced when they can be confident that implementations that purport to conform actually do. In the 1990s I found substantial numbers of conformance bugs in many Lisp implementations. As a result, I decided to build a comprehensive functional test suite for Common Lisp. The goals of the effort were, in no particular order: \begin{itemize} \item To thoroughly familiarize myself with the standard. \item To provide a tool to locate conformance problems in CL implementations, both commercial and free. \item To enable implementors to improve CL implementations while maintaining conformance. \item To explore the standard itself for ambiguities, unintended consequences, and other problems. \item To explore different testing strategies. \end{itemize} I deliberately did not design the test suite to measure or rank conformance of Lisp implementations. For this reason, I will not here report the overall score of any implementation. I decided to locate the test suite in the GCL development tree for two reasons. First, its development team had a goal of making GCL more ANSI compliant, and tests would assist there. Secondly, the GCL CVS tree is easily publicly accessible\footnote{See \url{http://savannah.gnu.org/projects/gcl/}}, so any developers or users of Common Lisp implementations would have easy access to it. The test suite was constructed over the period from 1998 to 2005, with most of the work done in 2002 to 2004. As of 24 May 2005, the test suite contains over 20,000 tests. The test suite is based on a version of the ANSI Common Lisp specification (ANSI/INCITS 226-1994, formerly ANSI X3.226-1994) that was made publicly available by Harlequin (now LispWorks) in hyperlinked form in 1996 \cite{X3J13:94}. Table \ref{lispimpltab} contains a list of Lisp implementations on which I am aware the test suite has been run. \begin{table} \begin{center} \begin{tabular}{lr} Implementation & Hardware Platforms \\ \hline GNU Common Lisp & All debian platforms \\ GNU CLISP & x86 \\ CMUCL & x86, Sparc \\ SBCL & x86, x86-64, Sparc, MIPS, Alpha, PowerPC \\ Allegro CL (6.2, 7) & x86, Sparc, PowerPC \\ LispWorks (4.3) & x86 \\ OpenMCL & PowerPC \\ ABCL & x86 (JVM) \\ ECL & x86 \\ \end{tabular} \end{center} \caption{\label{lispimpltab} Implementations Tested} \end{table} \section {Infrastructure} The test suite uses Waters' RT package \cite{Waters:91a}. This package provides a simple interface for defining tests. In its original form, tests are defined with a name (typically a symbol or string), a form to be evaluated, and zero or more expected values. The test passes if the form evaluates to the specified number of values, and those values are as specified. See figure \ref{examplefig} for an example from the test suite: \begin{figure} \begin{verbatim} (deftest let.17 (let ((x :bad)) (declare (special x)) (let ((x :good)) ;; lexical binding (let ((y x)) (declare (special x)) ;; free declaration y))) :good) \end{verbatim} \caption{\label{examplefig} Example of a test} \end{figure} As the test suite evolved RT was extended. Features added include: \begin{itemize} \item Error conditions raised by tests may be trapped. \item Tests may optionally be executed by wrapping the form to be evaluated in a lambda form, compiling it, and calling the compiled code. This makes sense for testing Lisp itself, but would not be useful for testing Lisp applications. \item A subset of the tests can be run repeatedly, in random order, a style of testing called \emph{Repeated Random Regression} by Kaner, Bond and McGee \cite{KanerBondMcGee:04}\footnote{This was previously called `Extended Random Regression'; McGee renamed it to avoid the confusing acronym.} \item Notes may be attached to tests, and these notes used to turn off groups of tests. \item Tests can be marked as being expected to fail. Unexpected failures are reported separately. \end{itemize} \section {Functional Tests} The bulk of the test suite consists of functional tests derived from specific parts of the ANSI specification. Typically, for each standardized operator there is a file \emph{operator}.lsp containing tests for that operator. This provides a crude form of traceability. There are exceptions to this naming convention, and many tests that test more than one operator are located somewhat arbitrarily. Table \ref{tab:testsize} shows the number and size of tests for each section of the ANSI specification. \begin{table} \begin{center} \begin{tabular}{|l|r|r|} \hline Section of CLHS & Size (Bytes) & Number of Tests \\ \hline \hline Arrays & 212623 & 1109 \\ Characters & 38655 & 256 \\ Conditions & 71250 & 658 \\ Cons & 264208 & 1816 \\ Data \& Control Flow & 185973 & 1217 \\ Environment & 51110 & 206 \\ Eval/Compile & 41638 & 234 \\ Files & 26375 & 87 \\ Hash Tables & 38752 & 158 \\ Iteration & 98339 & 767 \\ Numbers & 290991 & 1382 \\ Objects & 283549 & 774 \\ Packages & 162203 & 493 \\ Pathnames & 47100 & 215 \\ Printer & 454314 & 2364 \\ Reader & 101662 & 663 \\ Sequences & 562210 & 3219 \\ Streams & 165956 & 796 \\ Strings & 83982 & 415 \\ Structures & 46271 & 1366 \\ Symbols & 106063 & 1141 \\ System Construction & 16909 & 77 \\ Types & 104804 & 599 \\ Misc & 291883 & 679 \\ \hline Infrastructure & 115090 & \\ Random Testers & 190575 & \\ \hline Total & 4052485 & 20702 \\ \hline \end{tabular} \end{center} \caption{\label{tab:testsize} Sizes of Parts of the Test Suite} \end{table} Individual tests vary widely in power. Some are as simple as a test that {\tt (CAR NIL)} is {\tt NIL}. Others are more involved. For example, {\tt TYPES.9} checks that {\tt SUBTYPEP} is transitive on a large collection of built-in types. The time required to run the test suite depends on the implementation, but it is not excessive on modern hardware. SBCL 0.9.0.41 on a machine with 2 GHz 64 bit AMD processor, for example, runs the test suite in under eight minutes. Error tests have been written where the error behavior is specified by the standard. This includes specifications in the `Exceptional Situations' sections for operator dictionary entries, as well as tests for calls to functions with too few or too many arguments, keyword parameter errors, and violations of the first paragraph of CLHS section 14.1.2.3. When type errors are specified or when the CLHS requires that some operator have a well-defined meaning on any Lisp value, the tests iterate over a set of precomputed Lisp objects called the `universe' that contains representatives of all standardized Lisp classes. In some cases a subset of this universe is used, for efficiency reasons. There are some rules that perform random input testing. This testing technique is described more fully in the next section. Other tests are themselves deterministic, but are the product of one of the suite's high volume random test harnesses. The `Misc' entry in table \ref{tab:testsize} refers to these randomly generated tests. Each of these tests caused a failure in at least one implementation. Inevitably, bugs have appeared in the test suite. Running the test suite on multiple implementations (see table \ref{lispimpltab}) exposes most problems. If a test fails in most of them, it is likely (but not certain) that the test is flawed. Feedback from implementors has also been invaluable, and is deeply appreciated. In some cases, when it has not been possible to agree on the proper interpretation of the standard, I've added a note to the set of disputed tests so they can be disabled as a group. This is in keeping with the purpose of the test suite -- to help implementors, not judge implementations. \section {Random Testing} Random testing (more properly, random-input testing) is a standard technique in the testing of hardware systems. However, it has been the subject of controversy in the software testing community for more than two decades. Myers \cite{Myers:79} called it ``Probably the poorest ... methodology of all''. This assessment presumes that the cost of executing tests and checking their results for validity dominates the cost of constructing the tests. If test inputs can be constructed and results checked automatically, it may be very cost-effective to generate and execute many lower quality tests. Kaner et al. call this High Volume Automated Testing \cite{KanerBondMcGee:04}. Duran and Ntafos \cite{DuranNtafos:81} report favorably on the ability of random testing to find relatively subtle bugs without a great deal of effort. Random testing has been used to test Unix utilities (so-called `fuzz testing') \cite{MillerFredriksenSo:90}, database systems \cite{Slutz:98}, and C compilers \cite{McKeeman:98,Lindig:05,Faigon:05}. Bach and Schroeder \cite{BachSchroeder:04} report that random input testing compares well with the ability of the popular All-Pairs testing technique at actually finding bugs. Random input testing provides a powerful means of testing algebraic properties of systems. Common Lisp has many instances where such properties can be checked, and the test suite tests many of them. Random testing is used to test numeric operators, type operators, the compiler, some sequence operators, and the readability of objects printed in `print readably' mode. One criticism of random testing is its irreproducibility. With care, this needn't be a problem. If a random failure is sufficiently frequent, it can be reproduced with high probability by simply running a randomized test again. Tests can also be designed so that on failure, they print sufficient information so that a non-randomized test can be constructed exercising the bug. Most of the randomized tests in the test suite have this property. \subsection {Compiler Tests} \label{sec:compilertests} Efficiency of compiled code has long been one of Common Lisp's strengths. Implementations have been touted as in some cases approaching the speed of statically typed languages. Achieving this efficiency places strong demands on Lisp compilers. A sufficiently smart compiler needs a sufficiently smart test suite. Compilers (and Lisp compilers in particular) are an ideal target for random input testing. Inputs may have many parts that interact in the compiler in unpredictable ways. Because the language has a well-defined semantics, it is easy to generate related, but different, forms that should yield the same result (thereby providing a test oracle.) The Random Tester performs the following steps. For some input parameters $n$ and $s$ (each positive integers): \begin{enumerate} \item Produce a list of $n$ symbols that will be the parameters of a lambda expression. These parameters will have integer values. \item Produce a list of $n$ finite integer subrange types. These will be the types of the lambda parameters. The endpoints of these types are not uniformly distributed, but instead follow an approximately exponential distribution, preferring small integers over larger ones. Integers close in absolute value to integer powers of 2 are also overrepresented. \item Generate a random conforming Lisp form of `size' approximately $s$ containing (mostly) integer-valued forms. The parameters from step 1 occur as free variables. \item From this form, construct two lambda forms. In the first, the lambda parameters are declared to have their integer types, and random {\tt OPTIMIZE} settings are included. In the second, a different set of {\tt OPTIMIZE} settings is declared, and all the standardized Lisp functions that occur in the form are declared {\tt NOTINLINE}. The goal here is to attempt to make optimizations work differently on the two forms. \item For each lambda form, its value on each set of inputs is computed. This is done either by compiling the lambda form and calling it on the inputs, or by evaling forms in which the lambda form is the {\tt CAR} and the argument list the {\tt CDR}. \item A failure occurs if any call to the compiler or evaluator signals an error, or if the two lambda forms yield different results on any of the inputs. \end{enumerate} This procedure very quickly -- within seconds -- found failures in every Lisp implementation on which it was tried. Failures included assertion failures in the compiler, type errors, differing return values, code that caused segmentation faults, and in some cases code that crashed the Lisps entirely. Most of the 679 `Misc' tests in table \ref{tab:testsize} were produced by this tester; each represents a failure in one or more implementations. Generating failing tests was easy, but minimizing them was tedious and time consuming. I therefore wrote a pruner that repeatedly tries to simplify a failing random form, replacing integer-valued subforms with simpler ones, until no substitution preserving failure exists. In most cases, this greatly reduced the size of the failing form. Others have previously observed that bug-exposing random inputs can often be automatically simplified \cite{HildZeller:02a,McKeeman:98}. The desire to be able to automatically simplify the failing forms constrained the tester; I will discuss this problem later in section \ref{sec:future}. \begin{table} \begin{center} \begin{tabular}{|l|l|l|} \hline Sourceforge Bug \# & Type of Bug & Description \\ \hline 813119 & C & Simplification of conditional forms \\ 842910 & C & Simplification of conditional forms \\ 842912 & R & Incorrect generated code \\ 842913 & R & Incorrect generated code \\ 858011 & C & Compiler didn't handle implicit block in {\tt FLET} \\ 858658 & R & Incorrect code for {\tt UNWIND-PROTECT} and multiple values \\ 860052 & C & Involving {\tt RETURN-FROM} and {\tt MULTIPLE-VALUE-PROG1}. \\ 864220 & C & Integer tags in tagbody forms. \\ 864479 & C & Compiler bug in stack analysis. \\ 866282 & V & Incorrect value computed due to erroneous side effect \\ & & analysis in compiler on special variables \\ 874859 & R & Stack mixup causing catch tag to be returned. \\ 889037 & V & Bug involving nested {\tt LABELS}, {\tt UNWIND-PROTECT}, {\tt DOTIMES} forms. \\ 890138 & R & Incorrect bytecodes for {\tt CASE}, crashing the Lisp. \\ 1167991 & C & Simplification of conditional forms. \\ \hline \end{tabular} Legend: \begin{tabular}{ll} C & Condition thrown by the compiler (assert or type check failure.) \\ R & Condition thrown at runtime (incorrectly compiled code). \\ V & Incorrect value returned by compiled code. \\ \end{tabular} \end{center} \caption{\label{clispbugs} Compiler bugs found in GNU CLISP by Random Tester} \end{table} Table \ref{clispbugs} contains a list of the fourteen compiler bugs detected by the random tester in GNU CLISP. Roughly 200 million iterations of the random tester were executed to find these bugs, using a single 1.2 GHz Athlon XP+ workstation running intermittently over a period of months. All these bugs have been fixed (in CVS) and CLISP now fails only when the random forms produce bignum values that exceed CLISP's internal limit. The greatest obstacle to using the random tester is the presence of unfixed, high probability bugs. If an implementation has such a bug, it will generate many useless hits that will conceal lower probability bugs. \subsection {Types and Compilation} Type inference and type-based specialization of built-in operators is a vital part of any high performance Lisp compiler for stock hardware, so it makes sense to focus testing effort on it. The test suite contains a facility for generating random inputs for operators and compiling them with appropriate randomly generated type annotations, then checking if the result matches that from an unoptimized version of the operator. As an example, the operator {\tt ISQRT} had this bug in one commercial implementation: \begin{verbatim} (compile nil '(lambda (x) (declare (type (member 4 -1) x) (optimize speed (safety 1))) (isqrt x))) ==> Error: -1 is illegal argument to isqrt \end{verbatim} Amusingly, the bug occurs only when the negative integer is the second item in the {\tt MEMBER} list. The test that found this bug is succinctly defined via a macro: \begin{verbatim} (def-type-prop-test isqrt 'isqrt '((integer 0)) 1) \end{verbatim} The function to be compiled can be generated in such a way that it stores the result value into an array specialized to a type that contains the expected value. This is intended to allow the result value to remain unboxed. The general random testing framework of section \ref{sec:compilertests} is also useful for testing type-based compiler optimizations, with two drawbacks: it currently only handles integer operators, and it is less efficient than the more focused tests. Even so, it was used to improve unboxed arithmetic in several implementations (SBCL, CMUCL, GCL, ABCL). \subsection {{\tt SUBTYPEP} Testing} The test suite uses the algebraic properties of the {\tt SUBTYPEP} function in both deterministic and randomized tests. For example, if {\tt T1} is known to be a subtype of {\tt T2}, we can also check: \begin{verbatim} (subtypep '(not t2) '(not t1)) (subtypep '(and t1 (not t2)) nil) (subtypep '(or (not t1) t2) t) \end{verbatim} The generator/pruner approach of the compiler random tester was applied to testing {\tt SUBTYPEP}. Random types were generated and, if one was a subtype of the other, the three alternative formulas were also tested. If any return the two values (false, true), a failure has been found. Christophe Rhodes used feedback from this tester to fix logic and performance bugs in SBCL's {\tt SUBTYPEP} implementation. The handling of {\tt CONS} types is particularly interesting, since deciding the subtype relationship in the presence of cons types is NP-hard. At least one implementation's {\tt SUBTYPEP} will run wild on moderately complicated cons types, consuming large amounts of memory before aborting. \subsection {Repeated Random Regression} As mentioned earlier, RRR is a technique for executing tests in an extended random sequence, in order to flush out interaction bugs and slow corruption problems. As an experiment, RT was extended to support RRR on subsets of the tests. The main result was to find many unwanted dependencies in the test suite, particularly among the package tests. These dependencies had not surfaced when the tests had been run in their normal order. After fixing these problems, RRR did find one CLOS bug in CLISP, involving interaction between generic functions and class redefinitions. The bug was localized by bisecting the set of tests being run until a minimal core had been found, then minimizing the sequence of invocations of those tests. If more bugs of this kind are found it may be worthwhile to add a delta debugging \cite{HildZeller:02a} facility to perform automatic test minimization. In Lisps that support preemptively scheduled threads, it would be interesting to use RRR with subsets of the tests that lack global side effects. The tests would be run in two or more threads at once in order to find thread safety problems. \section {Issues with the ANSI Common Lisp Specification} Building the test suite involved going over the standard in detail. Many points were unclear, ambiguous, or contradictory; some parts of the standard proved difficult to test in a portable way. This section describes some of these findings. See `Proposed ANSI Revisions and Clarifications' on \url{http://www.cliki.net/} for a more complete list that includes issues arising from the test suite. \subsection {Testability} Some parts of the standard proved difficult to test in a completely conforming way. The specification of pathnames, for example, was difficult to test. The suite has assumed that UNIX-like filenames are legal as physical pathnames. Floating point operators presented problems. The standard does not specify the accuracy of floating point computations, even if it does specify a minimum precision for each of the standardized float types. \footnote{The standard does specify a feature indicating the implementation purports to conform to the IEEE Standard for Binary Floating Point Arithmetic (ANSI/IEEE Std 754-1985); this suite does not test this.} Some implementations have accuracy that varies depending on the details of compilation; in particular, boxed values may be constrained to 64 bits while unboxed values in machine registers may have additional `hidden' bits. These differences make differential testing challenging. The Objects chapter contains interfaces that are intended to be used with the Metaobject Protocol (MOP). Since the MOP is not part of the standard, some of these cannot be tested. For example, there is apparently no conforming way to obtain an instance of class {\tt METHOD-COMBINATION}, or to produce any subclass of {\tt GENERIC-FUNCTION} except for {\tt STANDARD-GENERIC-FUNCTION}. \subsection {Unintended Consequences} There seem to be many issues associated with Common Lisp's type system. One example is the {\tt TYPE-OF} function. According to the standard, this function has the property that \begin{quote} For any object that is an element of some built-in type: [\ldots] the type returned is a recognizable subtype of that built-in type. \end{quote} A \emph{built-in} type is defined to be \begin{quote} built-in type {\it n}. one of the types in Figure 4-2. \end{quote} Figure 4-2 of the standard contains {\tt UNSIGNED-BYTE}, the type of nonnegative integers. These constraints imply that {\tt TYPE-OF} can never return {\tt FIXNUM} or {\tt BIGNUM} for any nonnegative integer, since neither of those types is a subtype of {\tt UNSIGNED-BYTE}. A more serious set of problems involves {\tt UPGRADED-ARRAY-ELEMENT-TYPE}. \footnote{I ignore the issue that, strictly speaking, {\tt UPGRADED-ARRAY-ELEMENT-TYPE} is either an identity function or is not computable, since as defined it must work on {\tt SATISFIES} types.} This function (from types to types) is specified to satisfy these two axioms for all types $T_1$ and $T_2$: \begin{displaymath} T_1 \subseteq UAET(T_1) \end{displaymath} and \begin{displaymath} T_1 \subseteq T_2 \Longrightarrow UAET(T_1) \subseteq UAET(T_2) \end{displaymath} A type $T_1$ is a \emph{specialized array element type} if $T_1 = UAET(T_1)$. These axioms imply: \begin{theorem} If two types $T_1$ and $T_2$ are specialized array element types, then so is $T_1 \cap T_2$. \end{theorem} This theorem has a number of unpleasant consequences. For example, if {\tt (UNSIGNED-BYTE 16)} and {\tt (SIGNED-BYTE 16)} are specialized array element types, then so must be {\tt (UNSIGNED-BYTE 15)}. Even worse, since {\tt BIT} and {\tt CHARACTER} are required to be specialized array element types, and since they are disjoint, then {\tt NIL}, the empty type, must also be a specialized array element type. Topping all this off, note that \begin{quote} A string is a specialized vector whose elements are of type character or a subtype of type character. (CLHS page for {\tt STRING}) \end{quote} Since {\tt NIL} is a subtype of {\tt CHARACTER}, a vector with array element type {\tt NIL} is a string. It is impossible for a conforming implementation to have only a single representation of strings.\footnote{But since `nil strings' can never be accessed, it's acceptable in non-safe code to just assume string accesses are to some other string representation. The SBCL implementors took advantage of this when using nil strings as a stepping stone to Unicode support.} \section {Directions For Future Work} \label{sec:future} The test suite still has a few areas that are not sufficiently tested. Setf expanders need more testing, as do logical pathnames and file compilation. Floating point functions are inadequately tested. As mentioned earlier, it isn't clear what precision is expected of these functions, but perhaps tests can be written that check if the error is too large (in some sufficiently useful sense.) The random compiler tester, as implemented, is constrained to generate forms that remain conforming as they are simplified. This limits the use of certain operators that do not take the entire set of integers as their arguments. For example, {\tt ISQRT} appears only in forms like {\tt (ISQRT (ABS ...))}, and this pattern is preserved during pruning. The forms also make very limited use of non-numeric types. More sophisticated random tester could avoid these limitations. One approach would be to randomly generate trees from which Lisp forms could be produced, but that also carry along information that would enable pruning to be done more intelligently. Another approach would be to check each pruned form for validity on the set of chosen random inputs by doing a trial run with all operators replaced by special versions that always check for illegal behaviors. I intend to explore both options. The test suite has been written mostly as a `black box' suite (aside from the randomly generated Misc tests). It would be interesting to add more implementation knowledge, with tests that, while conforming, will be more useful if the Lisp has been implemented in a particular way. The type propagation tester is an example of this kind of `gray box' testing. It would be interesting to determine the level of coverage achieved by the test suite in various implementations. The coverage is probably not very good, since the suite cannot contain tests of nonstandardized error situations, but this should be confirmed, and compared against the coverage obtained from running typical applications. Internal coverage could also provide feedback for nudging the random tester toward testing relatively untested parts of the compiler, say by using an evolutionary algorithm on the parameters governing the construction of random forms. \section {Acknowledgments} I would like to thank Camm Maguire, the head of the GCL development team, for allowing the GCL ANSI test suite to be a part of that project. I also would like to thank users of the test suite who have returned feedback, including Camm, Christophe Rhodes, Sam Steingold, Bruno Haible, Duane Rettig, Raymond Toy, Dan Barlow, Juan Jos\'{e} Garc\'{i}a-Ripoll, Brian Mastenbrook and many others. \nocite{X3J13:94} \nocite{McKeeman:98} \nocite{DuranNtafos:81} \nocite{KanerBondMcGee:04} \nocite{Waters:91a} \nocite{HildZeller:02a} \nocite{BachSchroeder:04} \nocite{Slutz:98} \nocite{Lindig:05} \nocite{Myers:79} \bibliography{lisp} \bibliographystyle{plain} \end{document} gcl27-2.7.0/ansi-tests/doc/lisp.bib000066400000000000000000000064311454061450500167320ustar00rootroot00000000000000@booklet{X3J13:94, title = "Common {Lisp} {HyperSpec}", author = "K. M. Pitman", howpublished = "http://www.lispworks.com/reference/HyperSpec/Front/index.htm", note = "A hyperlinked form of ANSI/INCITS document 226-1994. Translated in 1996 and updated in 2005." } @article{McKeeman:98, title = {Differential Testing for Software}, author = {W. M. McKeeman}, journal = {Digital Technical Journal}, volume = {10}, number = {1}, year = {1998}, pages = {100--107} } @article{DuranNtafos:84, title = {An Evaluation of Random Testing}, author = {J. W. Duran and S. Ntafos}, journal = {IEEE TSE}, volume = {SE-10}, year = {1984}, pages = {438--444}, publisher = {IEEE Press} } @inproceedings{DuranNtafos:81, author = {Joe W. Duran and Simeon Ntafos}, title = {A report on random testing}, booktitle = {ICSE '81: Proceedings of the 5th international conference on Software engineering}, year = {1981}, pages = {179--183}, location = {San Diego, California, United States}, publisher = {IEEE Press} } @misc{KanerBondMcGee:04, author={C. Kaner, W. P. Bond, P. McGee}, title={High Volume Test Automation}, howpublished={At http://testingeducation.org/a/hvta.pdf}, year={2004}, month={May}, note={Keynote address presented at the International Conference on Software Testing, Analysis, and Review (STAR East), Orlando, FL} } @article{Waters:91a, author = {Richard C. Waters}, title = {Supporting the regression testing of Lisp programs}, journal = {SIGPLAN Lisp Pointers}, volume = {IV}, number = {2}, year = {1991}, pages = {47--53}, publisher = {ACM Press}, address = {New York, NY, USA}, } @article{HildZeller:02a, author={Andreas Zeller and Ralf Hildebrandt}, title={Simplifying and Isolating Failure-Inducing Input}, journal={IEEE Transactions on Software Engineering}, volume={28}, number={2}, month={Feb}, year={2002}, pages={183--200}, } @inproceedings {BachSchroeder:04, author={James Bach and Patrick J. Schroeder}, title={Pairwise Testing: A Best Practice That Isn't}, booktitle={Proc. 22nd Annual Pacific Northwest Software Quality Conference}, year={2004}, note={See http://www.pnsqc.org/proceedings/pnsqc2004.pdf}, } @inproceedings {Slutz:98, author={Don R. Slutz}, title={Massive Stochastic Testing of {SQL}}, booktitle={Proc. 24th International Conference on Very Large Database Systems (VLDB'98)}, year={1998}, month={Aug.}, pages={618-622}, } @misc{Lindig:05, author={Christian Lindig}, title={Random Testing the Translation of {C} Function Calls}, month={Feb.}, year={2005}, howpublished={At http://www.st.cs.uni-sb.de/~lindig/src/quest/quest.pdf}, } @book{Myers:79, author={Glenford J. Myers}, title={The Art of Software Testing}, publisher={John Wiley \& Sons}, year={1979}, } @article{MillerFredriksenSo:90, author = {Barton P. Miller and Louis Fredriksen and Bryan So}, title = {An empirical study of the reliability of UNIX utilities}, journal = {Commun. ACM}, volume = {33}, number = {12}, year = {1990}, issn = {0001-0782}, pages = {32--44}, doi = {http://doi.acm.org/10.1145/96267.96279}, publisher = {ACM Press}, address = {New York, NY, USA}, } @misc{Faigon:05, author={Ariel Faigon}, title={Testing for Zero Bugs}, year={2005}, howpublished={At http://www.yendor.com/testing/}, } gcl27-2.7.0/ansi-tests/documentation.lsp000066400000000000000000000462601454061450500201350ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Dec 14 07:30:01 2004 ;;;; Contains: Tests of DOCUMENTATION (in-package :cl-test) ;;; documentation (x function) (doc-type (eql 't)) (deftest documentation.function.t.1 (let* ((sym (gensym))) (eval `(defun ,sym () nil)) (documentation (symbol-function sym) t)) nil) (deftest documentation.function.t.2 (let* ((sym (gensym))) (eval `(defun ,sym () nil)) (let ((fn (symbol-function sym)) (doc "FOO1")) (multiple-value-prog1 (setf (documentation fn t) (copy-seq doc)) (assert (or (null (documentation fn t)) (equal doc (documentation fn t))))))) "FOO1") (deftest documentation.function.t.3 (let* ((sym (gensym))) (eval `(defmacro ,sym () nil)) (documentation (macro-function sym) t)) nil) (deftest documentation.function.t.4 (let* ((sym (gensym))) (eval `(defmacro ,sym () nil)) (let ((fn (macro-function sym)) (doc "FOO2")) (multiple-value-prog1 (setf (documentation fn t) (copy-seq doc)) (assert (or (null (documentation fn t)) (equal doc (documentation fn t))))))) "FOO2") (deftest documentation.function.t.6 (let* ((sym (gensym)) (fn (eval `#'(lambda () ',sym))) (doc "FOO3")) (multiple-value-prog1 (setf (documentation fn t) (copy-seq doc)) (assert (or (null (documentation fn t)) (equal doc (documentation fn t)))))) "FOO3") (deftest documentation.function.t.6a (let* ((sym (gensym)) (fn (compile nil `(lambda () ',sym))) (doc "FOO3A")) (multiple-value-prog1 (setf (documentation fn t) (copy-seq doc)) (assert (or (null (documentation fn t)) (equal doc (documentation fn t)))))) "FOO3A") ;; Reorder 5, 5a and 6, 6a to expose possible interaction bug (deftest documentation.function.t.5 (let* ((sym (gensym)) (fn (eval `#'(lambda () ',sym)))) (documentation fn t)) nil) (deftest documentation.function.t.5a (let* ((sym (gensym)) (fn (compile nil `(lambda () ',sym)))) (documentation fn t)) nil) (deftest documentation.function.t.7 (let* ((sym (gensym)) (fn (eval `(defgeneric ,sym (x))))) (documentation fn t)) nil) (deftest documentation.function.t.8 (let* ((sym (gensym)) (fn (eval `(defgeneric ,sym (x)))) (doc "FOO4")) (multiple-value-prog1 (setf (documentation fn t) (copy-seq doc)) (assert (or (null (documentation fn t)) (equal doc (documentation fn t)))))) "FOO4") (deftest documentation.function.t.9 (loop for s in *cl-function-symbols* for fn = (symbol-function s) for doc = (documentation fn t) unless (or (null doc) (string doc)) collect (list s doc)) nil) (deftest documentation.function.t.10 (loop for s in *cl-accessor-symbols* for fn = (symbol-function s) for doc = (documentation fn t) unless (or (null doc) (string doc)) collect (list s doc)) nil) (deftest documentation.function.t.11 (loop for s in *cl-macro-symbols* for fn = (macro-function s) for doc = (documentation fn t) unless (or (null doc) (string doc)) collect (list s doc)) nil) (deftest documentation.function.t.12 (loop for s in *cl-standard-generic-function-symbols* for fn = (symbol-function s) for doc = (documentation fn t) unless (or (null doc) (string doc)) collect (list s doc)) nil) ;;; documentation (x function) (doc-type (eql 'function)) (deftest documentation.function.function.1 (let* ((sym (gensym))) (eval `(defun ,sym () nil)) (documentation (symbol-function sym) 'function)) nil) (deftest documentation.function.function.2 (let* ((sym (gensym))) (eval `(defun ,sym () nil)) (let ((fn (symbol-function sym)) (doc "FOO5")) (multiple-value-prog1 (setf (documentation fn 'function) (copy-seq doc)) (assert (or (null (documentation fn 'function)) (equal doc (documentation fn 'function))))))) "FOO5") (deftest documentation.function.function.3 (let* ((sym (gensym))) (eval `(defmacro ,sym () nil)) (documentation (macro-function sym) 'function)) nil) (deftest documentation.function.function.4 (let* ((sym (gensym))) (eval `(defmacro ,sym () nil)) (let ((fn (macro-function sym)) (doc "FOO6")) (multiple-value-prog1 (setf (documentation fn t) (copy-seq doc)) (assert (or (null (documentation fn 'function)) (equal doc (documentation fn 'function))))))) "FOO6") (deftest documentation.function.function.5 (let* ((sym (gensym)) (fn (eval `(defgeneric ,sym (x))))) (documentation fn 'function)) nil) (deftest documentation.function.function.8 (let* ((sym (gensym)) (fn (eval `(defgeneric ,sym (x)))) (doc "FOO4A")) (multiple-value-prog1 (setf (documentation fn t) (copy-seq doc)) (assert (or (null (documentation fn 'function)) (equal doc (documentation fn 'function)))))) "FOO4A") ;;; documentation (x list) (doc-type (eql 'function)) (deftest documentation.list.function.1 (let* ((sym (gensym))) (eval `(defun (setf ,sym) (&rest args) (declare (ignore args)) nil)) (documentation `(setf ,sym) 'function)) nil) (deftest documentation.list.function.2 (let* ((sym (gensym))) (eval `(defun (setf ,sym) (&rest args) (declare (ignore args)) nil)) (let ((fn `(setf ,sym)) (doc "FOO7")) (multiple-value-prog1 (setf (documentation fn 'function) (copy-seq doc)) (assert (or (null (documentation fn 'function)) (equal doc (documentation fn 'function))))))) "FOO7") ;;; documentation (x list) (doc-type (eql 'compiler-macro)) (deftest documentation.list.compiler-macro.1 (let* ((sym (gensym))) (eval `(define-compiler-macro (setf ,sym) (&rest args) (declare (ignore args)) nil)) (documentation `(setf ,sym) 'compiler-macro)) nil) (deftest documentation.list.compiler-macro.2 (let* ((sym (gensym))) (eval `(define-compiler-macro (setf ,sym) (&rest args) (declare (ignore args)) nil)) (let ((fn `(setf ,sym)) (doc "FOO8")) (multiple-value-prog1 (setf (documentation fn 'compiler-macro) (copy-seq doc)) (assert (or (null (documentation fn 'function)) (equal doc (documentation fn 'compiler-macro))))))) "FOO8") ;;; documentation (x symbol) (doc-type (eql 'function)) (deftest documentation.symbol.function.1 (let* ((sym (gensym))) (eval `(defun ,sym () nil)) (documentation sym 'function)) nil) (deftest documentation.symbol.function.2 (let* ((sym (gensym))) (eval `(defun ,sym () nil)) (let ((doc "FOO9")) (multiple-value-prog1 (setf (documentation sym 'function) (copy-seq doc)) (assert (or (null (documentation sym 'function)) (equal doc (documentation sym 'function))))))) "FOO9") (deftest documentation.symbol.function.3 (let* ((sym (gensym))) (eval `(defmacro ,sym () nil)) (documentation sym 'function)) nil) (deftest documentation.symbol.function.4 (let* ((sym (gensym))) (eval `(defmacro ,sym () nil)) (let ((doc "FOO9A")) (multiple-value-prog1 (setf (documentation sym 'function) (copy-seq doc)) (assert (or (null (documentation sym 'function)) (equal doc (documentation sym 'function))))))) "FOO9A") (deftest documentation.symbol.function.5 (let* ((sym (gensym))) (eval `(defgeneric ,sym (x))) (documentation sym 'function)) nil) (deftest documentation.symbol.function.6 (let* ((sym (gensym))) (eval `(defgeneric ,sym (x))) (let ((doc "FOO9B")) (multiple-value-prog1 (setf (documentation sym 'function) (copy-seq doc)) (assert (or (null (documentation sym 'function)) (equal doc (documentation sym 'function))))))) "FOO9B") (deftest documentation.symbol.function.7 (loop for s in *cl-special-operator-symbols* for doc = (documentation s 'function) unless (or (null doc) (stringp doc)) collect (list s doc)) nil) (deftest documentation.symbol.function.8 (loop for s in *cl-function-or-accessor-symbols* for doc = (documentation s 'function) unless (or (null doc) (stringp doc)) collect (list s doc)) nil) (deftest documentation.symbol.function.9 (loop for s in *cl-macro-symbols* for doc = (documentation s 'function) unless (or (null doc) (stringp doc)) collect (list s doc)) nil) ;;; documentation (x symbol) (doc-type (eql 'compiler-macro)) (deftest documentation.symbol.compiler-macro.1 (let* ((sym (gensym))) (eval `(define-compiler-macro ,sym (&rest args) (declare (ignore args)) nil)) (documentation sym 'compiler-macro)) nil) (deftest documentation.symbol.compiler-macro.2 (let* ((sym (gensym))) (eval `(define-compiler-macro ,sym (&rest args) (declare (ignore args)) nil)) (let ((doc "FOO10")) (multiple-value-prog1 (setf (documentation sym 'compiler-macro) (copy-seq doc)) (assert (or (null (documentation sym 'compiler-macro)) (equal doc (documentation sym 'compiler-macro))))))) "FOO10") ;;; documentation (x symbol) (doc-type (eql 'setf)) (deftest documentation.symbol.setf.1 (let* ((sym (gensym)) (doc "FOO11")) (eval `(defun ,sym () (declare (special *x*)) *x*)) (eval `(define-setf-expander ,sym () (let ((g (gemsym))) (values nil nil (list g) `(locally (declare (special *x*)) (setf *x* ,g)) '(locally (declare (special *x*)) *x*))))) (multiple-value-prog1 (values (documentation sym 'setf) (setf (documentation sym 'setf) (copy-seq doc))) (assert (or (null (documentation sym 'setf)) (equal doc (documentation sym 'setf)))))) nil "FOO11") (deftest documentation.symbol.setf.2 (let* ((sym (gensym)) (doc "FOO12")) (eval `(defmacro ,sym () `(locally (declare (special *x*)) *x*))) (eval `(define-setf-expander ,sym () (let ((g (gemsym))) (values nil nil (list g) `(locally (declare (special *x*)) (setf *x* ,g)) '(locally (declare (special *x*)) *x*))))) (multiple-value-prog1 (values (documentation sym 'setf) (setf (documentation sym 'setf) (copy-seq doc))) (assert (or (null (documentation sym 'setf)) (equal doc (documentation sym 'setf)))))) nil "FOO12") ;;; documentation (x method-combination) (doc-type (eql 't)) ;;; documentation (x method-combination) (doc-type (eql 'method-combination)) ;;; There's no portable way to test those, since there's no portable way to ;;; get a method combination object ;;; documentation (x symbol) (doc-type (eql 'method-combination)) (deftest documentation.symbol.method-combination.1 (let* ((sym (gensym)) (doc "FOO13")) (eval `(define-method-combination ,sym :identity-with-one-argument t)) (multiple-value-prog1 (values (documentation sym 'method-combination) (setf (documentation sym 'method-combination) (copy-seq doc))) (assert (or (null (documentation sym 'method-combination)) (equal doc (documentation sym 'method-combination)))))) nil "FOO13") ;;; documentation (x standard-method) (doc-type (eql 't)) (deftest documentation.standard-method.t.1 (let* ((sym (gensym)) (doc "FOO14")) (eval `(defgeneric ,sym (x))) (let ((method (eval `(defmethod ,sym ((x t)) nil)))) (multiple-value-prog1 (values (documentation method t) (setf (documentation method t) (copy-seq doc))) (assert (or (null (documentation method 't)) (equal doc (documentation method 't))))))) nil "FOO14") ;;; documentation (x package) (doc-type (eql 't)) (deftest documentation.package.t.1 (let ((package-name "PACKAGE-NAME-FOR-DOCUMENATION-TESTS-1")) (unwind-protect (progn (eval `(defpackage ,package-name (:use))) (let ((pkg (find-package package-name)) (doc "FOO15")) (assert pkg) (multiple-value-prog1 (values (documentation pkg t) (setf (documentation pkg t) (copy-seq doc))) (assert (or (null (documentation pkg t)) (equal doc (documentation pkg t))))))) (delete-package package-name))) nil "FOO15") ;;; documentation (x standard-class) (doc-type (eql 't)) (deftest documentation.standard-class.t.1 (let* ((sym (gensym)) (class-form `(defclass ,sym () ()))) (eval class-form) (let ((class (find-class sym)) (doc "FOO16")) (multiple-value-prog1 (values (documentation class t) (setf (documentation class t) (copy-seq doc))) (assert (or (null (documentation class t)) (equal doc (documentation class t))))))) nil "FOO16") ;;; documentation (x standard-class) (doc-type (eql 'type)) (deftest documentation.standard-class.type.1 (let* ((sym (gensym)) (class-form `(defclass ,sym () ()))) (eval class-form) (let ((class (find-class sym)) (doc "FOO17")) (multiple-value-prog1 (values (documentation class 'type) (setf (documentation class 'type) (copy-seq doc))) (assert (or (null (documentation class 'type)) (equal doc (documentation class 'type))))))) nil "FOO17") ;;; documentation (x structure-class) (doc-type (eql 't)) (deftest documentation.struct-class.t.1 (let* ((sym (gensym)) (class-form `(defstruct ,sym a b c))) (eval class-form) (let ((class (find-class sym)) (doc "FOO18")) (multiple-value-prog1 (values (documentation class t) (setf (documentation class t) (copy-seq doc))) (assert (or (null (documentation class t)) (equal doc (documentation class t))))))) nil "FOO18") ;;; documentation (x structure-class) (doc-type (eql 'type)) (deftest documentation.struct-class.type.1 (let* ((sym (gensym)) (class-form `(defstruct ,sym a b c))) (eval class-form) (let ((class (find-class sym)) (doc "FOO19")) (multiple-value-prog1 (values (documentation class 'type) (setf (documentation class 'type) (copy-seq doc))) (assert (or (null (documentation class 'type)) (equal doc (documentation class 'type))))))) nil "FOO19") ;;; documentation (x symbol) (doc-type (eql 'type)) (deftest documentation.symbol.type.1 (let* ((sym (gensym)) (class-form `(defclass ,sym () ())) (doc "FOO20")) (eval class-form) (multiple-value-prog1 (values (documentation sym 'type) (setf (documentation sym 'type) (copy-seq doc))) (assert (or (null (documentation sym 'type)) (equal doc (documentation sym 'type)))))) nil "FOO20") (deftest documentation.symbol.type.2 (let* ((sym (gensym)) (class-form `(defstruct ,sym a b c)) (doc "FOO21")) (eval class-form) (multiple-value-prog1 (values (documentation sym 'type) (setf (documentation sym 'type) (copy-seq doc))) (assert (or (null (documentation sym 'type)) (equal doc (documentation sym 'type)))))) nil "FOO21") (deftest documentation.symbol.type.3 (let* ((sym (gensym)) (type-form `(deftype ,sym () t)) (doc "FOO21A")) (eval type-form) (multiple-value-prog1 (values (documentation sym 'type) (setf (documentation sym 'type) (copy-seq doc))) (assert (or (null (documentation sym 'type)) (equal doc (documentation sym 'type)))))) nil "FOO21A") (deftest documentation.symbol.type.4 (loop for s in *cl-all-type-symbols* for doc = (documentation s 'type) unless (or (null doc) (stringp doc)) collect (list doc)) nil) ;;; documentation (x symbol) (doc-type (eql 'structure)) (deftest documentation.symbol.structure.1 (let* ((sym (gensym)) (class-form `(defstruct ,sym a b c)) (doc "FOO22")) (eval class-form) (multiple-value-prog1 (values (documentation sym 'structure) (setf (documentation sym 'structure) (copy-seq doc))) (assert (or (null (documentation sym 'structure)) (equal doc (documentation sym 'structure)))))) nil "FOO22") (deftest documentation.symbol.structure.2 (let* ((sym (gensym)) (class-form `(defstruct (,sym (:type list)) a b c)) (doc "FOO23")) (eval class-form) (multiple-value-prog1 (values (documentation sym 'structure) (setf (documentation sym 'structure) (copy-seq doc))) (assert (or (null (documentation sym 'structure)) (equal doc (documentation sym 'structure)))))) nil "FOO23") (deftest documentation.symbol.structure.3 (let* ((sym (gensym)) (class-form `(defstruct (,sym (:type vector)) a b c)) (doc "FOO24")) (eval class-form) (multiple-value-prog1 (values (documentation sym 'structure) (setf (documentation sym 'structure) (copy-seq doc))) (assert (or (null (documentation sym 'structure)) (equal doc (documentation sym 'structure)))))) nil "FOO24") ;;; documentation (x symbol) (doc-type (eql 'variable)) (deftest documentation.symbol.variable.1 (let* ((sym (gensym)) (form `(defvar ,sym)) (doc "FOO25")) (eval form) (multiple-value-prog1 (values (documentation sym 'variable) (setf (documentation sym 'variable) (copy-seq doc))) (assert (or (null (documentation sym 'variable)) (equal doc (documentation sym 'variable)))))) nil "FOO25") (deftest documentation.symbol.variable.2 (let* ((sym (gensym)) (form `(defvar ,sym t)) (doc "FOO26")) (eval form) (multiple-value-prog1 (values (documentation sym 'variable) (setf (documentation sym 'variable) (copy-seq doc))) (assert (or (null (documentation sym 'variable)) (equal doc (documentation sym 'variable)))))) nil "FOO26") (deftest documentation.symbol.variable.3 (let* ((sym (gensym)) (form `(defparameter ,sym t)) (doc "FOO27")) (eval form) (multiple-value-prog1 (values (documentation sym 'variable) (setf (documentation sym 'variable) (copy-seq doc))) (assert (or (null (documentation sym 'variable)) (equal doc (documentation sym 'variable)))))) nil "FOO27") (deftest documentation.symbol.variable.4 (let* ((sym (gensym)) (form `(defconstant ,sym t)) (doc "FOO27")) (eval form) (multiple-value-prog1 (values (documentation sym 'variable) (setf (documentation sym 'variable) (copy-seq doc))) (assert (or (null (documentation sym 'variable)) (equal doc (documentation sym 'variable)))))) nil "FOO27") (deftest documentation.symbol.variable.5 (loop for s in *cl-variable-symbols* for doc = (documentation s 'variable) unless (or (null doc) (stringp doc)) collect (list s doc)) nil) (deftest documentation.symbol.variable.6 (loop for s in *cl-constant-symbols* for doc = (documentation s 'variable) unless (or (null doc) (stringp doc)) collect (list s doc)) nil) ;;; Defining new methods for DOCUMENTATION (ignore-errors (defgeneric documentation-test-class-1-doc-accessor (obj)) (defgeneric (setf documentation-test-class-1-doc-accessor) (newdoc obj)) (defclass documentation-test-class-1 () ((my-doc :accessor documentation-test-class-1-doc-accessor :type (or null string) :initform nil))) (defmethod documentation-test-class-1-doc-accessor ((obj documentation-test-class-1) ) (slot-value obj 'my-doc)) (defmethod (setf documentation-test-class-1-doc-accessor) ((newdoc string) (obj documentation-test-class-1)) (setf (slot-value obj 'my-doc) newdoc)) (defmethod documentation ((obj documentation-test-class-1) (doctype (eql t))) (documentation-test-class-1-doc-accessor obj)) (defmethod (setf documentation) ((newdoc string) (obj documentation-test-class-1) (doctype (eql t))) (setf (documentation-test-class-1-doc-accessor obj) newdoc))) (deftest documentation.new-method.1 (let ((obj (make-instance 'documentation-test-class-1))) (values (documentation obj t) (setf (documentation obj t) "FOO28") (documentation obj t))) nil "FOO28" "FOO28") gcl27-2.7.0/ansi-tests/doit.lsp000066400000000000000000000026211454061450500162140ustar00rootroot00000000000000;;; Uncomment the next line to make MAKE-STRING and MAKE-SEQUENCE ;;; tests require that a missing :initial-element argument defaults ;;; to a single value, rather than leaving the string/sequence filled ;;; with arbitrary legal garbage. ;; (pushnew :ansi-tests-strict-initial-element *features*) #+allegro (setq *enclose-printer-errors* nil) ;;; Remove compiled files (let* ((fn (compile-file-pathname "doit.lsp")) (type (pathname-type fn)) (dir-pathname (make-pathname :name :wild :type type)) (files (directory dir-pathname))) (assert type) (assert (not (string-equal type "lsp"))) (mapc #'delete-file files)) (load "gclload1.lsp") (load "gclload2.lsp") #+allegro (progn (rt:disable-note :nil-vectors-are-strings) (rt:disable-note :standardized-package-nicknames) (rt:disable-note :type-of/strict-builtins) (rt:disable-note :assume-no-simple-streams) (rt:disable-note :assume-no-gray-streams)) #+lispworks (progn (rtest:disable-note :allow-nil-arrays) (rtest:disable-note :nil-vectors-are-strings)) ;#+gcl(si::use-fast-links nil) (in-package :cl-test) ;;; These two tests will misbehave if the tests are being ;;; invoked from a file that is being loaded, so remove them (when *load-pathname* (mapc #'regression-test:rem-test '(load-pathname.1 load-truename.1))) (time (regression-test:do-tests)) #+allegro (cl-user::exit) #+(or cmu sbcl gcl armedbear) (cl-user::quit) gcl27-2.7.0/ansi-tests/doit1.lsp000066400000000000000000000012311454061450500162710ustar00rootroot00000000000000;;; Uncomment the next line to make MAKE-STRING and MAKE-SEQUENCE ;;; tests require that a missing :initial-element argument defaults ;;; to a single value, rather than leaving the string/sequence filled ;;; with arbitrary legal garbage. ;; (pushnew :ansi-tests-strict-initial-element *features*) #+allegro (setq *enclose-printer-errors* nil) ;;; Remove compiled files (let* ((fn (compile-file-pathname "doit.lsp")) (type (pathname-type fn)) (dir-pathname (make-pathname :name :wild :type type)) (files (directory dir-pathname))) (assert type) (assert (not (string-equal type "lsp"))) (mapc #'delete-file files)) (load "gclload1.lsp") gcl27-2.7.0/ansi-tests/doit2.lsp000066400000000000000000000013011454061450500162700ustar00rootroot00000000000000#+allegro (progn (rt:disable-note :nil-vectors-are-strings) (rt:disable-note :standardized-package-nicknames) (rt:disable-note :type-of/strict-builtins) (rt:disable-note :assume-no-simple-streams) (rt:disable-note :assume-no-gray-streams)) #+lispworks (progn (rtest:disable-note :allow-nil-arrays) (rtest:disable-note :nil-vectors-are-strings)) (in-package :cl-test) ;;; These two tests will misbehave if the tests are being ;;; invoked from a file that is being loaded, so remove them (when *load-pathname* (mapc #'regression-test:rem-test '(load-pathname.1 load-truename.1))) (time (regression-test:do-tests)) #+allegro (cl-user::exit) #+(or cmu sbcl gcl armedbear) (cl-user::quit) gcl27-2.7.0/ansi-tests/dolist.lsp000066400000000000000000000055541454061450500165630ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 8 07:26:48 2005 ;;;; Contains: Tests of DOLIST (in-package :cl-test) (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)) ;;; Scope of free declarations (deftest dolist.16 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (dolist (e (return-from done x)) (declare (special x)))))) :good) (deftest dolist.17 (let ((x :good)) (declare (special x)) (let ((x :bad)) (dolist (e nil x) (declare (special x))))) :good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest dolist.18 (let ((result nil)) (macrolet ((%m (z) z)) (dolist (x (expand-in-current-env (%m '(a b c))) result) (push x result)))) (c b a)) (deftest dolist.19 (let ((result nil)) (macrolet ((%m (z) z)) (dolist (x '(a b c) (expand-in-current-env (%m result))) (push x result)))) (c b a)) ;;; Error tests (def-macro-test dolist.error.1 (dolist (x nil))) gcl27-2.7.0/ansi-tests/dostar.lsp000066400000000000000000000071231454061450500165530ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 8 07:26:22 2005 ;;;; Contains: Tests of DO* (in-package :cl-test) (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)) ;;; Scope of free declarations (deftest do*.16 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (do* ((i (return-from done x) 0)) (t nil) (declare (special x)))))) :good) (deftest do*.17 (block done (let ((x :good)) (declare (special x)) (let ((x :bad)) (do* ((i 0 (return-from done x))) (nil nil) (declare (special x)))))) :good) (deftest do*.18 (block done (let ((x :good)) (declare (special x)) (let ((x :bad)) (do* ((i 0 0)) ((return-from done x) nil) (declare (special x)))))) :good) (deftest do*.19 (let ((x :good)) (declare (special x)) (let ((x :bad)) (do* () (t x) (declare (special x))))) :good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest do*.20 (let ((result 0)) (macrolet ((%m (z) z)) (do* ((x (expand-in-current-env (%m 1)) (1+ x))) ((> x 10) result) (incf result x)))) 55) (deftest do*.21 (let ((result 0)) (macrolet ((%m (z) z)) (do* ((x 1 (expand-in-current-env (%m (1+ x))))) ((> x 10) result) (incf result x)))) 55) (deftest do*.22 (let ((result 0)) (macrolet ((%m (z) z)) (do* ((x 1 (1+ x))) ((expand-in-current-env (%m (> x 10))) result) (incf result x)))) 55) (deftest do*.23 (let ((result 0)) (macrolet ((%m (z) z)) (do* ((x 1 (1+ x))) ((> x 10) (expand-in-current-env (%m result))) (incf result x)))) 55) (def-macro-test do*.error.1 (do* ((i 0 (1+ i))) ((= i 5) 'a))) gcl27-2.7.0/ansi-tests/dotimes.lsp000066400000000000000000000076771454061450500167410ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 8 07:27:15 2005 ;;;; Contains: Tests of DOTIMES (in-package :cl-test) (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 (block done (dotimes (i -1 'good) (return-from done 'bad))) good) (deftest dotimes.7 (block done (dotimes (i (1- most-negative-fixnum) 'good) (return-from done 'bad))) good) ;;; 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.17a (let ((i 0) (y nil) (bound 4)) (declare (special i)) (flet ((%f () i)) (dotimes (i bound) (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)) (deftest dotimes.18a (let ((i 0) (y nil) (bound 4)) (declare (special i)) (flet ((%f () i)) (dotimes (i bound) (declare (special i)) (push (%f) y))) y) (3 2 1 0)) (deftest dotimes.19 (dotimes (i 100 i)) 100) (deftest dotimes.20 (dotimes (i -100 i)) 0) (deftest dotimes.21 (let ((x 0)) (dotimes (i (1- most-negative-fixnum) (values i x)) (declare (type fixnum i)) (incf x))) 0 0) ;;; Scope of free declarations (deftest dotimes.22 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (dotimes (i (return-from done x)) (declare (special x)))))) :good) (deftest dotimes.23 (let ((x :good)) (declare (special x)) (let ((x :bad)) (dotimes (i 10 x) (declare (special x))))) :good) (deftest dotimes.23a (let ((x :good) (bound 10)) (declare (special x)) (let ((x :bad)) (dotimes (i bound x) (declare (special x))))) :good) (deftest dotimes.24 (let ((bound 4) (j 0)) (values (dotimes (i bound) (incf j) (decf bound)) bound j)) nil 0 4) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest dotimes.25 (macrolet ((%m (z) z)) (let (result) (dotimes (i (expand-in-current-env (%m 4)) result) (push i result)))) (3 2 1 0)) (deftest dotimes.26 (macrolet ((%m (z) z)) (let (result) (dotimes (i 4 (expand-in-current-env (%m result))) (push i result)))) (3 2 1 0)) (def-macro-test dotimes.error.1 (dotimes (i 10))) gcl27-2.7.0/ansi-tests/dpb.lsp000066400000000000000000000040221454061450500160170ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Sep 11 20:43:54 2003 ;;;; Contains: Tests of DPB (in-package :cl-test) ;;; Error tests (deftest dpb.error.1 (signals-error (dpb) program-error) t) (deftest dpb.error.2 (signals-error (dpb 1) program-error) t) (deftest dpb.error.3 (signals-error (dpb 1 (byte 1 0)) program-error) t) (deftest dpb.error.4 (signals-error (dpb 1 (byte 1 0) 0 nil) program-error) t) ;;; Non-error tests (deftest dpb.1 (loop for pos = (random 32) for size = (random 32) for newbyte = (random (ash 1 (+ pos size))) for val = (random (1+ (random (ash 1 (+ pos size))))) for result = (dpb newbyte (byte size pos) val) repeat 100 unless (loop for i from 0 to (+ pos size) always (if (or (< i pos) (>= i (+ pos size))) (if (logbitp i val) (logbitp i result) (not (logbitp i result))) (if (logbitp (- i pos) newbyte) (logbitp i result) (not (logbitp i result))))) collect (list pos size newbyte val result)) nil) (deftest dpb.2 (loop for pos = (random 1000) for size = (random 1000) for newbyte = (random (ash 1 (+ pos size))) for val = (random (1+ (random (ash 1 (+ pos size))))) for result = (dpb newbyte (byte size pos) val) repeat 100 unless (loop for i from 0 to (+ pos size) always (if (or (< i pos) (>= i (+ pos size))) (if (logbitp i val) (logbitp i result) (not (logbitp i result))) (if (logbitp (- i pos) newbyte) (logbitp i result) (not (logbitp i result))))) collect (list pos size newbyte val result)) nil) (deftest dpb.3 (loop for x = (random-fixnum) for y = (random-fixnum) for pos = (random 32) repeat 100 always (= (dpb x (byte 0 pos) y) y)) t) (deftest dpb.4 (let ((bound (ash 1 200))) (loop for x = (random-from-interval bound) for y = (random-from-interval bound) for pos = (random 200) repeat 100 always (= (dpb x (byte 0 pos) y) y))) t) (deftest dpb.5 (loop for i of-type fixnum from -1000 to 1000 always (eql (dpb -1 (byte 0 0) i) i)) t) gcl27-2.7.0/ansi-tests/dribble.lsp000066400000000000000000000006311454061450500166570ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 15 12:56:29 2005 ;;;; Contains: Tests of DRIBBLE (in-package :cl-test) ;;; Error tests only -- cannot depend on using it in a program ;;; See the CLHS DRIBBLE and issue DRIBBLE-TECHNIQUE for an explanation (deftest dribble.error.1 (signals-error (dribble "dribble.out" nil) program-error) t) ;;; FIXME -- more error tests here gcl27-2.7.0/ansi-tests/dynamic-extent.lsp000066400000000000000000000063441454061450500202140ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 21 09:10:52 2005 ;;;; Contains: Tests of DYNAMIC-EXTENT (in-package :cl-test) (deftest dynamic-extent.1 (let () (declare (dynamic-extent))) nil) (deftest dynamic-extent.2 (let ((x 'a)) (declare (dynamic-extent x) (optimize speed (safety 0))) x) a) (deftest dynamic-extent.3 (let ((x (list 'a 'b 'c))) (declare (dynamic-extent x) (optimize speed (safety 0))) (length x)) 3) (deftest dynamic-extent.4 (let ((x (vector 'a 'b 'c))) (declare (dynamic-extent x) (optimize speed (safety 0))) (length x)) 3) (deftest dynamic-extent.5 (flet ((%f (x) (list 'a x))) (declare (dynamic-extent (function %f)) (optimize speed (safety 0))) (mapcar #'%f '(1 2 3))) ((a 1) (a 2) (a 3))) (deftest dynamic-extent.6 (labels ((%f (x) (list 'a x))) (declare (dynamic-extent (function %f)) (optimize speed (safety 0))) (mapcar #'%f '(1 2 3))) ((a 1) (a 2) (a 3))) (deftest dynamic-extent.7 (labels ((%f (x) (if (consp x) (cons (%f (car x)) (%f (cdr x))) '*))) (declare (dynamic-extent (function %f)) (optimize speed (safety 0))) (mapcar #'%f '((1) 2 (3 4 5)))) ((* . *) * (* * * . *))) (deftest dynamic-extent.8 (let ((x (+ most-positive-fixnum 2))) (declare (dynamic-extent x) (optimize speed (safety 0))) (1- x)) #.(1+ most-positive-fixnum)) (deftest dynamic-extent.9 (flet ((f () (list 'a 'b))) (let ((f (list 'c 'd))) (declare (dynamic-extent (function f)) (optimize speed (safety 0))) f)) (c d)) (deftest dynamic-extent.10 (let ((x nil)) (values x (locally (declare (dynamic-extent x) (notinline length) (optimize speed (safety 0))) (setq x (list 'a 'b 'c 'd 'e)) (prog1 (length x) (setq x t))) x)) nil 5 t) (deftest dynamic-extent.11 (let* ((x (list 'a 'b)) (y (cons 'c x))) (declare (dynamic-extent y) (optimize speed (safety 0))) (cdr y)) (a b)) (deftest dynamic-extent.12 (let* ((contents '(1 0 0 1 1 0 1 1 0 1)) (n (length contents))) (loop for i from 1 to 32 for type = `(unsigned-byte ,i) for form1 = `(make-array '(,n) :initial-contents ',contents :element-type ',type) for form2 = `(let ((a ,form1)) (declare (dynamic-extent a)) (declare (type (simple-array ,type (,n)))) (declare (notinline coerce)) (declare (optimize speed (safety 0))) (equal (coerce a 'list) ',contents)) unless (funcall (compile nil `(lambda () ,form2))) collect i)) nil) (deftest dynamic-extent.13 (let ((s (make-string 10 :initial-element #\a))) (declare (dynamic-extent s) (optimize speed (safety 0))) (notnot (every #'(lambda (c) (eql c #\a)) s))) t) (deftest dynamic-extent.14 (let ((s (make-string 10 :initial-element #\a :element-type 'base-char))) (declare (dynamic-extent s) (notinline every) (optimize speed (safety 0))) (notnot (every #'(lambda (c) (eql c #\a)) s))) t) (deftest dynamic-extent.15 (flet (((setf %f) (x y) (setf (car y) x))) (declare (dynamic-extent #'(setf %f))) :good) :good) (deftest dynamic-extent.16 (labels (((setf %f) (x y) (setf (car y) x))) (declare (dynamic-extent #'(setf %f))) :good) :good) gcl27-2.7.0/ansi-tests/ecase.lsp000066400000000000000000000064751454061450500163500ustar00rootroot00000000000000;-*- 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 (signals-type-error x 1 (ecase x)) t) (deftest ecase.3 (signals-type-error x 1 (ecase x (a 1) (b 2) (c 3))) t) ;;; It is legal to use T or OTHERWISE as key designators ;;; in ECASE forms. They have no special meaning here. (deftest ecase.4 (signals-type-error x 1 (ecase x (t nil))) t) (deftest ecase.5 (signals-type-error x 1 (ecase x (otherwise nil))) t) (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 (signals-type-error x nil (ecase x (nil 'a))) t) (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 (signals-type-error x t (ecase x (a 10))) t) (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 (signals-type-error x 'otherwise (ecase x ((t) 10))) t) (deftest ecase.16 (signals-type-error x t (ecase x ((otherwise) 10))) t) (deftest ecase.17 (signals-type-error x 'a (ecase x (b 0) (c 1) (otherwise 2))) t) (deftest ecase.18 (signals-type-error x 'a (ecase x (b 0) (c 1) ((otherwise) 2))) t) (deftest ecase.19 (signals-type-error x 'a (ecase x (b 0) (c 1) ((t) 2))) t) (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) ;;; No implicit tagbody (deftest ecase.33 (block done (tagbody (ecase 'a (a (go 10) 10 (return-from done 'bad))) 10 (return-from done 'good))) good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest ecase.34 (macrolet ((%m (z) z)) (ecase (expand-in-current-env (%m :b)) (:a :bad1) (:b :good) (:c :bad2))) :good) (deftest ecase.error.1 (signals-error (funcall (macro-function 'ecase)) program-error) t) (deftest ecase.error.2 (signals-error (funcall (macro-function 'ecase) '(ecase t)) program-error) t) (deftest ecase.error.3 (signals-error (funcall (macro-function 'ecase) '(ecase t) nil nil) program-error) t) gcl27-2.7.0/ansi-tests/echo-stream-input-stream.lsp000066400000000000000000000013461454061450500221150ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Feb 12 04:30:40 2004 ;;;; Contains: Tests of ECHO-STREAM-INPUT-STREAM (in-package :cl-test) (deftest echo-stream-input-stream.1 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (equalt (multiple-value-list (echo-stream-input-stream s)) (list is))) t) (deftest echo-stream-input-stream.error.1 (signals-error (echo-stream-input-stream) program-error) t) (deftest echo-stream-input-stream.error.2 (signals-error (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (echo-stream-input-stream s nil)) program-error) t) gcl27-2.7.0/ansi-tests/echo-stream-output-stream.lsp000066400000000000000000000013551454061450500223160ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Feb 12 04:32:33 2004 ;;;; Contains: Tests off ECHO-STREAM-OUTPUT-STREAM (in-package :cl-test) (deftest echo-stream-output-stream.1 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (equalt (multiple-value-list (echo-stream-output-stream s)) (list os))) t) (deftest echo-stream-output-stream.error.1 (signals-error (echo-stream-output-stream) program-error) t) (deftest echo-stream-output-stream.error.2 (signals-error (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (echo-stream-output-stream s nil)) program-error) t) gcl27-2.7.0/ansi-tests/ed.lsp000066400000000000000000000006141454061450500156450ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 15 13:07:39 2005 ;;;; Contains: Tests of ED (in-package :cl-test) ;;; Since the normal behavior of ED is implementation dependent, ;;; test only the error behavior (deftest ed.error.1 (signals-error (ed "ed.lsp" nil) program-error) t) ;;; Since the editor may not even be included, no other tests ;;; are possible. gcl27-2.7.0/ansi-tests/elt.lsp000066400000000000000000000237411454061450500160470ustar00rootroot00000000000000;-*- 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 (signals-error (elt nil 0) type-error) t) (deftest elt.1a (signals-error (elt nil -10) type-error) t) (deftest elt.1b (signals-error (locally (elt nil 0) t) type-error) t) (deftest elt.2 (signals-error (elt nil 1000000) type-error) t) (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 (signals-error (elt '(a b c d e) -4) type-error) t) (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 (signals-error (let ((x (list 'a 'b 'c))) (setf (elt x 4) 'd)) type-error) t) (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 (signals-error (let ((x (list 'a 'b 'c))) (elt x 10)) type-error) t) (deftest elt.15 (signals-error (let ((x (list 'a 'b 'c))) (elt x 'a)) type-error) t) (deftest elt.16 (signals-error (let ((x (list 'a 'b 'c))) (elt x 10.0)) type-error) t) (deftest elt.17 (signals-error (let ((x (list 'a 'b 'c))) (elt x -1)) type-error) t) (deftest elt.18 (signals-error (let ((x (list 'a 'b 'c))) (elt x -100000000000000000)) type-error) t) (deftest elt.19 (signals-error (let ((x (list 'a 'b 'c))) (elt x #\w)) type-error) t) (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 (signals-error (elt (make-array '(0)) 0) type-error) t) ;; (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 (signals-error (let ((x (make-array '(3) :initial-contents (list 'a 'b 'c)))) (setf (elt x 4) 'd)) type-error) t) (deftest elt-v.11 (signals-error (let ((x (make-array '(3) :initial-contents (list 'a 'b 'c)))) (setf (elt x -100) 'd)) type-error) t) (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 (signals-error (elt (make-adj-array '(0)) 0) type-error) t) ;;; (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 (signals-error (let ((x (make-adj-array '(3) :initial-contents (list 'a 'b 'c)))) (setf (elt x 4) 'd)) type-error) t) (deftest elt-adj-array.11 (signals-error (let ((x (make-adj-array '(3) :initial-contents (list 'a 'b 'c)))) (setf (elt x -100) 'd)) type-error) t) (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 (signals-error (elt (make-displaced-array '(0) 100) 0) type-error) t) (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 (signals-error (let ((a (make-array '(5) :initial-contents '(0 0 1 0 0) :fill-pointer 3))) (elt a 4)) type-error) t) (deftest elt-fill-pointer.4 (signals-error (let ((a (make-array '(5) :initial-contents '(0 0 1 0 0) :element-type 'bit :fill-pointer 3))) (elt a 4)) type-error) t) (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 (signals-error (let ((a (make-array '(5) :initial-contents '(#\a #\b #\c #\d #\e) :element-type 'character :fill-pointer 3))) (elt a 4)) type-error) t) (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 (signals-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) t) ;;; Specialized strings (deftest elt.special-strings.1 (do-special-strings (s "abcde" nil) (assert (char= (elt s 0) #\a)) (assert (char= (elt s 3) #\d)) (assert (char= (elt s 4) #\e))) nil) ;;; Specialized integer vectors (deftest elt.special-vectors.1 (do-special-integer-vectors (v #(1 1 0 1 0 1) nil) (assert (= (elt v 0) 1)) (assert (= (elt v 1) 1)) (assert (= (elt v 2) 0)) (assert (= (elt v 3) 1)) (assert (= (elt v 4) 0)) (assert (= (elt v 5) 1))) nil) (deftest elt.special-vectors.2 (do-special-integer-vectors (v #(1 2 0 -1 0 3) nil) (assert (= (elt v 0) 1)) (assert (= (elt v 1) 2)) (assert (= (elt v 2) 0)) (assert (= (elt v 3) -1)) (assert (= (elt v 4) 0)) (assert (= (elt v 5) 3))) nil) (deftest elt.special-vectors.3 (loop for type in '(short-float single-float long-float double-float) for len = 10 for vals = (loop for i from 1 to len collect (coerce i type)) for vec = (make-array len :element-type type :initial-contents vals) unless (loop for i below len always (eql (elt vec i) (coerce (1+ i) type))) collect (list type vals vec)) nil) (deftest elt.special-vectors.4 (loop for etype in '(short-float single-float long-float double-float integer rational) for type = `(complex ,etype) for len = 10 for vals = (loop for i from 1 to len collect (complex (coerce i etype) (coerce (- i) etype))) for vec = (make-array len :element-type type :initial-contents vals) unless (loop for i below len always (eql (elt vec i) (elt vals i))) collect (list type vals vec)) nil) ;;; Error tests (deftest elt.error.1 (signals-error (elt) program-error) t) (deftest elt.error.2 (signals-error (elt nil) program-error) t) (deftest elt.error.3 (signals-error (elt nil 0 nil) program-error) t) (deftest elt.error.4 (do-special-integer-vectors (v #(1 1 0 1 0 1) nil) (assert (eql t (eval `(signals-error (elt ,v -1) type-error)))) (assert (eql t (eval `(signals-error (elt ,v 6) type-error))))) nil) (deftest elt.error.5 (do-special-strings (s "ABCDEFGH" nil) (assert (eql t (eval `(signals-error (elt ,s -1) type-error)))) (assert (eql t (eval `(signals-error (elt ,s 8) type-error))))) nil) gcl27-2.7.0/ansi-tests/encode-universal-time.lsp000066400000000000000000000063661454061450500214660ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 8 12:54:34 2005 ;;;; Contains: Tests of ENCODE-UNIVERSAL-TIME ;;; See also the tests in decode-universal-time.lsp (in-package :cl-test) (deftest encode-universal-time.1 (loop with count = 0 for year = (+ 1900 (random 1000)) ;; Gregorian leap year algorithm for leap? = (and (= (mod year 4) 0) (or (/= (mod year 100) 0) (= (mod year 400) 0))) for month = (1+ (random 12)) for date = (1+ (random (elt (if leap? #(0 31 29 31 30 31 30 31 31 30 31 30 31) #(0 31 28 31 30 31 30 31 31 30 31 30 31)) month))) for hour = (random 24) for minute = (random 60) for second = (random 60) for tz = (if (and (= year 1900) (= date 0) (= month 0)) (random 25) (- (random 49) 24)) for time = (encode-universal-time second minute hour date month year tz) for decoded-vals = (multiple-value-list (decode-universal-time time tz)) for vals = (list second minute hour date month year (elt decoded-vals 6) nil tz) repeat 20000 unless (equal vals decoded-vals) collect (progn (incf count) (list vals time decoded-vals)) until (>= count 100)) nil) #| (deftest encode-universal-time.2 (loop with count = 0 for year = (+ 1901 (random 1000)) ;; Gregorian leap year algorithm for leap? = (and (= (mod year 4) 0) (or (/= (mod year 100) 0) (= (mod year 400) 0))) for month = (1+ (random 12)) for date = (1+ (random (elt (if leap? #(0 31 29 31 30 31 30 31 31 30 31 30 31) #(0 31 28 31 30 31 30 31 31 30 31 30 31)) month))) for hour = (random 24) for minute = (random 60) for second = (random 60) for time = (encode-universal-time second minute hour date month year) for decoded-vals = (multiple-value-list (decode-universal-time time)) for vals = (list second minute hour date month year (elt decoded-vals 6) (elt decoded-vals 7) (elt decoded-vals 8)) repeat 20000 unless (equal vals decoded-vals) collect (progn (incf count) (list vals time decoded-vals)) until (>= count 100)) nil) |# (deftest encode-universal-time.3 (loop with count = 0 for year = (+ 1900 (random 1000)) ;; Gregorian leap year algorithm for leap? = (and (= (mod year 4) 0) (or (/= (mod year 100) 0) (= (mod year 400) 0))) for month = (1+ (random 12)) for date = (1+ (random (elt (if leap? #(0 31 29 31 30 31 30 31 31 30 31 30 31) #(0 31 28 31 30 31 30 31 31 30 31 30 31)) month))) for hour = (random 24) for minute = (random 60) for second = (random 60) for tz = (/ (if (and (= year 1900) (= date 0) (= month 0)) (random (1+ (* 24 3600))) (- (random (1+ (* 48 3600))) (* 24 3600))) 3600) for time = (encode-universal-time second minute hour date month year tz) for decoded-vals = (multiple-value-list (decode-universal-time time tz)) for vals = (list second minute hour date month year (elt decoded-vals 6) nil tz) repeat 20000 unless (equal vals decoded-vals) collect (progn (incf count) (list vals time decoded-vals)) until (>= count 100)) nil) ;;; Error cases (deftest encode-universal-time.error.1 (signals-error (encode-universal-time 0 0 0 1 1) program-error) t) (deftest encode-universal-time.error.2 (signals-error (encode-universal-time 0 0 0 1 1 1901 0 nil) program-error) t) gcl27-2.7.0/ansi-tests/endp.lsp000066400000000000000000000013141454061450500162010ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:34:40 1998 ;;;; Contains: Tests of ENDP (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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.error.1 (check-type-error #'endp #'listp) nil) (deftest endp.error.4 (signals-error (endp) program-error) t) (deftest endp.error.5 (signals-error (endp nil nil) program-error) t) (deftest endp.error.6 (signals-error (locally (endp 1)) type-error) t) gcl27-2.7.0/ansi-tests/enough-namestring.lsp000066400000000000000000000044051454061450500207110ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 12 06:23:50 2004 ;;;; Contains: Tests of ENOUGH-NAMESTRING (in-package :cl-test) (deftest enough-namestring.1 (let* ((vals (multiple-value-list (enough-namestring "enough-namestring.lsp"))) (s (first vals))) (if (and (null (cdr vals)) (stringp s) (equal (enough-namestring s) s)) :good vals)) :good) (deftest enough-namestring.2 (do-special-strings (s "enough-namestring.lsp" nil) (let ((ns (enough-namestring s))) (assert (stringp ns)) (assert (string= (enough-namestring ns) ns)))) nil) (deftest enough-namestring.3 (let* ((name "enough-namestring.lsp") (pn (merge-pathnames (pathname name))) (name2 (enough-namestring pn)) (name3 (enough-namestring name))) (or (equalt name2 name3) (list name2 name3))) t) (deftest enough-namestring.4 (let* ((name "enough-namestring.lsp") (pn (merge-pathnames (pathname name))) (name2 (with-open-file (s pn :direction :input) (enough-namestring s))) (name3 (enough-namestring name))) (or (equalt name2 name3) (list name2 name3))) t) (deftest enough-namestring.5 (let* ((vals (multiple-value-list (enough-namestring "enough-namestring.lsp" *default-pathname-defaults*))) (s (first vals))) (if (and (null (cdr vals)) (stringp s) (equal (enough-namestring s) s)) :good vals)) :good) (deftest enough-namestring.6 (let* ((vals (multiple-value-list (enough-namestring "enough-namestring.lsp" (namestring *default-pathname-defaults*)))) (s (first vals))) (if (and (null (cdr vals)) (stringp s) (equal (enough-namestring s) s)) :good vals)) :good) (deftest enough-namestring.7 (do-special-strings (s (namestring *default-pathname-defaults*) nil) (let* ((vals (multiple-value-list (enough-namestring "enough-namestring.lsp" s))) (s2 (first vals))) (assert (null (cdr vals))) (assert (stringp s2)) (assert (equal (enough-namestring s2) s2)))) nil) ;;; Error tests (deftest enough-namestring.error.1 (signals-error (enough-namestring) program-error) t) (deftest enough-namestring.error.2 (signals-error (enough-namestring "enough-namestring.lsp" *default-pathname-defaults* nil) program-error) t) gcl27-2.7.0/ansi-tests/ensure-directories-exist.lsp000066400000000000000000000115521454061450500222250ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 5 20:53:03 2004 ;;;; Contains: Tests of ENSURE-DIRECTORIES-EXIST (in-package :cl-test) (deftest ensure-directories-exist.1 (let* ((pn (make-pathname :name "ensure-directories-exist.lsp" :defaults *default-pathname-defaults*)) (results nil) (verbosity (with-output-to-string (*standard-output*) (setq results (multiple-value-list (ensure-directories-exist pn)))))) (values (length results) (equalt (truename pn) (truename (first results))) (second results) verbosity)) 2 t nil "") (deftest ensure-directories-exist.2 (with-open-file (s "ensure-directories-exist.lsp" :direction :input) (let* ((results (multiple-value-list (ensure-directories-exist s)))) (values (length results) (equalt (truename (first results)) (truename s)) (second results)))) 2 t nil) (deftest ensure-directories-exist.3 (let ((s (open "ensure-directories-exist.lsp" :direction :input))) (close s) (let* ((results (multiple-value-list (ensure-directories-exist s)))) (values (length results) (equalt (truename (first results)) (truename s)) (second results)))) 2 t nil) (deftest ensure-directories-exist.4 (let* ((pn (make-pathname :name "ensure-directories-exist.lsp" :defaults *default-pathname-defaults*)) (results nil) (verbosity (with-output-to-string (*standard-output*) (setq results (multiple-value-list (ensure-directories-exist pn :verbose nil)))))) (values (length results) (equalt (truename pn) (truename (first results))) (second results) verbosity)) 2 t nil "") (deftest ensure-directories-exist.5 (let* ((pn (make-pathname :name "ensure-directories-exist.lsp" :defaults *default-pathname-defaults*)) (results nil) (verbosity (with-output-to-string (*standard-output*) (setq results (multiple-value-list (ensure-directories-exist pn :verbose t)))))) (values (length results) (equalt (truename pn) (truename (first results))) (second results) verbosity)) 2 t nil "") (deftest ensure-directories-exist.6 (let* ((pn (make-pathname :name "ensure-directories-exist.lsp" :defaults *default-pathname-defaults*)) (results nil) (verbosity (with-output-to-string (*standard-output*) (setq results (multiple-value-list (ensure-directories-exist pn :allow-other-keys nil)))))) (values (length results) (equalt (truename pn) (truename (first results))) (second results) verbosity)) 2 t nil "") (deftest ensure-directories-exist.7 (let* ((pn (make-pathname :name "ensure-directories-exist.lsp" :defaults *default-pathname-defaults*)) (results nil) (verbosity (with-output-to-string (*standard-output*) (setq results (multiple-value-list (ensure-directories-exist pn :allow-other-keys t :nonsense t)))))) (values (length results) (equalt (truename pn) (truename (first results))) (second results) verbosity)) 2 t nil "") ;;; Case where directory shouldn't exist ;; The directort ansi-tests/scratch must not exist before this ;; test is run (deftest ensure-directories-exist.8 (let* ((subdir (make-pathname :directory '(:relative "scratch") :defaults *default-pathname-defaults*)) (pn (make-pathname :name "foo" :type "txt" :defaults subdir))) #+gcl(progn (mapc 'delete-file (directory "./scratch/*"))(si::rmdir "scratch")) (assert (not (probe-file pn)) () "Delete subdirectory scratch and its contents!") (let* ((results nil) (verbosity (with-output-to-string (*standard-output*) (setq results (multiple-value-list (ensure-directories-exist pn))))) (result-pn (first results)) (created (second results))) ;; Create the file and write to it (with-open-file (*standard-output* pn :direction :output :if-exists :error :if-does-not-exist :create) (print nil)) (values (length results) (notnot created) (equalt pn result-pn) (notnot (probe-file pn)) verbosity ))) 2 t t t "") ;;; Specialized string tests (deftest ensure-directories-exist.9 (do-special-strings (str "ensure-directories-exist.lsp" nil) (let* ((results (multiple-value-list (ensure-directories-exist str)))) (assert (eql (length results) 2)) (assert (equalt (truename (first results)) (truename str))) (assert (null (second results))))) nil) ;; FIXME ;; Need to add a LPN test (deftest ensure-directories-exist.error.1 (signals-error-always (ensure-directories-exist (make-pathname :directory '(:relative :wild) :defaults *default-pathname-defaults*)) file-error) t t) (deftest ensure-directories-exist.error.2 (signals-error (ensure-directories-exist) program-error) t) gcl27-2.7.0/ansi-tests/ensure-generic-function.lsp000066400000000000000000000137351454061450500220230ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Mar 27 21:29:53 2003 ;;;; Contains: Tests for ENSURE-GENERIC-FUNCTION (in-package :cl-test) (deftest ensure-generic-function.1 (if (typep #'car 'generic-function) t (signals-error (ensure-generic-function 'car) error)) t) (deftest ensure-generic-function.2 (signals-error (ensure-generic-function 'defclass) error) t) (deftest ensure-generic-function.3 (signals-error (ensure-generic-function 'tagbody) error) t) (deftest ensure-generic-function.4 (let ((f 'egf-fun-4)) (when (fboundp f) (fmakunbound f)) (values (fboundp f) (notnot-mv (typep (ensure-generic-function f) 'generic-function)) (notnot-mv (typep (ensure-generic-function f) 'generic-function)) (notnot-mv (typep (symbol-function f) 'generic-function)))) nil t t t) (deftest ensure-generic-function.5 (let ((f 'egf-fun-5)) (when (fboundp f) (fmakunbound f)) (values (fboundp f) (notnot-mv (typep (ensure-generic-function f :lambda-list '(a b c)) 'generic-function)) ;; Test of incongruent generic function lambda list when no ;; methods exist (notnot-mv (typep (ensure-generic-function f :lambda-list '(x y)) 'generic-function)) (notnot-mv (typep (symbol-function f) 'generic-function)))) nil t t t) (deftest ensure-generic-function.6 (let ((f 'egf-fun-6)) (when (fboundp f) (fmakunbound f)) (values (fboundp f) (notnot-mv (typep (ensure-generic-function f :lambda-list '(a b c)) 'generic-function)) (notnot-mv (eval `(defmethod ,f ((a t)(b t)(c t)) (list a b c)))) ;; Test of incongruent generic function lambda list when no ;; methods exist (eval `(signals-error (ensure-generic-function ',f :lambda-list '(x y)) error)))) nil t t t) (deftest ensure-generic-function.7 (let ((f 'egf-fun-7)) (when (fboundp f) (fmakunbound f)) (let ((fn (eval `(defgeneric ,f (x) (:method ((x symbol)) (list x :a)) (:method ((x integer)) (list x :b)) (:method ((x t)) (list x :c)))))) (values (mapcar fn '(x 2 3/2)) (eqlt fn (ensure-generic-function f :lambda-list '(x))) (mapcar fn '(x 2 3/2))))) ((x :a) (2 :b) (3/2 :c)) t ((x :a) (2 :b) (3/2 :c))) (deftest ensure-generic-function.8 (let ((f 'egf-fun-8)) (when (fboundp f) (fmakunbound f)) (let ((fn (eval `(defgeneric ,f (x y) (:method ((x t) (y symbol)) 1) (:method ((x symbol) (y t)) 2))))) (values (mapcar fn '(a a 3) '(b 4 b)) (eqlt fn (ensure-generic-function f :lambda-list '(x y) :argument-precedence-order '(y x))) (mapcar fn '(a a 3) '(b 4 b))))) (2 2 1) t (1 2 1)) (deftest ensure-generic-function.9 (let ((f 'egf-fun-9)) (when (fboundp f) (fmakunbound f)) (let ((fn (eval `(defgeneric ,f (x) (:method-combination +) (:method + ((x t)) 1) (:method + ((x symbol)) 2) (:method + ((x (eql nil))) 4))))) (values (mapcar fn '(3/2 a nil)) (eqlt fn (ensure-generic-function f :lambda-list '(x) :method-class 'standard-method)) (mapcar fn '(3/2 a nil)) (eqlt fn (ensure-generic-function f :lambda-list '(x) :method-class (find-class 'standard-method))) (mapcar fn '(3/2 a nil))))) (1 3 7) t (1 3 7) t (1 3 7)) (deftest ensure-generic-function.10 (let ((f 'egf-fun-10)) (when (fboundp f) (fmakunbound f)) (let ((fn (eval `(defgeneric ,f (x) (:method ((x t)) 1))))) (values (funcall fn 'a) (eqlt fn (ensure-generic-function f :lambda-list '(x) :generic-function-class 'standard-generic-function)) (funcall fn 'a) (eqlt fn (ensure-generic-function f :lambda-list '(x) :generic-function-class (find-class 'standard-generic-function))) (funcall fn 'a)))) 1 t 1 t 1) (deftest ensure-generic-function.11 (let ((f 'egf-fun-11)) (when (fboundp f) (fmakunbound f)) (let ((fn (eval `(defgeneric ,f (x) (:method ((x t)) 1))))) (values (funcall fn 'a) (eqlt fn (eval `(macrolet ((%m (&environment env) (ensure-generic-function ',f :lambda-list '(x) :environment env))) (%m)))) (funcall fn 'a)))) 1 t 1) (deftest ensure-generic-function.12 (let ((f 'egf-fun-12)) (when (fboundp f) (fmakunbound f)) (let ((fn (eval `(defgeneric ,f (x) (:documentation "foo") (:method ((x t)) 1))))) (values (funcall fn 'a) (or (documentation f 'function) "foo") (eqlt fn (ensure-generic-function f :lambda-list '(x) :documentation "bar")) (or (documentation f 'function) "bar") (funcall fn 'a)))) 1 "foo" t "bar" 1) (deftest ensure-generic-function.13 (let ((f 'egf-fun-13)) (when (fboundp f) (fmakunbound f)) (let ((fn (eval `(defgeneric ,f (x y) (declare (optimize safety (speed 0) (debug 0) (space 0))) (:method ((x t) (y t)) (list x y)))))) (values (funcall fn 'a 'b) (eqlt fn (ensure-generic-function f :lambda-list '(x y) :declare '((optimize (safety 0) (debug 2) speed (space 1))))) (funcall fn 'a 1)))) (a b) t (a 1)) (deftest ensure-generic-function.14 (let ((f '(setf egf-fun-14))) (when (fboundp f) (fmakunbound f)) (let ((fn (eval `(defgeneric ,f (val x) (:method ((val t) (x cons)) (setf (car x) val)))))) (values (let ((z (cons 'a 'b))) (list (setf (egf-fun-14 z) 'c) z)) (eqlt fn (ensure-generic-function f :lambda-list '(val x))) (let ((z (cons 'a 'b))) (list (setf (egf-fun-14 z) 'c) z))))) (c (c . b)) t (c (c . b))) ;;; Many more tests are needed for other combinations of keyword parameters (deftest ensure-generic-function.error.1 (signals-error (ensure-generic-function) program-error) t) (deftest ensure-generic-function.error.2 (signals-error (ensure-generic-function (gensym) :lambda-list) program-error) t) gcl27-2.7.0/ansi-tests/environment-functions.lsp000066400000000000000000000015261454061450500216320ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Dec 11 22:15:54 2004 ;;;; Contains: Tests of various string-returning functions from section 25 (in-package :cl-test) (defmacro def-env-tests (fn-name) (flet ((%name (suffix) (intern (concatenate 'string (symbol-name fn-name) suffix) (find-package :cl-test)))) `(progn (deftest ,(%name ".1") (let ((x (,fn-name))) (or (not x) (notnot (stringp x)))) t) (deftest ,(%name ".ERROR.1") (signals-error (,fn-name nil) program-error) t)))) (def-env-tests lisp-implementation-type) (def-env-tests lisp-implementation-version) (def-env-tests short-site-name) (def-env-tests long-site-name) (def-env-tests machine-instance) (def-env-tests machine-type) (def-env-tests machine-version) (def-env-tests software-type) (def-env-tests software-version) gcl27-2.7.0/ansi-tests/epsilons.lsp000066400000000000000000000065171454061450500171210ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 20 22:05:20 2003 ;;;; Contains: Tests of the EPSILON constants (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (deftest epsilons.1 (loop for e in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) when (= (float 1 e) (+ (float 1 e) e)) collect e) nil) (deftest epsilons.2 (loop for e in (list short-float-negative-epsilon single-float-negative-epsilon double-float-negative-epsilon long-float-negative-epsilon) when (= (float 1 e) (- (float 1 e) e)) collect e) nil) (deftest epsilons.3 (loop for e in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) unless (= (float 1 e) (+ (float 1 e) (/ e 2))) collect e) nil) (deftest epsilons.4 (loop for e in (list short-float-negative-epsilon single-float-negative-epsilon double-float-negative-epsilon long-float-negative-epsilon) unless (= (float 1 e) (- (float 1 e) (/ e 2))) collect e) nil) (deftest epsilons.5 (loop for (type var) in '( (short-float short-float-epsilon) (short-float short-float-negative-epsilon) (single-float single-float-epsilon) (single-float single-float-negative-epsilon) (double-float double-float-epsilon) (double-float double-float-negative-epsilon) (long-float long-float-epsilon) (long-float long-float-negative-epsilon)) for val = (symbol-value var) unless (typep val type) collect (list type var val)) nil) (deftest epsilons.6 (flet ((%check (x) (/= 1.0s0 (+ 1.0s0 x)))) (let ((eps (float-binary-search #'%check 0.0s0 1.0s0))) (if (= eps short-float-epsilon) :good (list eps short-float-epsilon)))) :good) (deftest epsilons.7 (flet ((%check (x) (/= 1.0f0 (+ 1.0f0 x)))) (let ((eps (float-binary-search #'%check 0.0f0 1.0f0))) (if (= eps single-float-epsilon) :good (list eps single-float-epsilon)))) :good) (deftest epsilons.8 (flet ((%check (x) (/= 1.0d0 (+ 1.0d0 x)))) (let ((eps (float-binary-search #'%check 0.0d0 1.0d0))) (if (= eps double-float-epsilon) :good (list eps double-float-epsilon)))) :good) (deftest epsilons.9 (flet ((%check (x) (/= 1.0l0 (+ 1.0l0 x)))) (let ((eps (float-binary-search #'%check 0.0l0 1.0l0))) (if (= eps long-float-epsilon) :good (list eps long-float-epsilon)))) :good) (deftest epsilons.10 (flet ((%check (x) (/= 1.0s0 (- 1.0s0 x)))) (let ((eps (float-binary-search #'%check 0.0s0 1.0s0))) (if (= eps short-float-negative-epsilon) :good (list eps short-float-negative-epsilon)))) :good) (deftest epsilons.11 (flet ((%check (x) (/= 1.0f0 (- 1.0f0 x)))) (let ((eps (float-binary-search #'%check 0.0f0 1.0f0))) (if (= eps single-float-negative-epsilon) :good (list eps single-float-negative-epsilon)))) :good) (deftest epsilons.12 (flet ((%check (x) (/= 1.0d0 (- 1.0d0 x)))) (let ((eps (float-binary-search #'%check 0.0d0 1.0d0))) (if (= eps double-float-negative-epsilon) :good (list eps double-float-negative-epsilon)))) :good) (deftest epsilons.13 (flet ((%check (x) (/= 1.0l0 (- 1.0l0 x)))) (let ((eps (float-binary-search #'%check 0.0l0 1.0l0))) (if (= eps long-float-negative-epsilon) :good (list eps long-float-negative-epsilon)))) :good) gcl27-2.7.0/ansi-tests/eql.lsp000066400000000000000000000026221454061450500160370ustar00rootroot00000000000000;-*- 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 (check-predicate #'(lambda (x) (eql x x))) nil) (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) ;;; Error tests for EQL (deftest eql.error.1 (signals-error (eql) program-error) t) (deftest eql.error.2 (signals-error (eql nil) program-error) t) (deftest eql.error.3 (signals-error (eql nil nil nil) program-error) t) ;;; Error tests for EQ (deftest eq.error.1 (signals-error (eq) program-error) t) (deftest eq.error.2 (signals-error (eq nil) program-error) t) (deftest eq.error.3 (signals-error (eq nil nil nil) program-error) t) gcl27-2.7.0/ansi-tests/equal.lsp000066400000000000000000000054161454061450500163710ustar00rootroot00000000000000;-*- 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.13 :notes (:nil-vectors-are-strings) (let ((x (make-array '(0) :element-type nil)) (y (make-array '(0) :element-type nil))) (equalt x y)) t) (deftest equal.14 :notes (:nil-vectors-are-strings) (and (equalt (make-array '(0) :element-type nil) "") (equalt "" (make-array '(0) :element-type nil))) t) (deftest equal.15 (equalt (make-array '(0) :element-type 'character) (make-array '(0) :element-type 'base-char)) t) (deftest equal.16 (equalt "abc" (make-array '(3) :element-type 'base-char :initial-contents '(#\a #\b #\c))) t) (deftest equal.17 (let ((s (make-array '(10) :element-type 'character :initial-contents "0123456789" :fill-pointer 3))) (values (equalt s "012") (equalt "012" s))) t t) (deftest equal.18 (let ((b (make-array '(10) :element-type 'bit :initial-contents #*0110001110 :fill-pointer 5))) (values (equalt #*01100 b) (equalt #*01100 b))) t t) (deftest equal.19 (let ((s (make-array '(10) :element-type 'base-char :initial-contents "0123456789" :fill-pointer 3))) (values (equalt s "012") (equalt "012" s))) t t) ;;; Should add more pathname equality tests (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) ;;; Error tests (deftest equal.error.1 (signals-error (equal) program-error) t) (deftest equal.error.2 (signals-error (equal nil) program-error) t) (deftest equal.error.3 (signals-error (equal nil nil nil) program-error) t) gcl27-2.7.0/ansi-tests/equalp.lsp000066400000000000000000000157611454061450500165550ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 17 22:14:42 2002 ;;;; Contains: Tests for EQUALP (in-package :cl-test) (compile-and-load "random-aux.lsp") (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.5 :notes (:allow-nil-arrays) (equalpt (make-array '(0) :element-type nil) #()) t) (deftest equalp.6 :notes (:allow-nil-arrays) (equalpt (make-array '(0) :element-type nil) "") t) (deftest equalp.7 (loop for nbits from 1 to 100 for type = `(unsigned-byte ,nbits) for bound = (ash 1 nbits) for val = (random bound) for a1 = (make-array nil :initial-element val :element-type type) for a2 = (make-array nil :initial-element val) unless (equalp a1 a2) collect (list nbits type val)) nil) (deftest equalp.8 (loop for nbits from 1 to 100 for type = `(unsigned-byte ,nbits) for bound = (ash 1 nbits) for n = (1+ (random 20)) for vals = (loop repeat n collect (random bound)) for a1 = (make-array n :initial-contents vals :element-type type) for a2 = (make-array n :initial-contents vals) unless (equalp a1 a2) collect (list nbits type vals)) nil) (deftest equalp.9 (loop for nbits from 1 to 100 for type = `(signed-byte ,nbits) for bound = (ash 1 nbits) for n = (1+ (random 20)) for vals = (loop repeat n collect (- (random bound) (/ bound 2))) for a1 = (make-array n :initial-contents vals :element-type type) for a2 = (make-array n :initial-contents vals) unless (equalp a1 a2) collect (list nbits type vals)) nil) (deftest equalp.10 (equalpt #*0010 #(0 0 1 0)) t) (deftest equalp.11 (let ((v1 #(1 2 3)) (v2 (make-array 8 :initial-contents '(1 2 3 4 5 6 7 8) :fill-pointer 3))) (equalpt v1 v2)) t) (deftest equalp.12 (equalpt '(#\a #\b) "ab") nil) (deftest equalp.13 (equalpt '(#\a #\b) '(#\A #\B)) t) (deftest equalp.14 (let ((s1 (make-array '(4) :initial-contents '(#\a #\b #\c #\d) :element-type 'base-char)) (s2 (make-array '(4) :initial-contents '(#\a #\b #\c #\d) :element-type 'character))) (equalpt s1 s2)) t) (deftest equalp.15 (let ((bv (make-array '(4) :initial-contents '(0 0 1 0) :element-type 'bit)) (v #(0 0 1 0))) (equalpt bv v)) t) (defstruct equalp-struct-16 a b c) (defstruct equalp-struct-16-alt a b c) (deftest equalp.16 (let ((s1 (make-equalp-struct-16 :a 1 :b 2 :c #\a)) (s2 (make-equalp-struct-16 :a 1.0 :b 2.0 :c #\A)) (s3 (make-equalp-struct-16-alt :a 1.0 :b 2.0 :c #\A))) (values (equalpt s1 s2) (equalpt s1 s3) (equalpt s2 s3))) t nil nil) (deftest equalp.17 (loop for i below 8192 for f = (float i 1.0s0) repeat 1000 unless (equalp i f) collect (list i f)) nil) (deftest equalp.18 (loop for i = (- (random 10000000) 5000000) for f = (float i 1.0f0) repeat 1000 unless (equalp i f) collect (list i f)) nil) (deftest equalp.19 (loop for i = (- (random 10000000) 5000000) for f = (float i 1.0d0) repeat 1000 unless (equalp i f) collect (list i f)) nil) (deftest equalp.20 (loop for i = (- (random 10000000) 5000000) for f = (float i 1.0l0) repeat 1000 unless (equalp i f) collect (list i f)) nil) (deftest equalp.21 (let ((ht1 (make-hash-table :test #'eq)) (ht2 (make-hash-table :test #'eql)) (ht3 (make-hash-table :test #'equal)) (ht4 (make-hash-table :test #'equalp))) (values (equalpt ht1 ht2) (equalpt ht1 ht3) (equalpt ht1 ht4) (equalpt ht2 ht3) (equalpt ht2 ht4) (equalpt ht3 ht4))) nil nil nil nil nil nil) (deftest equalp.22 (equalpt (make-hash-table :test 'eq) (make-hash-table :test #'eq)) t) (deftest equalp.23 (equalpt (make-hash-table :test 'eql) (make-hash-table :test #'eql)) t) (deftest equalp.24 (equalpt (make-hash-table :test 'equal) (make-hash-table :test #'equal)) t) (deftest equalp.25 (equalpt (make-hash-table :test 'equalp) (make-hash-table :test #'equalp)) t) (deftest equalp.26 (let ((ht1 (make-hash-table :test #'eq)) (ht2 (make-hash-table :test #'eq))) (setf (gethash #\a ht1) t) (setf (gethash #\A ht2) t) (equalpt ht1 ht2)) nil) (deftest equalp.27 (let ((ht1 (make-hash-table :test #'eq)) (ht2 (make-hash-table :test #'eq))) (setf (gethash 'a ht1) #\a) (setf (gethash 'a ht2) #\A) (equalpt ht1 ht2)) t) (deftest equalp.28 (let ((ht1 (make-hash-table :test #'eql)) (ht2 (make-hash-table :test #'eql))) (setf (gethash #\a ht1) t) (setf (gethash #\A ht2) t) (equalpt ht1 ht2)) nil) (deftest equalp.29 (let ((ht1 (make-hash-table :test #'eql)) (ht2 (make-hash-table :test #'eql))) (setf (gethash #\a ht1) "a") (setf (gethash #\a ht2) "A") (equalpt ht1 ht2)) t) (deftest equalp.30 (let ((ht1 (make-hash-table :test #'equal)) (ht2 (make-hash-table :test #'equal))) (setf (gethash #\a ht1) t) (setf (gethash #\A ht2) t) (equalpt ht1 ht2)) nil) (deftest equalp.31 (let ((ht1 (make-hash-table :test #'equal)) (ht2 (make-hash-table :test #'equal))) (setf (gethash #\a ht1) "a") (setf (gethash #\a ht2) "A") (equalpt ht1 ht2)) t) (deftest equalp.32 (let ((ht1 (make-hash-table :test #'equalp)) (ht2 (make-hash-table :test #'equalp))) (setf (gethash #\a ht1) t) (setf (gethash #\A ht2) t) (equalpt ht1 ht2)) t) (deftest equalp.33 (let ((ht1 (make-hash-table :test #'equalp)) (ht2 (make-hash-table :test #'equalp))) (setf (gethash #\a ht1) "a") (setf (gethash #\a ht2) "A") (equalpt ht1 ht2)) t) (deftest equalp.34 (let ((ht1 (make-hash-table :test #'equalp)) (ht2 (make-hash-table :test #'equalp))) (setf (gethash '#:a ht1) t) (setf (gethash '#:a ht2) t) (equalpt ht1 ht2)) nil) (deftest equalp.35 (loop for test in '(eq eql equal equalp) collect (flet ((%make-table () (apply #'make-hash-table :test test `(,@(when (coin) (list :size (random 100))) ,@(when (coin) (list :rehash-size (1+ (random 50)))) ,@(when (coin) (list :rehash-threshold (random 1.0)) ))))) (loop repeat 200 count (let ((ht1 (%make-table)) (ht2 (%make-table)) (pairs (loop for i below (random 100) collect (cons (gensym) i)))) (loop for (k . v) in pairs do (setf (gethash k ht1) v)) (setf pairs (random-permute pairs)) (loop for (k . v) in pairs do (setf (gethash k ht2) v)) (not (equalp ht1 ht2)))))) (0 0 0 0)) (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) ;;; Error tests (deftest equalp.error.1 (signals-error (equalp) program-error) t) (deftest equalp.error.2 (signals-error (equalp nil) program-error) t) (deftest equalp.error.3 (signals-error (equalp nil nil nil) program-error) t) gcl27-2.7.0/ansi-tests/error.lsp000066400000000000000000000042771454061450500164170ustar00rootroot00000000000000;-*- 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) (declare (ignore c)) :wrong) (simple-condition (c) (declare (ignore c)) :right)) :right) (deftest error.7 (handler-case (error 'simple-warning) (error (c) (declare (ignore c)) :wrong) (simple-warning (c) (declare (ignore c)) :right) (condition (c) (declare (ignore 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) (deftest error.9 (let ((fmt (formatter "Boo!"))) (handler-case (error 'simple-warning :format-control fmt) (simple-warning (c) (frob-simple-warning c fmt)))) t) (deftest error.10 (let ((fmt (formatter "Error"))) (handler-case (error 'simple-error :format-control fmt) (simple-error (c) (frob-simple-error c fmt)))) t) (deftest error.11 (let ((fmt (formatter "Error"))) (handler-case (error fmt) (simple-error (c) (frob-simple-error c fmt)))) t) (deftest error.12 (let* ((fmt (formatter "Error")) (cnd (make-condition 'simple-error :format-control fmt))) (handler-case (error cnd) (simple-error (c) (frob-simple-error c fmt)))) t) ;;; Tests for other conditions will in their own files. gcl27-2.7.0/ansi-tests/etypecase.lsp000066400000000000000000000063101454061450500172360ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 23:02:23 2002 ;;;; Contains: Tests of ETYPECASE (in-package :cl-test) (compile-and-load "types-aux.lsp") (deftest etypecase.1 (etypecase 1 (integer 'a) (t 'b)) a) (deftest etypecase.2 (signals-type-error x 1 (etypecase x (symbol 'a))) t) (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) (deftest etypecase.13 (block nil (tagbody (let ((x 'a)) (etypecase x (symbol (go 10) 10 (return 'bad)))) 10 (return 'good))) good) (deftest etypecase.14 (loop for x in '(1 a 1.3 "") collect (etypecase x (t :good) (integer :bad) (symbol :bad) (float :bad) (string :bad))) (:good :good :good :good)) (deftest etypecase.15 (let* ((u (coerce *universe* 'vector)) (len1 (length u)) (types (coerce *cl-all-type-symbols* 'vector)) (len2 (length types))) (loop for n = (random 10) for my-types = (loop repeat n collect (elt types (random len2))) for val = (elt u (random len1)) for i = (position val my-types :test #'typep) for form = `(function (lambda (x) (handler-case (etypecase x ,@(loop for i from 0 for type in my-types collect `(,type ,i))) (type-error (c) (assert (eql x (type-error-datum c))) (let* ((expected (type-error-expected-type c))) (let ((equiv (check-equivalence expected ',(cons 'or my-types)))) (assert (null equiv) () "EQUIV = ~A" EQUIV))) nil)))) for j = (funcall (eval form) val) repeat 200 unless (eql i j) collect (list n my-types val i form j))) nil) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest etypecase.16 (macrolet ((%m (z) z)) (etypecase (expand-in-current-env (%m :foo)) (integer :bad1) (keyword :good) (symbol :bad2))) :good) (deftest etypecase.17 (macrolet ((%m (z) z)) (etypecase :foo (integer (expand-in-current-env (%m :bad1))) (keyword (expand-in-current-env (%m :good))) (symbol (expand-in-current-env (%m :bad2))))) :good) ;;; Error cases (deftest etypecase.error.1 (signals-error (funcall (macro-function 'etypecase)) program-error) t) (deftest etypecase.error.2 (signals-error (funcall (macro-function 'etypecase) '(etypecase t)) program-error) t) (deftest etypecase.error.3 (signals-error (funcall (macro-function 'etypecase) '(etypecase t) nil nil) program-error) t) gcl27-2.7.0/ansi-tests/eval-and-compile.lsp000066400000000000000000000011411454061450500203660ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/eval-when.lsp000066400000000000000000000073561454061450500171550ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 6 17:00:30 2003 ;;;; Contains: Tests for EVAL-WHEN ;;; The following test was suggested by Sam Steingold, ;;; so I've created this file to hold it. (in-package :cl-test) (defvar *eval-when.1-collector*) (deftest eval-when.1 (let ((forms nil) all (ff "generated-eval-when-test-file.lisp")) (dolist (c '(nil (:compile-toplevel))) (dolist (l '(nil (:load-toplevel))) (dolist (x '(nil (:execute))) (push `(eval-when (,@c ,@l ,@x) (push '(,@c ,@l ,@x) *eval-when.1-collector*)) forms)))) (dolist (c '(nil (:compile-toplevel))) (dolist (l '(nil (:load-toplevel))) (dolist (x '(nil (:execute))) (push `(let () (eval-when (,@c ,@l ,@x) (push '(let ,@c ,@l ,@x) *eval-when.1-collector*))) forms)))) (with-open-file (o ff :direction :output :if-exists :supersede) (dolist (f forms) (prin1 f o) (terpri o))) (let ((*eval-when.1-collector* nil)) (load ff) (push (cons "load source" *eval-when.1-collector*) all)) (let ((*eval-when.1-collector* nil)) (compile-file ff) (push (cons "compile source" *eval-when.1-collector*) all)) (let ((*eval-when.1-collector* nil)) (load (compile-file-pathname ff)) (push (cons "load compiled" *eval-when.1-collector*) all)) (delete-file ff) (delete-file (compile-file-pathname ff)) #+clisp (delete-file (make-pathname :type "lib" :defaults ff)) (nreverse all)) (("load source" (:execute) (:load-toplevel :execute) (:compile-toplevel :execute) (:compile-toplevel :load-toplevel :execute) (let :execute) (let :load-toplevel :execute) (let :compile-toplevel :execute) (let :compile-toplevel :load-toplevel :execute)) ("compile source" (:compile-toplevel) (:compile-toplevel :execute) (:compile-toplevel :load-toplevel) (:compile-toplevel :load-toplevel :execute)) ("load compiled" (:load-toplevel) (:load-toplevel :execute) (:compile-toplevel :load-toplevel) (:compile-toplevel :load-toplevel :execute) (let :execute) (let :load-toplevel :execute) (let :compile-toplevel :execute) (let :compile-toplevel :load-toplevel :execute)))) ;;; More EVAL-WHEN tests to go here (deftest eval-when.2 (eval-when () :bad) nil) (deftest eval-when.3 (eval-when (:execute)) nil) (deftest eval-when.4 (eval-when (:execute) :good) :good) (deftest eval-when.5 (eval-when (:compile-toplevel) :bad) nil) (deftest eval-when.6 (eval-when (:load-toplevel) :bad) nil) (deftest eval-when.7 (eval-when (:compile-toplevel :execute) :good) :good) (deftest eval-when.8 (eval-when (:load-toplevel :execute) :good) :good) (deftest eval-when.9 (eval-when (:load-toplevel :compile-toplevel) :bad) nil) (deftest eval-when.10 (eval-when (:load-toplevel :compile-toplevel :execute) :good) :good) (deftest eval-when.11 (eval-when (:execute) (values 'a 'b 'c 'd)) a b c d) (deftest eval-when.12 (let ((x :good)) (values (eval-when (:load-toplevel) (setq x :bad)) x)) nil :good) (deftest eval-when.13 (let ((x :good)) (values (eval-when (:compile-toplevel) (setq x :bad)) x)) nil :good) (deftest eval-when.14 (let ((x :bad)) (values (eval-when (:execute) (setq x :good)) x)) :good :good) (deftest eval-when.15 (let ((x :good)) (values (eval-when (load) (setq x :bad)) x)) nil :good) (deftest eval-when.16 (let ((x :good)) (values (eval-when (compile) (setq x :bad)) x)) nil :good) (deftest eval-when.17 (let ((x :bad)) (values (eval-when (eval) (setq x :good)) x)) :good :good) ;;; Macros are expanded in the appropriate environment (deftest eval-when.18 (macrolet ((%m (z) z)) (eval-when (:execute) (expand-in-current-env (%m :good)))) :good) gcl27-2.7.0/ansi-tests/eval.lsp000066400000000000000000000017031454061450500162040ustar00rootroot00000000000000;-*- 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 (signals-error (eval) program-error) t) (deftest eval.error.2 (signals-error (eval nil nil) program-error) t) (deftest eval.error.3 (let ((v (gensym))) (eval `(signals-error (eval (list ',v)) undefined-function :name ,v))) t) (deftest eval.error.4 (let ((v (gensym))) (eval `(signals-error (eval ',v) unbound-variable :name ,v))) t)gcl27-2.7.0/ansi-tests/evenp.lsp000066400000000000000000000026521454061450500163760ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 31 10:39:01 2003 ;;;; Contains: Tests of EVENP (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (deftest evenp.error.1 (signals-error (evenp) program-error) t) (deftest evenp.error.2 (signals-error (evenp 0 nil) program-error) t) (deftest evenp.error.3 (check-type-error #'evenp #'integerp) nil) (deftest evenp.1 (loop for x in *numbers* when (integerp x) do (evenp x)) nil) (deftest evenp.3 (loop for x = (random-fixnum) repeat 10000 when (or (not (evenp (+ x x))) (evenp (+ x x 1)) (if (evenp x) (or (evenp (1+ x)) (evenp (1- x)) (/= (mod x 2) 0)) (or (not (evenp (1+ x))) (not (evenp (1- x))) (= (mod x 2) 0)))) collect x) nil) (deftest evenp.4 (let ((upper-bound 1000000000000000) (lower-bound -1000000000000000)) (loop for x = (random-from-interval upper-bound lower-bound) repeat 10000 when (or (not (evenp (+ x x))) (evenp (+ x x 1)) (if (evenp x) (or (evenp (1+ x)) (evenp (1- x)) (/= (mod x 2) 0)) (or (not (evenp (1+ x))) (not (evenp (1- x))) (= (mod x 2) 0)))) collect x)) nil) (deftest evenp.5 (notnot-mv (evenp 0)) t) (deftest evenp.6 (evenp 1) nil) (deftest evenp.7 (notnot-mv (evenp 100000000000000000000000000000000)) t) (deftest evenp.8 (evenp 100000000000000000000000000000001) nil) gcl27-2.7.0/ansi-tests/every.lsp000066400000000000000000000174311454061450500164140ustar00rootroot00000000000000;-*- 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) ;;; Other specialized sequences (deftest every.17 (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 2 3 4 5 6) :fill-pointer 4))) (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (notnot (every #'zerop v)))) (t t t t t nil nil nil nil nil)) (deftest every.18 (loop for i from 1 to 40 for type = `(unsigned-byte ,i) unless (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 1 1 1 1 1) :element-type type :fill-pointer 4))) (equal (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (notnot (every #'zerop v))) '(t t t t t nil nil nil nil nil))) collect i) nil) (deftest every.19 (loop for i from 1 to 40 for type = `(signed-byte ,i) unless (let ((v (make-array '(10) :initial-contents '(0 0 0 0 -1 -1 -1 -1 -1 -1) :element-type type :fill-pointer 4))) (equal (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (notnot (every #'zerop v))) '(t t t t t nil nil nil nil nil))) collect i) nil) (deftest every.20 (let ((v (make-array '(10) :initial-contents "abcd012345" :element-type 'character :fill-pointer 4))) (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (notnot (every #'alpha-char-p v)))) (t t t t t nil nil nil nil nil)) (deftest every.21 (let ((v (make-array '(10) :initial-contents "abcd012345" :element-type 'base-char :fill-pointer 4))) (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (notnot (every #'alpha-char-p v)))) (t t t t t nil nil nil nil nil)) (deftest every.22 (let ((v (make-array '(5) :initial-contents "abcde" :element-type 'base-char))) (values (notnot (every #'alpha-char-p v)) (setf (aref v 2) #\0) (every #'alpha-char-p v))) t #\0 nil) ;;; Displaced vectors (deftest every.23 (let* ((v1 (make-array '(10) :initial-contents '(1 3 2 4 6 8 5 7 9 1))) (v2 (make-array '(4) :displaced-to v1 :displaced-index-offset 2))) (values (every #'evenp v1) (notnot (every 'evenp v2)))) nil t) (deftest every.24 (loop for i from 1 to 40 for type = `(unsigned-byte ,i) unless (let* ((v1 (make-array '(10) :initial-contents '(1 1 0 0 0 0 1 1 1 1) :element-type type)) (v2 (make-array '(4) :displaced-to v1 :displaced-index-offset 2 :element-type type))) (and (not (every 'evenp v1)) (every #'evenp v2))) collect i) nil) (deftest every.25 (loop for i from 1 to 40 for type = `(signed-byte ,i) unless (let* ((v1 (make-array '(10) :initial-contents '(-1 -1 0 0 0 0 -1 -1 -1 -1) :element-type type)) (v2 (make-array '(4) :displaced-to v1 :displaced-index-offset 2 :element-type type))) (and (not (every 'evenp v1)) (every #'evenp v2))) collect i) nil) (deftest every.26 (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'character))) (loop for i from 0 to 6 for s2 = (make-array '(2) :element-type 'character :displaced-to s1 :displaced-index-offset i) collect (notnot (every 'alpha-char-p s2)))) (nil nil t t nil nil nil)) (deftest every.27 (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'base-char))) (loop for i from 0 to 6 for s2 = (make-array '(2) :element-type 'base-char :displaced-to s1 :displaced-index-offset i) collect (notnot (every 'alpha-char-p s2)))) (nil nil t t nil nil nil)) ;;; adjustable vectors (deftest every.28 (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) :adjustable t))) (values (notnot (every #'plusp v)) (progn (adjust-array v '(11) :initial-element -1) (every #'plusp v)))) t nil) (deftest every.29 (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) :fill-pointer 10 :adjustable t))) (values (notnot (every #'plusp v)) (progn (adjust-array v '(11) :initial-element -1) (every #'plusp v)))) t t) ;;; Float, complex vectors (deftest every.30 (loop for type in '(short-float single-float double-float long-float) for v = (make-array '(6) :element-type type :initial-contents (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6))) unless (every #'plusp v) collect (list type v)) nil) (deftest every.31 (loop for type in '(short-float single-float double-float long-float) for v = (make-array '(6) :element-type type :fill-pointer 5 :initial-contents (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 -1))) unless (every #'plusp v) collect (list type v)) nil) (deftest every.32 (loop for type in '(short-float single-float double-float long-float) for ctype = `(complex ,type) for v = (make-array '(6) :element-type ctype :initial-contents (mapcar #'(lambda (x) (complex x (coerce x type))) '(1 2 3 4 5 6))) unless (every #'complexp v) collect (list type v)) nil) ;;; Order of arguments (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 (check-type-error #'(lambda (x) (every x '(a b c))) #'(lambda (x) (typep x '(or function symbol)))) nil) (deftest every.error.2 (check-type-error #'(lambda (x) (every #'null x)) #'(lambda (x) (typep x 'sequence))) nil) (deftest every.error.3 (check-type-error #'(lambda (x) (every #'eq () x)) #'(lambda (x) (typep x 'sequence))) nil) (deftest every.error.8 (signals-error (every) program-error) t) (deftest every.error.9 (signals-error (every #'null) program-error) t) (deftest every.error.10 (signals-error (locally (every 1 '(a b c)) t) type-error) t) (deftest every.error.11 (signals-error (every #'cons '(a b c)) program-error) t) (deftest every.error.12 (signals-error (every #'cons '(a b c) '(1 2 3) '(4 5 6)) program-error) t) (deftest every.error.13 (signals-error (every #'car '(a b c)) type-error) t) (deftest every.error.14 (signals-error (every #'identity '(1 2 3 . 4)) type-error) t) gcl27-2.7.0/ansi-tests/exp-aux.lsp000066400000000000000000000010171454061450500166420ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Sep 1 21:30:38 2003 ;;;; Contains: Aux. functions for testing EXP, EXPT (in-package :cl-test) (defun my-exp (x n) "Compute e^x in the appropriate float result type, summing the first n terms of the Taylor series." (assert (realp x)) (let ((result 1) (xrat (rational x))) (loop for i from (1- n) downto 1 do (setq result (+ 1 (/ (* xrat result) i)))) (if (floatp x) (float result x) (float result 1.0f0)))) gcl27-2.7.0/ansi-tests/exp.lsp000066400000000000000000000037371454061450500160620ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Sep 1 21:24:44 2003 ;;;; Contains: Tests of EXP (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "exp-aux.lsp") ;;; Error tests (deftest exp.error.1 (signals-error (exp) program-error) t) (deftest exp.error.2 (signals-error (exp 0 nil) program-error) t) (deftest exp.error.3 (signals-error (exp 0 0 0) program-error) t) ;;; Other tests (deftest exp.1 (let ((result (exp 0))) (or (eqlt result 1) (eqlt result 1.0f0))) t) (deftest exp.2 (mapcar #'exp '(0.0s0 0.0f0 0.0d0 0.0l0)) (1.0s0 1.0f0 1.0d0 1.0l0)) (deftest exp.3 (mapcar #'exp '(-0.0s0 -0.0f0 -0.0d0 -0.0l0)) (1.0s0 1.0f0 1.0d0 1.0l0)) ;;; FIXME ;;; Add more tests here for floating point accuracy (defun texp (x) #+gcl(si::break-on-floating-point-exceptions :floating-point-overflow t :floating-point-underflow t) (unwind-protect (exp x) #+gcl(si::break-on-floating-point-exceptions :floating-point-overflow nil :floating-point-underflow nil))) (deftest exp.error.4 (signals-error (texp (+ (log most-positive-short-float) 100)) floating-point-overflow) t) (deftest exp.error.5 (signals-error (texp (+ (log most-positive-single-float) 100)) floating-point-overflow) t) (deftest exp.error.6 (signals-error (texp (+ (log most-positive-double-float) 100)) floating-point-overflow) t) (deftest exp.error.7 (signals-error (texp (+ (log most-positive-long-float) 100)) floating-point-overflow) t) (deftest exp.error.8 (signals-error (texp (- (log least-positive-short-float) 100)) floating-point-underflow) t) (deftest exp.error.9 (signals-error (texp (- (log least-positive-single-float) 100)) floating-point-underflow) t) (deftest exp.error.10 (signals-error (texp (- (log least-positive-double-float) 100)) floating-point-underflow) t) (deftest exp.error.11 (signals-error (texp (- (log least-positive-double-float) 100)) floating-point-underflow) t) gcl27-2.7.0/ansi-tests/export.lsp000066400000000000000000000050671454061450500166050ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 07:59:45 1998 ;;;; Contains: Tests of EXPORT (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 (progn (set-up-packages) (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 (signals-error (export) program-error) t) (deftest export.error.2 (signals-error (export 'X "CL-TEST" NIL) program-error) t) gcl27-2.7.0/ansi-tests/expt.lsp000066400000000000000000000122241454061450500162350ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Sep 2 19:36:22 2003 ;;;; Contains: Tests of EXPT (in-package :cl-test) ;;; Error tests (defun texpt (x y) #+gcl(si::break-on-floating-point-exceptions :floating-point-overflow t :floating-point-underflow t) (unwind-protect (expt x y) #+gcl(si::break-on-floating-point-exceptions :floating-point-overflow nil :floating-point-underflow nil))) (deftest expt.error.1 (signals-error (expt) program-error) t) (deftest expt.error.2 (signals-error (expt 1 1 1) program-error) t) (deftest expt.error.3 (signals-error (expt 1 1 nil nil) program-error) t) (deftest expt.error.4 (signals-error (texpt most-positive-short-float 2) floating-point-overflow) t) (deftest expt.error.5 (signals-error (texpt most-positive-single-float 2) floating-point-overflow) t) (deftest expt.error.6 (signals-error (texpt most-positive-double-float 2) floating-point-overflow) t) (deftest expt.error.7 (signals-error (texpt most-positive-long-float 2) floating-point-overflow) t) (deftest expt.error.8 (signals-error (texpt least-positive-short-float 2) floating-point-underflow) t) (deftest expt.error.9 (signals-error (texpt least-positive-single-float 2) floating-point-underflow) t) (deftest expt.error.10 (signals-error (texpt least-positive-double-float 2) floating-point-underflow) t) (deftest expt.error.11 (signals-error (texpt least-positive-long-float 2) floating-point-underflow) t) ;;; Non-error tests (deftest expt.1 (expt 0 0) 1) (deftest expt.2 (loop for i from -1000 to 1000 always (eql (expt i 0) 1)) t) (deftest expt.3 (loop for i = (random 1.0s3) repeat 1000 always (eql (expt i 0) 1.0s0)) t) (deftest expt.4 (loop for i = (random 1.0f6) repeat 1000 always (eql (expt i 0) 1.0f0)) t) (deftest expt.5 (loop for i = (random 1.0d10) repeat 1000 always (eql (expt i 0) 1.0d0)) t) (deftest expt.6 (loop for i = (random 1.0l10) repeat 1000 always (eql (expt i 0) 1.0l0)) t) (deftest expt.7 (loop for i from -1000 to 1000 for c = (complex i i) always (eql (expt c 0) 1)) t) (deftest expt.8 (loop for i = (random 1.0s3) for c = (complex i i) repeat 1000 always (eql (expt c 0) #c(1.0s0 0.0s0))) t) (deftest expt.9 (loop for i = (random 1.0f6) for c = (complex i i) repeat 1000 always (eql (expt c 0) #c(1.0f0 0.0f0))) t) (deftest expt.10 (loop for i = (random 1.0d10) for c = (complex i i) repeat 1000 always (eql (expt c 0) #c(1.0d0 0.0d0))) t) (deftest expt.11 (loop for i = (random 1.0l10) for c = (complex i i) repeat 1000 always (eql (expt c 0) #c(1.0l0 0.0l0))) t) (deftest expt.12 (loop for x in *numbers* unless (or (floatp (realpart x)) (eql (expt x 1) x)) collect x) nil) (deftest expt.13 (loop for x in *rationals* unless (and (eql (expt x 2) (* x x)) (or (zerop x) (eql (expt x -1) (/ x)))) collect x) nil) (deftest expt.14 (expt #c(0 2) 2) -4) (deftest expt.15 (expt #c(1 1) 2) #c(0 2)) (deftest expt.16 (expt #c(1/2 1/3) 3) #c(-1/24 23/108)) (deftest expt.17 (expt #c(1 1) -2) #c(0 -1/2)) (deftest expt.18 (loop for zero in '(0.0s0 0.0f0 0.0d0 0.0l0) always (loop for i from -1000 to 1000 always (or (zerop i) (eql (expt i zero) (float 1 zero))))) t) (deftest expt.19 (loop for zero in '(0.0s0 0.0f0 0.0d0 0.0l0) always (loop for i from -1000 to 1000 always (or (zerop i) (eql (expt (float i 0.0s0) zero) (float 1 zero))))) t) (deftest expt.20 (loop for zero in '(0.0f0 0.0d0 0.0l0) always (loop for i from -1000 to 1000 always (or (zerop i) (eql (expt (float i 0.0f0) zero) (float 1 zero))))) t) (deftest expt.21 (loop for zero in '(0.0d0 0.0l0) always (loop for i from -1000 to 1000 always (or (zerop i) (eql (expt (float i 0.0d0) zero) (float 1 zero))))) t) (deftest expt.22 (expt 2.0f0 0.0s0) 1.0f0) (deftest expt.23 (expt 2.0d0 0.0s0) 1.0d0) (deftest expt.24 (expt 2.0l0 0.0s0) 1.0l0) (deftest expt.25 (expt 2.0d0 0.0f0) 1.0d0) (deftest expt.26 (expt 2.0l0 0.0f0) 1.0l0) (deftest expt.27 (expt 2.0l0 0.0d0) 1.0l0) (deftest expt.28 (<= (realpart (expt -8 1/3)) 0.0) nil) #| ;;; FIXME ;;; I need to think more about how to do approximate float ;;; equality in a principled way. (deftest expt.29 (loop for bound in '(1.0s4 1.0f6 1.0d8 1.0l8) for ebound in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for ebound2 = (max (* 2 ebound) (/ bound)) nconc (loop for x = (1+ (random 1.0f6)) for s1 = (sqrt x) for s2 = (expt x 1/2) for error = (/ (abs (- s2 s2)) x) repeat 1000 unless (< error ebound2) collect (list x s1 s2))) nil) (deftest expt.30 (loop for bound in '(1.0s4 1.0f6 1.0d8 1.0l8) for ebound in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for ebound2 = (max (* 2 ebound) (/ bound)) nconc (loop for x = (- (1+ (random 1.0f6))) for s1 = (sqrt x) for s2 = (expt x 1/2) for error = (/ (abs (- s2 s2)) x) repeat 1000 unless (< error ebound2) collect (list x s1 s2))) nil) |# gcl27-2.7.0/ansi-tests/fboundp.lsp000066400000000000000000000040401454061450500167070ustar00rootroot00000000000000;-*- 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) (report-and-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) ;;; See 11.1.2.1.1 (deftest fboundp.8 (loop for x in *cl-non-function-macro-special-operator-symbols* when (and (fboundp x) (not (eq x 'ed))) collect x) nil) (deftest fboundp.order.1 (let ((i 0)) (values (notnot (fboundp (progn (incf i) 'car))) i)) t 1) (deftest fboundp.error.1 (check-type-error #'fboundp #'(lambda (x) (typep x '(or symbol (cons (eql setf) (cons symbol null)))))) nil) (deftest fboundp.error.2 (signals-type-error x '(x) (fboundp x)) t) (deftest fboundp.error.3 (signals-type-error x '(setf) (fboundp x)) t) (deftest fboundp.error.4 (signals-type-error x '(setf foo . bar) (fboundp x)) t) (deftest fboundp.error.5 (signals-type-error x '(setf foo bar) (fboundp x)) t) (deftest fboundp.error.6 (signals-error (fboundp) program-error) t) (deftest fboundp.error.7 (signals-error (fboundp 'cons nil) program-error) t) (deftest fboundp.error.8 (signals-error (locally (fboundp 1) t) type-error) t) (deftest fboundp.error.9 (signals-type-error x '(setf . foo) (fboundp x)) t) (deftest fboundp.error.10 (loop for x in *mini-universe* unless (symbolp x) nconc (handler-case (list x (fboundp `(setf ,x))) (type-error (c) (assert (not (typep (type-error-datum c) (type-error-expected-type c)))) nil) (error (c) (list (list x c))))) nil) gcl27-2.7.0/ansi-tests/fceiling-aux.lsp000066400000000000000000000007471454061450500176370ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 20 06:24:45 2003 ;;;; Contains: Tests of FCEILING (in-package :cl-test) (defun fceiling.1-fn () (loop for n = (- (random 200000) 100000) for d = (1+ (random 10000)) for vals = (multiple-value-list (fceiling n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 100 unless (and (eql (length vals) 2) (floatp q) (= n n2) (integerp r) (< (- d) r 1)) collect (list n d q r n2))) gcl27-2.7.0/ansi-tests/fceiling.lsp000066400000000000000000000071351454061450500170420ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 20 06:22:23 2003 ;;;; Contains: Tests of FCEILING (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "fceiling-aux.lsp") (deftest fceiling.error.1 (signals-error (fceiling) program-error) t) (deftest fceiling.error.2 (signals-error (fceiling 1.0 1 nil) program-error) t) ;;; (deftest fceiling.1 (fceiling.1-fn) nil) (deftest fceiling.10 (loop for x in (remove-if #'zerop *reals*) for (q r) = (multiple-value-list (fceiling x x)) unless (and (floatp q) (if (floatp x) (eql q (float 1 x)) (= q 1)) (zerop r) (if (floatp x) (eql r (float 0 x)) (= r 0))) collect x) nil) (deftest fceiling.11 (loop for x in (remove-if-not #'floatp (remove-if #'zerop *reals*)) for (q r) = (multiple-value-list (fceiling (- x) x)) unless (and (floatp q) (if (floatp x) (eql q (float -1 x)) (= q -1)) (zerop r) (if (floatp x) (eql r (float 0 x)) (= r 0))) collect x) nil) (deftest fceiling.12 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (fceiling x)) unless (and (eql q (coerce (1+ i) 'short-float)) (eql r (- rrad 1))) collect (list i x q r))) nil) (deftest fceiling.13 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (fceiling x)) unless (and (eql q (coerce i 'short-float)) (eql r (- rrad 1))) collect (list i x q r))) nil) (deftest fceiling.14 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (fceiling x)) unless (and (eql q (coerce (1+ i) 'single-float)) (eql r (- rrad 1))) collect (list i x q r))) nil) (deftest fceiling.15 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (fceiling x)) unless (and (eql q (coerce i 'single-float)) (eql r (- rrad 1))) collect (list i x q r))) nil) (deftest fceiling.16 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (fceiling x)) unless (and (eql q (coerce (1+ i) 'double-float)) (eql r (- rrad 1))) collect (list i x q r))) nil) (deftest fceiling.17 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (fceiling x)) unless (and (eql q (coerce i 'double-float)) (eql r (- rrad 1))) collect (list i x q r))) nil) (deftest fceiling.18 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (fceiling x)) unless (and (eql q (coerce (1+ i) 'long-float)) (eql r (- rrad 1))) collect (list i x q r))) nil) (deftest fceiling.19 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (fceiling x)) unless (and (eql q (coerce i 'long-float)) (eql r (- rrad 1))) collect (list i x q r))) nil) gcl27-2.7.0/ansi-tests/fdefinition.lsp000066400000000000000000000042241454061450500175540ustar00rootroot00000000000000;-*- 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 (signals-error (fdefinition) program-error) t) (deftest fdefinition.error.2 (signals-error (fdefinition 'cons nil) program-error) t) (deftest fdefinition.error.3 (let ((v (gensym))) (eval `(signals-error (fdefinition ',v) undefined-function :name ,v))) t) (deftest fdefinition.error.4 (check-type-error #'fdefinition #'(lambda (x) (typep x '(or symbol (cons (eql setf) (cons symbol null)))))) nil) ;;; (deftest fdefinition.error.5 ;;; (let ((fn `(setf ,(gensym)))) ;;; (eval `(signals-error (fdefinition ',fn) undefined-function ;;; :name ,fn))) ;;; t) (deftest fdefinition.error.6 (signals-error (locally (fdefinition 10) t) type-error) t) (deftest fdefinition.error.7 (check-type-error #'fdefinition (constantly nil) '((setf) (setf . foo) (setf foo . bar) (setf foo bar))) nil) (deftest fdefinition.error.8 (loop for x in *mini-universe* unless (symbolp x) nconc (handler-case (list x (fdefinition `(setf ,x))) (type-error (c) (assert (not (typep (type-error-datum c) (type-error-expected-type c)))) nil) (error (c) (list (list x c))))) nil) ;;; 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) gcl27-2.7.0/ansi-tests/features.lsp000066400000000000000000000010731454061450500170730ustar00rootroot00000000000000;-*- 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) (deftest features.4 (notnot (every #'symbolp *features*)) t) gcl27-2.7.0/ansi-tests/ffloor-aux.lsp000066400000000000000000000007621454061450500173430ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Aug 12 07:02:07 2003 ;;;; Contains: Aux. functions used in FFLOOR tests (in-package :cl-test) (defun ffloor.1-fn () (loop for n = (- (random 200000) 100000) for d = (1+ (random 10000)) for vals = (multiple-value-list (ffloor n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 100 unless (and (eql (length vals) 2) (floatp q) (= n n2) (integerp r) (< -1 r d)) collect (list n d q r n2))) gcl27-2.7.0/ansi-tests/ffloor.lsp000066400000000000000000000071451454061450500165520ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Aug 12 06:59:54 2003 ;;;; Contains: Tests of FFLOOR (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "ffloor-aux.lsp") (deftest ffloor.error.1 (signals-error (ffloor) program-error) t) (deftest ffloor.error.2 (signals-error (ffloor 1.0 1 nil) program-error) t) ;;; (deftest ffloor.1 (ffloor.1-fn) nil) (deftest ffloor.10 (loop for x in (remove-if #'zerop *reals*) for (q r) = (multiple-value-list (ffloor x x)) unless (and (floatp q) (if (floatp x) (eql q (float 1 x)) (= q 1)) (zerop r) (if (floatp x) (eql r (float 0 x)) (= r 0))) collect x) nil) (deftest ffloor.11 (loop for x in (remove-if-not #'floatp (remove-if #'zerop *reals*)) for (q r) = (multiple-value-list (ffloor (- x) x)) unless (and (floatp q) (if (floatp x) (eql q (float -1 x)) (= q -1)) (zerop r) (if (floatp x) (eql r (float 0 x)) (= r 0))) collect x) nil) (deftest ffloor.12 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (ffloor x)) unless (and (eql q (coerce i 'short-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest ffloor.13 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (ffloor x)) unless (and (eql q (coerce (1- i) 'short-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest ffloor.14 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (ffloor x)) unless (and (eql q (coerce i 'single-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest ffloor.15 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (ffloor x)) unless (and (eql q (coerce (1- i) 'single-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest ffloor.16 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (ffloor x)) unless (and (eql q (coerce i 'double-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest ffloor.17 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (ffloor x)) unless (and (eql q (coerce (1- i) 'double-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest ffloor.18 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (ffloor x)) unless (and (eql q (coerce i 'long-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest ffloor.19 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (ffloor x)) unless (and (eql q (coerce (1- i) 'long-float)) (eql r rrad)) collect (list i x q r))) nil) ;;; To add: tests that involve adding/subtracting EPSILON constants ;;; (suitably scaled) to floated integers. gcl27-2.7.0/ansi-tests/file-author.lsp000066400000000000000000000037411454061450500175000ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 6 05:41:06 2004 ;;;; Contains: Tests of FILE-AUTHOR (in-package :cl-test) (deftest file-author.1 (loop for pn in (directory (make-pathname :name :wild :type :wild :defaults *default-pathname-defaults*)) for author = (file-author pn) unless (or (null author) (stringp author)) collect (list pn author)) nil) (deftest file-author.2 (let ((author (file-author "file-author.lsp"))) (if (or (null author) (stringp author)) nil author)) nil) (deftest file-author.3 (let ((author (file-author #p"file-author.lsp"))) (if (or (null author) (stringp author)) nil author)) nil) (deftest file-author.4 (let ((author (file-author (truename "file-author.lsp")))) (if (or (null author) (stringp author)) nil author)) nil) (deftest file-author.5 (let ((author (with-open-file (s "file-author.lsp" :direction :input) (file-author s)))) (if (or (null author) (stringp author)) nil author)) nil) (deftest file-author.6 (let ((author (let ((s (open "file-author.lsp" :direction :input))) (close s) (file-author s)))) (if (or (null author) (stringp author)) nil author)) nil) ;;; Specialized string tests (deftest file-author.7 (do-special-strings (s "file-author.lsp" nil) (assert (equal (file-author s) (file-author "file-author.lsp")))) nil) ;;; FIXME ;;; Add LPN test ;;; Error tests (deftest file-author.error.1 (signals-error (file-author) program-error) t) (deftest file-author.error.2 (signals-error (file-author "file-author.lsp" nil) program-error) t) (deftest file-author.error.3 (signals-error-always (file-author (make-pathname :name :wild :type "lsp" :defaults *default-pathname-defaults*)) file-error) t t) (deftest file-author.error.4 (signals-error-always (file-author (make-pathname :name "file-author" :type :wild :defaults *default-pathname-defaults*)) file-error) t t) gcl27-2.7.0/ansi-tests/file-error.lsp000066400000000000000000000047211454061450500173260ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 13 19:10:02 2004 ;;;; Contains: Tests of the FILE-ERROR condition, and associated accessor function (in-package :cl-test) (deftest file-error.1 (let ((pn (make-pathname :name :wild :type "txt" :version :newest :defaults *default-pathname-defaults*))) (handler-case (probe-file pn) (error (c) (values (notnot (typep c 'file-error)) (if (equalp (file-error-pathname c) pn) t (list (file-error-pathname c) pn)))))) t t) (deftest file-error-pathname.1 (let ((c (make-condition 'file-error :pathname "foo.txt"))) (values (notnot (typep c 'file-error)) (eqlt (class-of c) (find-class 'file-error)) (file-error-pathname c))) t t "foo.txt") (deftest file-error-pathname.2 (let ((c (make-condition 'file-error :pathname #p"foo.txt"))) (values (notnot (typep c 'file-error)) (eqlt (class-of c) (find-class 'file-error)) (equalt #p"foo.txt" (file-error-pathname c)))) t t t) (deftest file-error-pathname.3 (let ((c (make-condition 'file-error :pathname "CLTEST:foo.txt"))) (values (notnot (typep c 'file-error)) (eqlt (class-of c) (find-class 'file-error)) (equalpt "CLTEST:foo.txt" (file-error-pathname c)))) t t t) (deftest file-error-pathname.4 (let ((c (make-condition 'file-error :pathname (logical-pathname "CLTEST:foo.txt")))) (values (notnot (typep c 'file-error)) (eqlt (class-of c) (find-class 'file-error)) (equalpt (logical-pathname "CLTEST:foo.txt") (file-error-pathname c)))) t t t) (deftest file-error-pathname.5 (with-open-file (s "file-error.lsp" :direction :input) (let ((c (make-condition 'file-error :pathname s))) (values (notnot (typep c 'file-error)) (eqlt (class-of c) (find-class 'file-error)) (equalpt s (file-error-pathname c))))) t t t) (deftest file-error-pathname.6 (let ((s (open "file-error.lsp" :direction :input))) (close s) (let ((c (make-condition 'file-error :pathname s))) (values (notnot (typep c 'file-error)) (eqlt (class-of c) (find-class 'file-error)) (equalpt s (file-error-pathname c))))) t t t) (deftest file-error-pathname.error.1 (signals-error (file-error-pathname) program-error) t) (deftest file-error-pathname.error.2 (signals-error (file-error-pathname (make-condition 'file-error :pathname "foo.txt") nil) program-error) t) gcl27-2.7.0/ansi-tests/file-length.lsp000066400000000000000000000110601454061450500174500ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jan 21 06:21:11 2004 ;;;; Contains: Tests of FILE-LENGTH (in-package :cl-test) (deftest file-length.error.1 (signals-error (file-length) program-error) t) (deftest file-length.error.2 (signals-error (with-open-file (is "file-length.lsp" :direction :input) (file-length is nil)) program-error) t) (deftest file-length.error.3 (loop for x in *mini-universe* unless (or (typep x 'file-stream) (typep x 'broadcast-stream) (handler-case (progn (file-length x) nil) (type-error (c) (assert (not (typep x (type-error-expected-type c)))) t) (condition () nil))) collect x) nil) (deftest file-length.error.4 :notes (:assume-no-simple-streams :assume-no-gray-streams) (signals-error (with-input-from-string (s "abc") (file-length s)) type-error) t) (deftest file-length.error.5 (signals-error (with-open-file (is "file-length.lsp" :direction :input) (with-open-file (os "tmp.txt" :direction :output :if-exists :supersede) (let ((s (make-two-way-stream is os))) (unwind-protect (file-length s) (close s))))) type-error) t) (deftest file-length.error.6 (signals-error (with-open-file (is "file-length.lsp" :direction :input) (with-open-file (os "tmp.txt" :direction :output :if-exists :supersede) (let ((s (make-echo-stream is os))) (unwind-protect (file-length s) (close s))))) type-error) t) (deftest file-length.error.8 (with-open-file (os "tmp.txt" :direction :output :if-exists :supersede) (let ((s (make-broadcast-stream os))) (eqlt (file-length s) (file-length os)))) t) (deftest file-length.error.9 (signals-type-error s (make-concatenated-stream) (unwind-protect (file-length s) (close s))) t) (deftest file-length.error.10 (signals-error (with-open-file (is "file-length.lsp" :direction :input) (let ((s (make-concatenated-stream is))) (unwind-protect (file-length s) (close s)))) type-error) t) (deftest file-length.error.11 :notes (:assume-no-simple-streams :assume-no-gray-streams) (signals-type-error s (make-string-input-stream "abcde") (unwind-protect (file-length s) (close s))) t) (deftest file-length.error.12 :notes (:assume-no-simple-streams :assume-no-gray-streams) (signals-type-error s (make-string-output-stream) (unwind-protect (file-length s) (close s))) t) ;;; Non-error tests (deftest file-length.1 (let ((results (multiple-value-list (with-open-file (is "file-length.lsp" :direction :input) (file-length is))))) (and (= (length results) 1) (typep (car results) '(integer 1)) t)) t) (deftest file-length.2 (loop for i from 1 to 32 for etype = `(unsigned-byte ,i) for e = (max 0 (- (ash 1 i) 5)) for os = (open "tmp.dat" :direction :output :if-exists :supersede :element-type etype) do (loop repeat 17 do (write-byte e os)) do (finish-output os) unless (= (file-length os) 17) collect (list i (file-length os)) do (close os)) nil) (deftest file-length.3 (loop for i from 1 to 32 for etype = `(unsigned-byte ,i) for e = (max 0 (- (ash 1 i) 5)) for os = (open "tmp.dat" :direction :output :if-exists :supersede :element-type etype) for len = 0 do (loop repeat 17 do (write-byte e os)) do (close os) unless (let ((is (open "tmp.dat" :direction :input :element-type etype))) (prog1 (= (file-length is) 17) (close is))) collect i) nil) (deftest file-length.4 (loop for i from 33 to 100 for etype = `(unsigned-byte ,i) for e = (max 0 (- (ash 1 i) 5)) for os = (open "tmp.dat" :direction :output :if-exists :supersede :element-type etype) do (loop repeat 17 do (write-byte e os)) do (finish-output os) unless (= (file-length os) 17) collect (list i (file-length os)) do (close os)) nil) (deftest file-length.5 (loop for i from 33 to 100 for etype = `(unsigned-byte ,i) for e = (max 0 (- (ash 1 i) 5)) for os = (open "tmp.dat" :direction :output :if-exists :supersede :element-type etype) for len = 0 do (loop repeat 17 do (write-byte e os)) do (close os) unless (let ((is (open "tmp.dat" :direction :input :element-type etype))) (prog1 (= (file-length is) 17) (close is))) collect i) nil) (deftest file-length.6 (with-open-file (*foo* "file-length.lsp" :direction :input) (declare (special *foo*)) (let ((s (make-synonym-stream '*foo*))) (unwind-protect (typep* (file-length s) '(integer 1)) (close s)))) t) gcl27-2.7.0/ansi-tests/file-namestring.lsp000066400000000000000000000021021454061450500203330ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 11 07:40:47 2004 ;;;; Contains: Tests for FILE-NAMESTRING (in-package :cl-test) (deftest file-namestring.1 (let* ((vals (multiple-value-list (file-namestring "file-namestring.lsp"))) (s (first vals))) (if (and (null (cdr vals)) (stringp s) (equal (file-namestring s) s)) :good vals)) :good) (deftest file-namestring.2 (do-special-strings (s "file-namestring.lsp" nil) (let ((ns (file-namestring s))) (assert (stringp ns)) (assert (string= (file-namestring ns) ns)))) nil) (deftest file-namestring.3 (let* ((name "file-namestring.lsp") (pn (merge-pathnames (pathname name))) (name2 (with-open-file (s pn :direction :input) (file-namestring s))) (name3 (file-namestring pn))) (or (equalt name2 name3) (list name2 name3))) t) ;;; Error tests (deftest file-namestring.error.1 (signals-error (file-namestring) program-error) t) (deftest file-namestring.error.2 (signals-error (file-namestring "file-namestring.lsp" nil) program-error) t) gcl27-2.7.0/ansi-tests/file-position.lsp000066400000000000000000000101661454061450500200410ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jan 22 03:02:31 2004 ;;;; Contains: Tests of FILE-POSITION (in-package :cl-test) (deftest file-position.1 (with-open-file (is "file-position.lsp":direction :input) (file-position is)) 0) (deftest file-position.2 (with-open-file (is "file-position.lsp":direction :input) (values (multiple-value-list (notnot-mv (file-position is :start))) (file-position is))) (t) 0) (deftest file-position.3 (with-open-file (is "file-position.lsp":direction :input) (values (multiple-value-list (notnot-mv (file-position is :end))) (notnot (> (file-position is) 0)))) (t) t) (deftest file-position.4 (with-open-file (is "file-position.lsp":direction :input) (values (file-position is) (read-char is) (notnot (> (file-position is) 0)))) 0 #\; t) (deftest file-position.5 (with-open-file (os "tmp.dat":direction :output :if-exists :supersede) (values (file-position os) (write-char #\x os) (notnot (> (file-position os) 0)))) 0 #\x t) (deftest file-position.6 (with-open-file (os "tmp.dat":direction :output :if-exists :supersede) (let ((p1 (file-position os)) (delta (file-string-length os #\x))) (write-char #\x os) (let ((p2 (file-position os))) (or (null p1) (null p2) (null delta) (=t (+ p1 delta) p2))))) t) ;;; Byte streams (deftest file-position.7 (loop for len from 1 to 32 for n = (ash 1 len) do (with-open-file (os "tmp.dat" :direction :output :if-exists :supersede :element-type `(unsigned-byte ,len)) (loop for i from 0 below 100 for r = (logand (1- n) i) for pos = (file-position os) do (assert (or (not pos) (eql pos i))) do (write-byte r os))) do (with-open-file (is "tmp.dat" :direction :input :element-type `(unsigned-byte ,len)) (loop for i from 0 below 100 for pos = (file-position is) do (assert (or (not pos) (eql pos i))) do (let ((byte (read-byte is))) (assert (eql byte (logand (1- n) i))))))) nil) (deftest file-position.8 (loop for len from 33 to 100 for n = (ash 1 len) do (with-open-file (os "tmp.dat" :direction :output :if-exists :supersede :element-type `(unsigned-byte ,len)) (loop for i from 0 below 100 for r = (logand (1- n) i) for pos = (file-position os) do (assert (or (not pos) (eql pos i))) do (write-byte r os))) do (with-open-file (is "tmp.dat" :direction :input :element-type `(unsigned-byte ,len)) (loop for i from 0 below 100 for pos = (file-position is) do (assert (or (not pos) (eql pos i))) do (let ((byte (read-byte is))) (assert (eql byte (logand (1- n) i))))))) nil) (deftest file-position.9 (with-input-from-string (s "abcdefghijklmnopqrstuvwxyz") (loop repeat 26 for p = (file-position s) unless (or (not p) (progn (file-position s p) (eql (file-position s) p))) collect p do (read-char s))) nil) (deftest file-position.10 (with-output-to-string (s) (loop repeat 26 for p = (file-position s) unless (or (not p) (progn (file-position s p) (eql (file-position s) p))) collect p do (write-char #\x s))) "xxxxxxxxxxxxxxxxxxxxxxxxxx") ;;; Error tests (deftest file-position.error.1 (signals-error (file-position) program-error) t) (deftest file-position.error.2 (signals-error (file-position (make-string-input-stream "abc") :start nil) program-error) t) ;;; It's not clear what 'too large' means -- can we set the ;;; file position to a point where the file may later be extended ;;; by some other writer? #| (deftest file-position.error.3 (signals-error (with-open-file (is "file-position.lsp" :direction :input) (flet ((%fail () (error 'type-error))) (unless (file-position is :end) (%fail)) (let ((fp (file-position is))) (unless fp (%fail)) (file-position is (+ 1000000 fp))))) error) t) (deftest file-position.error.4 (signals-error (with-open-file (is "file-position.lsp" :direction :input) (file-position is 1000000000000000000000)) error) t) |# gcl27-2.7.0/ansi-tests/file-string-length.lsp000066400000000000000000000034311454061450500207570ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jan 22 21:34:04 2004 ;;;; Contains: Tests of FILE-STRING-LENGTH (in-package :cl-test) (deftest file-string-length.1 (with-open-file (s "tmp.dat" :direction :output :if-exists :supersede) (loop for x across +standard-chars+ for len = (file-string-length s x) do (assert (typep len '(or null (integer 0)))) do (let ((pos1 (file-position s))) (write-char x s) (let ((pos2 (file-position s))) (when (and pos1 pos2 len) (assert (= (+ pos1 len) pos2))))))) nil) (deftest file-string-length.2 (with-open-file (s "tmp.dat" :direction :output :if-exists :supersede) (loop for x across +standard-chars+ for len = (file-string-length s (string x)) do (assert (typep len '(or null (integer 0)))) do (let ((pos1 (file-position s))) (write-sequence (string x) s) (let ((pos2 (file-position s))) (when (and pos1 pos2 len) (assert (= (+ pos1 len) pos2))))))) nil) (deftest file-string-length.3 (with-open-file (stream "tmp.dat" :direction :output :if-exists :supersede) (let* ((s1 "abcde") (n (file-string-length stream s1))) (do-special-strings (s2 s1 nil) (assert (= (file-string-length stream s2) n))))) nil) ;;; Error tests (deftest file-string-length.error.1 (signals-error (file-string-length) program-error) t) (deftest file-string-length.error.2 (signals-error (with-open-file (s "tmp.dat" :direction :output :if-exists :supersede) (file-string-length s)) program-error) t) (deftest file-string-length.error.3 (signals-error (with-open-file (s "tmp.dat" :direction :output :if-exists :supersede) (file-string-length s #\x nil)) program-error) t) gcl27-2.7.0/ansi-tests/file-write-date.lsp000066400000000000000000000040061454061450500202360ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 6 06:01:35 2004 ;;;; Contains: Tests for FILE-WRITE-DATE (in-package :cl-test) (deftest file-write-date.1 (let* ((pn "file-write-date.lsp") (date (file-write-date pn)) (time (get-universal-time))) (or (null date) (and (integerp date) (<= 0 date time) t))) t) (deftest file-write-date.2 (let* ((pn #p"file-write-date.lsp") (date (file-write-date pn)) (time (get-universal-time))) (or (null date) (and (integerp date) (<= 0 date time) t))) t) (deftest file-write-date.3 (let* ((pn (truename "file-write-date.lsp")) (date (file-write-date pn)) (time (get-universal-time))) (or (null date) (and (integerp date) (<= 0 date time) t))) t) (deftest file-write-date.4 (loop for pn in (directory (make-pathname :name :wild :type :wild :defaults *default-pathname-defaults*)) for date = (file-write-date pn) for time = (get-universal-time) unless (or (null date) (<= 0 date time)) collect (list pn date time)) nil) (deftest file-write-date.5 (length (multiple-value-list (file-write-date "file-write-date.lsp"))) 1) ;;; Specialized string tests (deftest file-write-date.6 (let* ((str "file-write-date.lsp") (date (file-write-date str))) (do-special-strings (s str nil) (assert (equal (file-write-date s) date)))) nil) ;;; FIXME ;;; Add LPN test ;;; Error tests (deftest file-write-date.error.1 (signals-error (file-write-date) program-error) t) (deftest file-write-date.error.2 (signals-error (file-write-date "file-write-date.lsp" nil) program-error) t) (deftest file-write-date.error.3 (signals-error-always (file-write-date (make-pathname :name :wild :type "lsp" :defaults *default-pathname-defaults*)) file-error) t t) (deftest file-write-date.error.4 (signals-error-always (file-write-date (make-pathname :name "file-write-date" :type :wild :defaults *default-pathname-defaults*)) file-error) t t) gcl27-2.7.0/ansi-tests/fill-pointer.lsp000066400000000000000000000035341454061450500176650ustar00rootroot00000000000000;-*- 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 (signals-error (fill-pointer) program-error) t) (deftest fill-pointer.error.2 (signals-error (fill-pointer (make-array '(10) :fill-pointer 4) nil) program-error) t) (deftest fill-pointer.error.3 (let ((a (make-array '(10) :fill-pointer nil))) (if (array-has-fill-pointer-p a) t (eval `(signals-error (fill-pointer ',a) type-error)))) t) (deftest fill-pointer.error.4 (signals-error (fill-pointer #0aNIL) type-error) t) (deftest fill-pointer.error.5 (signals-error (fill-pointer #2a((a b c)(d e f))) type-error) t) (deftest fill-pointer.error.6 (check-type-error #'fill-pointer #'(lambda (x) (and (vectorp x) (array-has-fill-pointer-p x)))) nil) (deftest fill-pointer.error.7 (signals-error (locally (fill-pointer #2a((a b c)(d e f))) t) type-error) t) gcl27-2.7.0/ansi-tests/fill-strings.lsp000066400000000000000000000011701454061450500176700ustar00rootroot00000000000000;-*- 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") gcl27-2.7.0/ansi-tests/fill.lsp000066400000000000000000000340401454061450500162030ustar00rootroot00000000000000;-*- 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 (signals-error (fill 'a 'b) type-error) t) (deftest fill.error.2 (signals-error (fill) program-error) t) (deftest fill.error.3 (signals-error (fill (list 'a 'b)) program-error) t) (deftest fill.error.4 (signals-error (fill (list 'a 'b) 'c :bad t) program-error) t) (deftest fill.error.5 (signals-error (fill (list 'a 'b) 'c :bad t :allow-other-keys nil) program-error) t) (deftest fill.error.6 (signals-error (fill (list 'a 'b) 'c :start) program-error) t) (deftest fill.error.7 (signals-error (fill (list 'a 'b) 'c :end) program-error) t) (deftest fill.error.8 (signals-error (fill (list 'a 'b) 'c 1 2) program-error) t) (deftest fill.error.10 (signals-error (fill (list 'a 'b) 'c :bad t :allow-other-keys nil :allow-other-keys t) program-error) t) (deftest fill.error.11 (signals-error (locally (fill 'a 'b) t) type-error) t) ;;; 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 (signals-error (let* ((a (make-array '(5)))) (fill a 'x :start -1)) type-error) t) (deftest array-fill-8 (signals-error (let* ((a (make-array '(5)))) (fill a 'x :start 'a)) type-error) t) (deftest array-fill-9 (signals-error (let* ((a (make-array '(5)))) (fill a 'x :end -1)) type-error) t) (deftest array-fill-10 (signals-error (let* ((a (make-array '(5)))) (fill a 'x :end 'a)) type-error) t) ;;; 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 (signals-error (let* ((a (make-array '(5) :element-type 'fixnum))) (fill a 10 :start -1)) type-error) t) (deftest array-fixnum-fill-8 (signals-error (let* ((a (make-array '(5) :element-type 'fixnum))) (fill a 100 :start 'a)) type-error) t) (deftest array-fixnum-fill-9 (signals-error (let* ((a (make-array '(5) :element-type 'fixnum))) (fill a -5 :end -1)) type-error) t) (deftest array-fixnum-fill-10 (signals-error (let* ((a (make-array '(5) :element-type 'fixnum))) (fill a 17 :end 'a)) type-error) t) ;;; 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 (signals-error (array-unsigned-byte-fill-test-fn 8 0 :start -1) type-error) t) (deftest array-unsigned-byte8-fill-8 (signals-error (array-unsigned-byte-fill-test-fn 8 100 :start 'a) type-error) t) (deftest array-unsigned-byte8-fill-9 (signals-error (array-unsigned-byte-fill-test-fn 8 19 :end -1) type-error) t) (deftest array-unsigned-byte8-fill-10 (signals-error (array-unsigned-byte-fill-test-fn 8 17 :end 'a) type-error) t) ;;; 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) ;;; Specialized strings (deftest fill.specialized-strings.1 (do-special-strings (s (copy-seq "abcde") nil) (assert (string= s "abcde")) (assert (eq s (fill s #\x))) (assert (string= s "xxxxx"))) nil) (deftest fill.specialized-strings.2 (do-special-strings (s (copy-seq "abcde") nil) (assert (string= s "abcde")) (assert (eq s (fill s #\x :start 2))) (assert (string= s "abxxx"))) nil) (deftest fill.specialized-strings.3 (do-special-strings (s (copy-seq "abcde") nil) (assert (string= s "abcde")) (assert (eq s (fill s #\x :end 3))) (assert (string= s "xxxde"))) nil) (deftest fill.specialized-strings.4 (do-special-strings (s (copy-seq "abcde") nil) (assert (string= s "abcde")) (assert (eq s (fill s #\x :start 1 :end 4))) (assert (string= s "axxxe"))) nil) ;;; Specialized vector tests (deftest fill.specialized-vectors.1 (do-special-integer-vectors (v #(0 1 1 0 1) nil) (let ((etype (array-element-type v))) (assert (eq v (fill v 0))) (assert (equal (array-element-type v) etype))) (assert (equalp v #(0 0 0 0 0)))) nil) (deftest fill.specialized-vectors.2 (do-special-integer-vectors (v #(0 -1 1 0 -1) nil) (let ((etype (array-element-type v))) (assert (eq v (fill v 1))) (assert (equal (array-element-type v) etype))) (assert (equalp v #(1 1 1 1 1)))) nil) (deftest fill.specialized-vectors.3 (do-special-integer-vectors (v #(1 1 1 1 0) nil) (let ((etype (array-element-type v))) (assert (eq v (fill v 0 :start 1 :end 3))) (assert (equal (array-element-type v) etype))) (assert (equalp v #(1 0 0 1 0)))) nil)gcl27-2.7.0/ansi-tests/find-all-symbols.lsp000066400000000000000000000067571454061450500204470ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Feb 22 07:10:22 2004 ;;;; Contains: Tests for FIND-ALL-SYMBOLS (in-package :cl-test) (deftest find-all-symbols.1 (let ((all-packages (list-all-packages))) (loop for package in all-packages append (let ((failures nil)) (do-symbols (sym package failures) (when (eql (symbol-package sym) package) (let* ((name (symbol-name sym)) (similar (find-all-symbols name)) (similar2 (find-all-symbols sym))) (unless (and (member sym similar) (subsetp similar similar2) (subsetp similar2 similar) (loop for sym2 in similar always (string= name (symbol-name sym2)))) (push sym failures)))))))) nil) ;;; FIXME -- test that each symbol found is accessible in some package (deftest find-all-symbols.2 (loop for i from 0 to 255 for c = (code-char i) when (and (characterp c) (loop for sym in (find-all-symbols c) thereis (not (string= (symbol-name sym) (string c))))) collect c) nil) ;;; Unusual strings (deftest find-all-symbols.3 (let* ((name (make-array '(3) :initial-contents "NIL" :element-type 'base-char)) (symbols (find-all-symbols name))) (values (notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols)) (some #'not symbols))) t t) (deftest find-all-symbols.4 (let* ((name (make-array '(5) :initial-contents "NILXY" :fill-pointer 3 :element-type 'character)) (symbols (find-all-symbols name))) (values (notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols)) (some #'not symbols))) t t) (deftest find-all-symbols.5 (let* ((name (make-array '(5) :initial-contents "NILXY" :fill-pointer 3 :element-type 'base-char)) (symbols (find-all-symbols name))) (values (notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols)) (some #'not symbols))) t t) (deftest find-all-symbols.6 (let* ((name (make-array '(3) :initial-contents "NIL" :adjustable t :element-type 'base-char)) (symbols (find-all-symbols name))) (values (notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols)) (some #'not symbols))) t t) (deftest find-all-symbols.7 (let* ((name (make-array '(3) :initial-contents "NIL" :adjustable t :element-type 'character)) (symbols (find-all-symbols name))) (values (notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols)) (some #'not symbols))) t t) (deftest find-all-symbols.8 (let* ((type 'character) (name0 (make-array '(9) :initial-contents "XYZNILABC" :element-type type)) (name (make-array '(3) :element-type type :displaced-to name0 :displaced-index-offset 3)) (symbols (find-all-symbols name))) (values (notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols)) (some #'not symbols))) t t) (deftest find-all-symbols.9 (let* ((type 'base-char) (name0 (make-array '(9) :initial-contents "XYZNILABC" :element-type type)) (name (make-array '(3) :element-type type :displaced-to name0 :displaced-index-offset 3)) (symbols (find-all-symbols name))) (values (notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols)) (some #'not symbols))) t t) ;;; Error tests (deftest find-all-symbols.error.1 (signals-error (find-all-symbols) program-error) t) (deftest find-all-symbols.error.2 (signals-error (find-all-symbols "CAR" nil) program-error) t) gcl27-2.7.0/ansi-tests/find-class.lsp000066400000000000000000000167731454061450500173150ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu May 29 07:15:06 2003 ;;;; Contains: Tests of FIND-CLASS ;; find-class is also tested in numerous other places. (in-package :cl-test) (deftest find-class.1 (loop for name in *cl-types-that-are-classes-symbols* unless (eq (find-class name) (find-class name)) collect name) nil) (deftest find-class.2 (loop for name in *cl-types-that-are-classes-symbols* unless (eq (find-class name t) (find-class name)) collect name) nil) (deftest find-class.3 (loop for name in *cl-types-that-are-classes-symbols* unless (eq (find-class name nil) (find-class name)) collect name) nil) (deftest find-class.4 (handler-case (progn (eval '(find-class (gensym))) :bad) (error () :good)) :good) (deftest find-class.5 (handler-case (progn (eval '(find-class (gensym) t)) :bad) (error () :good)) :good) (deftest find-class.6 (find-class (gensym) nil) nil) (deftest find-class.7 (loop for name in *cl-types-that-are-classes-symbols* unless (eq (find-class name t nil) (find-class name)) collect name) nil) (deftest find-class.8 (loop for name in *cl-types-that-are-classes-symbols* unless (eq (find-class name nil nil) (find-class name)) collect name) nil) (deftest find-class.9 (macrolet ((%m (&environment env) (let ((result (loop for name in *cl-types-that-are-classes-symbols* unless (eq (find-class name nil env) (find-class name)) collect name))) `',result))) (%m)) nil) (deftest find-class.10 (macrolet ((%m (&environment env) (let ((result (loop for name in *cl-types-that-are-classes-symbols* unless (eq (find-class name t env) (find-class name)) collect name))) `',result))) (%m)) nil) (deftest find-class.11 (handler-case (progn (eval '(find-class (gensym) 'a nil)) :bad) (error () :good)) :good) (deftest find-class.12 (find-class (gensym) nil nil) nil) (deftest find-class.13 (macrolet ((%m (&environment env) `',(find-class (gensym) nil env))) (%m)) nil) (deftest find-class.14 (handler-case (progn (eval '(macrolet ((%m (&environment env) `',(find-class (gensym) 17 env))) (%m))) :bad) (error () :good)) :good) ;;; Need tests of assignment to (FIND-CLASS ...) ;;; Add tests of: ;;; Setting class to itself ;;; Changing class to a different class ;;; Changing to NIL (and that the class object stays around) ;;; Check that find-class is affected by the assignment, and ;;; class-name is not. (deftest find-class.15 (progn (setf (find-class 'find-class-class-01) nil) (let* ((class (eval '(defclass find-class-class-01 () ()))) (class1 (find-class 'find-class-class-01)) (class2 (setf (find-class 'find-class-class-01) class1))) (values (eqt class class1) (eqt class class2) (class-name class) ))) t t find-class-class-01) (deftest find-class.16 (progn (setf (find-class 'find-class-class-01 nil) nil) (setf (find-class 'find-class-class-01 t) nil) ;; should not throw error (let* ((i 0) (class (eval '(defclass find-class-class-01 () ()))) (class1 (find-class 'find-class-class-01)) (class2 (setf (find-class 'find-class-class-01 (incf i)) class1))) (values i (eqt class class1) (eqt class class2)))) 1 t t) (deftest find-class.17 (macrolet ((%m (&environment env) `',(progn (setf (find-class 'find-class-class-01) nil) (let* ((i 0) x y z (class (eval '(defclass find-class-class-01 () ()))) (class1 (find-class (progn (setf x (incf i)) 'find-class-class-01) (setf y (incf i)) (progn (setf z (incf i)) env))) (class2 (setf (find-class 'find-class-class-01) class1))) (list (eqt class class1) (eqt class class2) i x y z ))))) (%m)) (t t 3 1 2 3)) (deftest find-class.18 (progn (setf (find-class 'find-class-class-01) nil) (let* ((class (eval '(defclass find-class-class-01 () ()))) (class1 (find-class 'find-class-class-01)) (class2 (setf (find-class 'find-class-class-01) nil)) (class3 (find-class 'find-class-class-01 nil))) (values (eqt class class1) (eqt class class2) class2 (class-name class) class3))) t nil nil find-class-class-01 nil) (deftest find-class.19 (progn (setf (find-class 'find-class-class-01 nil) nil) (setf (find-class 'find-class-class-01 t) nil) ;; should not throw error (let* ((class (eval '(defclass find-class-class-01 () ()))) (class1 (find-class 'find-class-class-01)) (class2 (setf (find-class 'find-class-class-01 t nil) class1))) (values (eqt class class1) (eqt class class2)))) t t) ;; Change to a different class (deftest find-class.20 (progn (setf (find-class 'find-class-class-01) nil) (setf (find-class 'find-class-class-02) nil) (let* ((class1 (eval '(defclass find-class-class-01 () ()))) (class2 (eval '(defclass find-class-class-02 () ())))) (setf (find-class 'find-class-class-01) class2) (let* ((new-class1 (find-class 'find-class-class-01 nil)) (new-class2 (find-class 'find-class-class-02))) (values (eqt class1 class2) (eqt class2 new-class1) (eqt class2 new-class2) (class-name class2))))) nil t t find-class-class-02) (deftest find-class.21 (progn (setf (find-class 'find-class-class-01) nil) (setf (find-class 'find-class-class-02) nil) (let* ((class1 (eval '(defclass find-class-class-01 () ()))) (class2 (eval '(defclass find-class-class-02 () ())))) (psetf (find-class 'find-class-class-01) class2 (find-class 'find-class-class-02) class1) (let* ((new-class1 (find-class 'find-class-class-01 nil)) (new-class2 (find-class 'find-class-class-02))) (values (eqt class1 class2) (eqt class2 new-class1) (eqt class1 new-class2) (class-name new-class1) (class-name new-class2) )))) nil t t find-class-class-02 find-class-class-01) ;;; Effect on method dispatch (deftest find-class.22 (progn (setf (find-class 'find-class-class-01) nil) (let* ((class1 (eval '(defclass find-class-class-01 () ()))) (fn (eval '(defgeneric find-class-gf-01 (x) (:method ((x find-class-class-01)) :good) (:method ((x t)) nil)))) (obj (make-instance class1))) (assert (typep fn 'function)) (locally (declare (type function fn)) (values (funcall fn nil) (funcall fn obj) (setf (find-class 'find-class-class-01) nil) (funcall fn nil) (funcall fn obj))))) nil :good nil nil :good) (deftest find-class.23 (progn (setf (find-class 'find-class-class-01) nil) (setf (find-class 'find-class-class-02) nil) (let* ((class1 (eval '(defclass find-class-class-01 () ()))) (class2 (eval '(defclass find-class-class-02 (find-class-class-01) ()))) (fn (eval '(defgeneric find-class-gf-02 (x) (:method ((x find-class-class-01)) 1) (:method ((x find-class-class-02)) 2) (:method ((x t)) t)))) (obj1 (make-instance class1)) (obj2 (make-instance class2))) (assert (typep fn 'function)) (locally (declare (type function fn)) (values (funcall fn nil) (funcall fn obj1) (funcall fn obj2) (setf (find-class 'find-class-class-01) nil) (funcall fn nil) (funcall fn obj1) (funcall fn obj2))))) t 1 2 nil t 1 2) ;;; Error tests (deftest find-class.error.1 (signals-error (find-class) program-error) t) (deftest find-class.error.2 (signals-error (find-class 'symbol nil nil nil) program-error) t) gcl27-2.7.0/ansi-tests/find-if-not.lsp000066400000000000000000000347011454061450500173730ustar00rootroot00000000000000;-*- 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))) (deftest find-if-not-string.19 (do-special-strings (s "abc1def" nil) (assert (eql (find-if-not #'alpha-char-p s) #\1))) nil) ;;; 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 (check-type-error #'(lambda (x) (find-if-not #'null x)) #'(lambda (x) (typep x 'sequence))) nil) (deftest find-if-not.error.4 (signals-error (find-if-not 'identity '(a b c . d)) type-error) t) (deftest find-if-not.error.5 (signals-error (find-if-not) program-error) t) (deftest find-if-not.error.6 (signals-error (find-if-not #'null) program-error) t) (deftest find-if-not.error.7 (signals-error (find-if-not #'null nil :bad t) program-error) t) (deftest find-if-not.error.8 (signals-error (find-if-not #'null nil :bad t :allow-other-keys nil) program-error) t) (deftest find-if-not.error.9 (signals-error (find-if-not #'null nil 1 1) program-error) t) (deftest find-if-not.error.10 (signals-error (find-if-not #'null nil :key) program-error) t) (deftest find-if-not.error.11 (signals-error (locally (find-if-not #'null 'b) t) type-error) t) (deftest find-if-not.error.12 (signals-error (find-if-not #'cons '(a b c)) program-error) t) (deftest find-if-not.error.13 (signals-error (find-if-not #'car '(a b c)) type-error) t) (deftest find-if-not.error.14 (signals-error (find-if-not #'identity '(a b c) :key #'cons) program-error) t) (deftest find-if-not.error.15 (signals-error (find-if-not #'identity '(a b c) :key #'car) type-error) t) ;;; 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) (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) (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) gcl27-2.7.0/ansi-tests/find-if.lsp000066400000000000000000000347251454061450500166030ustar00rootroot00000000000000;-*- 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) (deftest find-if-string.20 (do-special-strings (s "123a456" nil) (assert (eql (find-if #'alpha-char-p s) #\a))) nil) ;;; 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 (check-type-error #'(lambda (x) (find-if #'null x)) #'(lambda (x) (typep x 'sequence))) nil) (deftest find-if.error.4 (signals-error (find-if 'null '(a b c . d)) type-error) t) (deftest find-if.error.5 (signals-error (find-if) program-error) t) (deftest find-if.error.6 (signals-error (find-if #'null) program-error) t) (deftest find-if.error.7 (signals-error (find-if #'null nil :bad t) program-error) t) (deftest find-if.error.8 (signals-error (find-if #'null nil :bad t :allow-other-keys nil) program-error) t) (deftest find-if.error.9 (signals-error (find-if #'null nil 1 1) program-error) t) (deftest find-if.error.10 (signals-error (find-if #'null nil :key) program-error) t) (deftest find-if.error.11 (signals-error (locally (find-if #'null 'b) t) type-error) t) (deftest find-if.error.12 (signals-error (find-if #'cons '(a b c)) program-error) t) (deftest find-if.error.13 (signals-error (find-if #'car '(a b c)) type-error) t) (deftest find-if.error.14 (signals-error (find-if #'identity '(a b c) :key #'cons) program-error) t) (deftest find-if.error.15 (signals-error (find-if #'identity '(a b c) :key #'car) type-error) t) ;;; 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) (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) (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) gcl27-2.7.0/ansi-tests/find-method.lsp000066400000000000000000000071511454061450500174560ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jun 3 21:12:03 2003 ;;;; Contains: Tests for FIND-METHOD (in-package :cl-test) (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defgeneric find-method-gf-01 (x))) (report-and-ignore-errors (defparameter *find-method-gf-01-method1* (defmethod find-method-gf-01 ((x integer)) 'a))) (report-and-ignore-errors (defparameter *find-method-gf-01-method2* (defmethod find-method-gf-01 ((x rational)) 'b))) (report-and-ignore-errors (defparameter *find-method-gf-01-method3* (defmethod find-method-gf-01 ((x real)) 'c))) (report-and-ignore-errors (defparameter *find-method-gf-01-method4* (defmethod find-method-gf-01 ((x t)) 'd))) ) (deftest find-method.1 (eqt (find-method #'find-method-gf-01 nil (list (find-class 'integer))) *find-method-gf-01-method1*) t) (deftest find-method.2 (eqt (find-method #'find-method-gf-01 nil (list (find-class 'rational))) *find-method-gf-01-method2*) t) (deftest find-method.3 (eqt (find-method #'find-method-gf-01 nil (list (find-class 'real))) *find-method-gf-01-method3*) t) (deftest find-method.4 (eqt (find-method #'find-method-gf-01 nil (list (find-class t))) *find-method-gf-01-method4*) t) (deftest find-method.5 (find-method #'find-method-gf-01 (list :around) (list (find-class t)) nil) nil) (deftest find-method.6 (find-method #'find-method-gf-01 (list :after) (list (find-class 'integer)) nil) nil) (deftest find-method.7 (find-method #'find-method-gf-01 (list :before) (list (find-class 'real)) nil) nil) ;;; EQL specializers (defgeneric find-method-gf-02 (x)) (defparameter *find-method-gf-02-method1* (defmethod find-method-gf-02 ((x (eql 1234567890))) 'a)) (defparameter *find-method-02-method2-value* (list 'a)) (defparameter *find-method-gf-02-method2* (defmethod find-method-gf-02 ((x (eql *find-method-02-method2-value*))) 'b)) (deftest find-method.8 (eqt (find-method #'find-method-gf-02 nil (list '(eql 1234567890))) *find-method-gf-02-method1*) t) (deftest find-method.9 (eqt (find-method #'find-method-gf-02 nil (list (list 'eql *find-method-02-method2-value*))) *find-method-gf-02-method2*) t) ;;; Error tests (deftest find-method.error.1 (signals-error (find-method) program-error) t) (deftest find-method.error.2 (signals-error (find-method #'find-method-gf-01) program-error) t) (deftest find-method.error.3 (signals-error (find-method #'find-method-gf-01 nil) program-error) t) (deftest find-method.error.4 (signals-error (find-method #'find-method-gf-01 nil (list (find-class 'integer)) nil nil) program-error) t) (deftest find-method.error.5 (handler-case (find-method #'find-method-gf-01 nil (list (find-class 'symbol))) (error () :error)) :error) (deftest find-method.error.6 (handler-case (find-method #'find-method-gf-01 nil (list (find-class 'symbol)) 'x) (error () :error)) :error) (deftest find-method.error.7 (handler-case (find-method #'find-method-gf-01 nil nil) (error () :error)) :error) (deftest find-method.error.8 (handler-case (find-method #'find-method-gf-01 nil (list (find-class 'integer) (find-class t))) (error () :error)) :error) (deftest find-method.error.9 (handler-case (find-method #'find-method-gf-01 nil nil nil) (error () :error)) :error) (deftest find-method.error.10 (handler-case (find-method #'find-method-gf-01 nil (list (find-class 'integer) (find-class t)) nil) (error () :error)) :error) gcl27-2.7.0/ansi-tests/find-package.lsp000066400000000000000000000066241454061450500175750ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 07:50:39 1998 ;;;; Contains: Tests for FIND-PACKAGE (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 (progn (set-up-packages) (let ((p (ignore-errors (find-package "A")))) (if (packagep p) t p))) t) (deftest find-package.5 (progn (set-up-packages) (let ((p (ignore-errors (find-package #\A)))) (if (packagep p) t p))) t) (deftest find-package.6 (progn (set-up-packages) (let ((p (ignore-errors (find-package "B")))) (if (packagep p) t p))) t) (deftest find-package.7 (progn (set-up-packages) (let ((p (ignore-errors (find-package #\B)))) (if (packagep p) t p))) t) (deftest find-package.8 (progn (set-up-packages) (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 (progn (set-up-packages) (let ((p (ignore-errors (find-package "A"))) (p2 (ignore-errors (find-package "B")))) (eqt p p2))) nil) (deftest find-package.10 (progn (set-up-packages) (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.12 (let* ((name (make-array '(7) :initial-contents "KEYWORD" :element-type 'base-char)) (p (find-package name))) (and p (eqt p (symbol-package :test)))) t) (deftest find-package.13 (let* ((name (make-array '(10) :initial-contents "KEYWORDXYZ" :fill-pointer 7 :element-type 'base-char)) (p (find-package name))) (and p (eqt p (symbol-package :test)))) t) (deftest find-package.14 (let* ((name (make-array '(10) :initial-contents "KEYWORDXYZ" :fill-pointer 7 :element-type 'character)) (p (find-package name))) (and p (eqt p (symbol-package :test)))) t) (deftest find-package.15 (let* ((name0 (make-array '(10) :initial-contents "XYKEYWORDZ" :element-type 'character)) (name (make-array '(7) :displaced-to name0 :displaced-index-offset 2 :element-type 'character)) (p (find-package name))) (and p (eqt p (symbol-package :test)))) t) (deftest find-package.16 (let* ((name (make-array '(7) :initial-contents "KEYWORD" :adjustable t :element-type 'base-char)) (p (find-package name))) (and p (eqt p (symbol-package :test)))) t) (deftest find-package.17 (let* ((name (make-array '(7) :initial-contents "KEYWORD" :adjustable t :element-type 'character)) (p (find-package name))) (and p (eqt p (symbol-package :test)))) t) ;;; Error tests (deftest find-package.error.1 (signals-error (find-package) program-error) t) (deftest find-package.error.2 (signals-error (find-package "CL" nil) program-error) t) gcl27-2.7.0/ansi-tests/find-symbol.lsp000066400000000000000000000077341454061450500175120ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 07:49:34 1998 ;;;; Contains: Tests for FIND-SYMBOL (in-package :cl-test) (compile-and-load "packages-00.lsp") ;;(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 (progn (set-up-packages) (let ((vals (multiple-value-list (find-symbol "FOO" #\A)))) (values (length vals) (package-name (symbol-package (first vals))) (symbol-name (first vals)) (second vals)))) 2 "A" "FOO" :external) (deftest find-symbol.13 (progn (set-up-packages) (intern "X" (find-package "A")) (let ((vals (multiple-value-list (find-symbol "X" #\A)))) (values (length vals) (package-name (symbol-package (first vals))) (symbol-name (first vals)) (second vals)))) 2 "A" "X" :internal) (deftest find-symbol.14 (progn (set-up-packages) (let ((vals (multiple-value-list (find-symbol "FOO" #\B)))) (values (length vals) (package-name (symbol-package (first vals))) (symbol-name (first vals)) (second vals)))) 2 "A" "FOO" :inherited) (deftest find-symbol.15 (find-symbol "FOO" "FS-B") FS-A::FOO :inherited) (deftest find-symbol.16 (find-symbol "FOO" (find-package "FS-B")) FS-A::FOO :inherited) (deftest find-symbol.17 (let ((name (make-array '(3) :initial-contents "FOO" :element-type 'base-char))) (find-symbol name "FS-B")) FS-A::FOO :inherited) (deftest find-symbol.18 (let ((name (make-array '(4) :initial-contents "FOOD" :element-type 'character :fill-pointer 3))) (find-symbol name "FS-B")) FS-A::FOO :inherited) (deftest find-symbol.19 (let ((name (make-array '(4) :initial-contents "FOOD" :element-type 'base-char :fill-pointer 3))) (find-symbol name "FS-B")) FS-A::FOO :inherited) (deftest find-symbol.20 (let* ((name0 (make-array '(5) :initial-contents "XFOOY" :element-type 'character)) (name (make-array '(3) :element-type 'character :displaced-to name0 :displaced-index-offset 1))) (find-symbol name "FS-B")) FS-A::FOO :inherited) (deftest find-symbol.21 (let* ((name0 (make-array '(5) :initial-contents "XFOOY" :element-type 'base-char)) (name (make-array '(3) :element-type 'base-char :displaced-to name0 :displaced-index-offset 1))) (find-symbol name "FS-B")) FS-A::FOO :inherited) (deftest find-symbol.22 (find-symbol "FOO" (make-array '(4) :initial-contents "FS-B" :element-type 'base-char)) FS-A::FOO :inherited) (deftest find-symbol.23 (find-symbol "FOO" (make-array '(5) :initial-contents "FS-BX" :fill-pointer 4 :element-type 'base-char)) FS-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 (signals-error (find-symbol) program-error) t) (deftest find-symbol.error.2 (signals-error (find-symbol "CAR" "CL" nil) program-error) t) gcl27-2.7.0/ansi-tests/find.lsp000066400000000000000000000503251454061450500162010ustar00rootroot00000000000000;-*- 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)) (deftest find-list.29 (find 10 '(1 2 3 8 20 3 1 21 3) :test #'<) 20) (deftest find-list.30 (find 10 '(1 2 3 8 20 3 1 21 3) :test-not #'>=) 20) ;;; 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))) (deftest find-vector.31 (find 10 #(1 2 3 8 20 3 1 21 3) :test #'<) 20) (deftest find-vector.32 (find 10 #(1 2 3 8 20 3 1 21 3) :test-not #'>=) 20) (deftest find-vector.33 (do-special-integer-vectors (v #(1 2 3 4 5 6 7) nil) (assert (null (find 0 v))) (assert (= (find 4 v) 4)) (assert (= (find -1 v :test #'<) 1)) (assert (= (find -1 v :test #'< :from-end t) 7))) nil) (deftest find-vector.34 (do-special-integer-vectors (v #(0 0 0 0) nil) (assert (eql (find 0 v) 0)) (assert (eql (find 0 v :start 1) 0)) (assert (eql (find 0 v :from-end t) 0)) (assert (null (find 1 v))) (assert (null (find 'a v))) (assert (null (find 0.0 v))) (assert (null (find #c(1.0 0.0) v))) (assert (null (find -1 v))) (assert (null (find 2 v)))) nil) ;;; 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) (deftest find-bit-vector.31 (find 2 #*00011010010 :test #'<) nil) (deftest find-bit-vector.32 (find 2 #*0010101101 :test-not #'>=) nil) (deftest find-bit-vector.33 (find 0 #*00011010010 :test #'<) 1) (deftest find-bit-vector.34 (find 0 #*0010101101 :test-not #'>=) 1) ;;; 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)) (deftest find-string.26 (find #\k "abcdmnop" :test #'char<) #\m) (deftest find-string.27 (find #\k "abcdmnop" :test-not #'char>=) #\m) (deftest find-string.28 (do-special-strings (s "abcdef" nil) (assert (char= (find #\c s :test #'char<) #\d))) nil) ;;; Test & test not (defharmless find-list.test-and-test-not.1 (find 'b '(a b c) :test #'eql :test-not #'eql)) (defharmless find-list.test-and-test-not.2 (find 'b '(a b c) :test-not #'eql :test #'eql)) (defharmless find-vector.test-and-test-not.1 (find 'b #(a b c) :test #'eql :test-not #'eql)) (defharmless find-vector.test-and-test-not.2 (find 'b #(a b c) :test-not #'eql :test #'eql)) (defharmless find-string.test-and-test-not.1 (find #\b "abc" :test #'eql :test-not #'eql)) (defharmless find-string.test-and-test-not.2 (find #\b "abc" :test-not #'eql :test #'eql)) (defharmless find-bit-string.test-and-test-not.1 (find 0 #*110110 :test #'eql :test-not #'eql)) (defharmless find-bit-string.test-and-test-not.2 (find 0 #*110110 :test-not #'eql :test #'eql)) ;;; 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 (check-type-error #'(lambda (x) (find 'a x)) #'(lambda (x) (typep x 'sequence))) nil) (deftest find.error.4 (signals-error (find 'e '(a b c . d)) type-error) t) (deftest find.error.5 (signals-error (find) program-error) t) (deftest find.error.6 (signals-error (find 'a) program-error) t) (deftest find.error.7 (signals-error (find 'a nil :bad t) program-error) t) (deftest find.error.8 (signals-error (find 'a nil :bad t :allow-other-keys nil) program-error) t) (deftest find.error.9 (signals-error (find 'a nil 1 1) program-error) t) (deftest find.error.10 (signals-error (find 'a nil :key) program-error) t) (deftest find.error.11 (signals-error (locally (find 'a 'b) t) type-error) t) (deftest find.error.12 (signals-error (find 'b '(a b c) :test #'identity) program-error) t) (deftest find.error.13 (signals-error (find 'b '(a b c) :test-not #'identity) program-error) t) (deftest find.error.14 (signals-error (find 'c '(a b c) :key #'cons) program-error) t) (deftest find.error.15 (signals-error (find 'c '(a b c) :key #'car) type-error) t) ;;; 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) (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) (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) gcl27-2.7.0/ansi-tests/finish-output.lsp000066400000000000000000000022641454061450500200760ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jan 28 06:38:20 2004 ;;;; Contains: Tests of FINISH-OUTPUT (in-package :cl-test) (deftest finish-output.1 (finish-output) nil) (deftest finish-output.2 (finish-output t) nil) (deftest finish-output.3 (finish-output nil) nil) (deftest finish-output.4 (loop for s in (list *debug-io* *error-output* *query-io* *standard-output* *trace-output* *terminal-io*) for results = (multiple-value-list (finish-output s)) unless (equal results '(nil)) collect s) nil) (deftest finish-output.5 (let ((os (make-string-output-stream))) (let ((*terminal-io* (make-two-way-stream (make-string-input-stream "") os))) (finish-output t))) nil) (deftest finish-output.6 (let ((*standard-output* (make-string-output-stream))) (finish-output nil)) nil) ;;; Error tests (deftest finish-output.error.1 (signals-error (finish-output nil nil) program-error) t) (deftest finish-output.error.2 (signals-error (finish-output t nil) program-error) t) (deftest finish-output.error.3 (check-type-error #'finish-output #'(lambda (x) (typep x '(or stream (member nil t))))) nil) gcl27-2.7.0/ansi-tests/flet.lsp000066400000000000000000000324031454061450500162100ustar00rootroot00000000000000;-*- 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 :good))) nil)) (%f) :bad)) :good) ;;; Key arguments are not in the block defined by ;;; the local function declaration (deftest flet.4a (block %f (flet ((%f (&key (x (return-from %f :good))) nil)) (%f) :bad)) :good) (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 (signals-error (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :c 4)) program-error) t) ;;; Odd # of keyword args should throw a program-error in safe code ;;; (section 3.5.1.6) (deftest flet.13 (signals-error (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :a)) program-error) t) ;;; Too few arguments (section 3.5.1.2) (deftest flet.14 (signals-error (flet ((%f (a) a)) (%f)) program-error) t) ;;; Too many arguments (section 3.5.1.3) (deftest flet.15 (signals-error (flet ((%f (a) a)) (%f 1 2)) program-error) t) ;;; Invalid keyword argument (section 3.5.1.5) (deftest flet.16 (signals-error (flet ((%f (&key a) a)) (%f '(foo))) program-error) t) ;;; 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 (1- lambda-parameters-limit) 1024)) (vars (loop repeat n collect (gensym)))) (eval `(eqlt ,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) (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 = `(ignore-errors (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 = `(ignore-errors (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 = `(ignore-errors (flet (((setf ,s) (&rest args) (declare (ignore args)) 'a)) (setf (,s) 10))) unless (eq (eval form) 'a) collect s) nil) ;;; Check that FLET does not have a tagbody (deftest flet.52 (block done (tagbody (flet ((%f () (go 10) 10 (return-from done 'bad))) (%f)) 10 (return-from done 'good))) good) ;;; Check that nil keyword arguments do not enable the default values (deftest flet.53 (flet ((%f (&key (a 'wrong)) a)) (%f :a nil)) nil) (deftest flet.54 (flet ((%f (&key (a 'wrong a-p)) (list a (not a-p)))) (%f :a nil)) (nil nil)) (deftest flet.55 (flet ((%f (&key ((:a b) 'wrong)) b)) (%f :a nil)) nil) (deftest flet.56 (flet ((%f (&key ((:a b) 'wrong present?)) (list b (not present?)))) (%f :a nil)) (nil nil)) (deftest flet.57 (flet ((%f (&key) 'good)) (%f :allow-other-keys nil)) good) (deftest flet.58 (flet ((%f (&key) 'good)) (%f :allow-other-keys t)) good) (deftest flet.59 (flet ((%f (&key) 'good)) (%f :allow-other-keys t :a 1 :b 2)) good) (deftest flet.60 (flet ((%f (&key &allow-other-keys) 'good)) (%f :a 1 :b 2)) good) ;;; NIL as a disallowed keyword argument (deftest flet.61 (signals-error (flet ((%f (&key) :bad)) (%f nil nil)) program-error) t) ;;; Free declarations do not affect argument forms (deftest flet.62 (let ((x :bad)) (declare (special x)) (let ((x :good)) (flet ((%f (&optional (y x)) (declare (special x)) y)) (%f)))) :good) (deftest flet.63 (let ((x :bad)) (declare (special x)) (let ((x :good)) (flet ((%f (&key (y x)) (declare (special x)) y)) (%f)))) :good) (deftest flet.64 (let ((x :bad)) (declare (special x)) (let ((x :good)) (flet () (declare (special x))) x)) :good) (deftest flet.65 (let ((x :bad)) (declare (special x)) (let ((x :good)) (flet ((%f () (declare (special x))))) x)) :good) (deftest flet.66 (let ((x :bad)) (declare (special x)) (let ((x :good)) (flet ((%f () (declare (special x)))) x))) :good) (deftest flet.67 (let ((x :bad)) (declare (special x)) (let ((x :good)) (flet ((%f (&aux (y x)) (declare (special x)) y)) (%f)))) :good) (deftest flet.68 (let ((x :bad)) (declare (special x)) (let ((x :good)) (flet ((%f () x)) (declare (special x)) (%f)))) :good) (deftest flet.69 (let ((*x* 0)) (declare (special *x*)) (flet ((%f (i) #'(lambda (arg) (declare (ignore arg)) (incf *x* i)))) (values (mapcar (%f 1) '(a b c)) (mapcar (%f 2) '(a b c))))) (1 2 3) (5 7 9)) ;;; Macros are expanded in the appropriate environment (deftest flet.70 (macrolet ((%m (z) z)) (flet () (expand-in-current-env (%m :good)))) :good) (deftest flet.71 (macrolet ((%m (z) z)) (flet ((%f () (expand-in-current-env (%m :good)))) (%f))) :good) gcl27-2.7.0/ansi-tests/float.lsp000066400000000000000000000036611454061450500163670ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Sep 11 21:53:51 2003 ;;;; Contains: Tests of FLOAT (in-package :cl-test) (deftest float.error.1 (signals-error (float) program-error) t) (deftest float.error.2 (signals-error (float 0 0.0 nil) program-error) t) ;;; (deftest float.1 (notnot (member (float 0) '(0.0f0 -0.0f0))) t) (deftest float.2 (float 1) 1.0f0) (deftest float.3 (float -1) -1.0f0) (deftest float.4 (loop for i from -1000 to 1000 always (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) for tp in '(short-float single-float double-float long-float) for y = (float i x) always (and (= i y) (typep y tp)))) t) (deftest float.5 (loop for x in *reals* always (or (not (floatp x)) (eql (float x) x))) t) (deftest float.6 (loop for x in *reals* unless (handler-case (or (not (typep x 'short-float)) (let ((y (float x 0.0f0))) (and (typep y 'single-float) (= x y)))) (arithmetic-error () t)) collect x) nil) (deftest float.7 (loop for x in *reals* unless (or (not (typep x 'short-float)) (let ((y (float x 0.0d0))) (and (typep y 'double-float) (= x y)))) collect x) nil) (deftest float.8 (loop for x in *reals* unless (or (not (typep x 'short-float)) (let ((y (float x 0.0l0))) (and (typep y 'long-float) (= x y)))) collect x) nil) (deftest float.9 (loop for x in *reals* unless (or (not (typep x 'single-float)) (let ((y (float x 0.0d0))) (and (typep y 'double-float) (= x y)))) collect x) nil) (deftest float.10 (loop for x in *reals* unless (or (not (typep x 'single-float)) (let ((y (float x 0.0l0))) (and (typep y 'long-float) (= x y)))) collect x) nil) (deftest float.11 (loop for x in *reals* unless (or (not (typep x 'double-float)) (let ((y (float x 0.0l0))) (and (typep y 'long-float) (= x y)))) collect x) nil) gcl27-2.7.0/ansi-tests/floatp.lsp000066400000000000000000000007541454061450500165470ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Sep 11 23:07:33 2003 ;;;; Contains: Tests of FLOATP (in-package :cl-test) ;;; Error tests (deftest floatp.error.1 (signals-error (floatp) program-error) t) (deftest floatp.error.2 (signals-error (floatp 1.0 nil) program-error) t) ;;; Non-error tests (deftest floatp.1 (notnot-mv (floatp 1.0)) t) (deftest floatp.2 (floatp nil) nil) (deftest floatp.3 (check-type-predicate #'floatp 'float) nil) gcl27-2.7.0/ansi-tests/floor-aux.lsp000066400000000000000000000050211454061450500171660ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 9 08:08:00 2003 ;;;; Contains: Aux. functions used in FLOOR tests (in-package :cl-test) (defun floor.1-fn () (loop for n = (- (random 2000000000) 1000000000) for d = (1+ (random 10000)) for vals = (multiple-value-list (floor n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (= n n2) (integerp r) (< -1 r d)) collect (list n d q r n2))) (defun floor.2-fn () (loop for num = (random 1000000000) for denom = (1+ (random 1000)) for n = (/ num denom) for d = (1+ (random 10000)) for vals = (multiple-value-list (floor n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (<= 0 r) (< r d) (= n n2)) collect (list n d q r n2))) (defun floor.3-fn (width) (loop for n = (- (random width) (/ width 2)) for vals = (multiple-value-list (floor n)) for (q r) = vals for n2 = (+ q r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (= n n2) (<= 0 r) (< r 1) ) collect (list n q r n2))) (defun floor.7-fn () (loop for numerator = (- (random 10000000000) 5000000000) for denominator = (1+ (random 100000)) for n = (/ numerator denominator) for vals = (multiple-value-list (floor n)) for (q r) = vals for n2 = (+ q r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (rationalp r) (= n n2) (<= 0 r) (< r 1) ) collect (list n q r n2))) (defun floor.8-fn () (loop for num1 = (- (random 10000000000) 5000000000) for den1 = (1+ (random 100000)) for n = (/ num1 den1) for num2 = (- (1+ (random 1000000))) for den2 = (1+ (random 1000000)) for d = (/ num2 den2) for vals = (multiple-value-list (floor n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (rationalp r) (>= 0 r) (> r d) (= n n2)) collect (list n q d r n2))) (defun floor.9-fn () (loop for num1 = (- (random 1000000000000000) 500000000000000) for den1 = (1+ (random 10000000000)) for n = (/ num1 den1) for num2 = (- (1+ (random 1000000000))) for den2 = (1+ (random 10000000)) for d = (/ num2 den2) for vals = (multiple-value-list (floor n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (rationalp r) (>= 0 r) (> r d) (= n n2)) collect (list n q d r n2))) ;;; Need float tests gcl27-2.7.0/ansi-tests/floor.lsp000066400000000000000000000071761454061450500164100ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Aug 4 22:16:00 2003 ;;;; Contains: Tests of FLOOR (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "floor-aux.lsp") ;;; Error tests (deftest floor.error.1 (signals-error (floor) program-error) t) (deftest floor.error.2 (signals-error (floor 1.0 1 nil) program-error) t) ;;; Non-error tests (deftest floor.1 (floor.1-fn) nil) (deftest floor.2 (floor.2-fn) nil) (deftest floor.3 (floor.3-fn 2.0s4) nil) (deftest floor.4 (floor.3-fn 2.0f4) nil) (deftest floor.5 (floor.3-fn 2.0d4) nil) (deftest floor.6 (floor.3-fn 2.0l4) nil) (deftest floor.7 (floor.7-fn) nil) (deftest floor.8 (floor.8-fn) nil) (deftest floor.9 (floor.9-fn) nil) (deftest floor.10 (loop for x in (remove-if #'zerop *reals*) for (q r) = (multiple-value-list (floor x x)) unless (and (eql q 1) (zerop r) (if (rationalp x) (eql r 0) (eql r (float 0 x)))) collect x) nil) (deftest floor.11 (loop for x in (remove-if #'zerop *reals*) for (q r) = (multiple-value-list (floor (- x) x)) unless (and (eql q -1) (zerop r) (if (rationalp x) (eql r 0) (eql r (float 0 x)))) collect x) nil) (deftest floor.12 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (floor x)) unless (and (eql q i) (eql r rrad)) collect (list i x q r))) nil) (deftest floor.13 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (floor x)) unless (and (eql q (1- i)) (eql r rrad)) collect (list i x q r))) nil) (deftest floor.14 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (floor x)) unless (and (eql q i) (eql r rrad)) collect (list i x q r))) nil) (deftest floor.15 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (floor x)) unless (and (eql q (1- i)) (eql r rrad)) collect (list i x q r))) nil) (deftest floor.16 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (floor x)) unless (and (eql q i) (eql r rrad)) collect (list i x q r))) nil) (deftest floor.17 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (floor x)) unless (and (eql q (1- i)) (eql r rrad)) collect (list i x q r))) nil) (deftest floor.18 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (floor x)) unless (and (eql q i) (eql r rrad)) collect (list i x q r))) nil) (deftest floor.19 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (floor x)) unless (and (eql q (1- i)) (eql r rrad)) collect (list i x q r))) nil) ;;; To add: tests that involve adding/subtracting EPSILON constants ;;; (suitably scaled) to floated integers. gcl27-2.7.0/ansi-tests/fmakunbound.lsp000066400000000000000000000035451454061450500175740ustar00rootroot00000000000000;-*- 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 (equalt (check-values (fmakunbound n)) n) (fboundp n)))) t nil) (deftest fmakunbound.error.1 (check-type-error #'fmakunbound #'(lambda (x) (typep x '(or symbol (cons (eql setf) (cons symbol null)))))) nil) (deftest fmakunbound.error.2 (check-type-error #'fmakunbound (constantly nil) '((setf) (setf . foo) (setf foo . bar) (setf foo bar))) nil) (deftest fmakunbound.error.3 (signals-type-error x '(x) (fmakunbound x)) t) (deftest fmakunbound.error.4 (signals-error (fmakunbound) program-error) t) (deftest fmakunbound.error.5 (signals-error (fmakunbound (gensym) nil) program-error) t) (deftest fmakunbound.error.6 (signals-error (locally (fmakunbound 1) t) type-error) t) (deftest fmakunbound.error.7 (loop for x in *mini-universe* unless (symbolp x) nconc (handler-case (list x (fmakunbound `(setf ,x))) (type-error (c) (assert (not (typep (type-error-datum c) (type-error-expected-type c)))) nil) (error (c) (list (list x c))))) nil)gcl27-2.7.0/ansi-tests/force-output.lsp000066400000000000000000000022431454061450500177110ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jan 28 06:41:46 2004 ;;;; Contains: Tests of FORCE-OUTPUT (in-package :cl-test) (deftest force-output.1 (force-output) nil) (deftest force-output.2 (force-output t) nil) (deftest force-output.3 (force-output nil) nil) (deftest force-output.4 (loop for s in (list *debug-io* *error-output* *query-io* *standard-output* *trace-output* *terminal-io*) for results = (multiple-value-list (force-output s)) unless (equal results '(nil)) collect s) nil) (deftest force-output.5 (let ((os (make-string-output-stream))) (let ((*terminal-io* (make-two-way-stream (make-string-input-stream "") os))) (force-output t))) nil) (deftest force-output.6 (let ((*standard-output* (make-string-output-stream))) (force-output nil)) nil) ;;; Error tests (deftest force-output.error.1 (signals-error (force-output nil nil) program-error) t) (deftest force-output.error.2 (signals-error (force-output t nil) program-error) t) (deftest force-output.error.3 (check-type-error #'force-output #'(lambda (x) (typep x '(or stream (member nil t))))) nil) gcl27-2.7.0/ansi-tests/format-a.lsp000066400000000000000000000172161454061450500167710ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Aug 2 01:42:35 2004 ;;;; Contains: Tests of printing using the ~A directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-format-test format.a.1 "~a" (nil) "NIL") (deftest format.a.2 (with-standard-io-syntax (let ((*print-case* :downcase)) (format nil "~A" nil))) "nil") (deftest formatter.a.2 (with-standard-io-syntax (let ((*print-case* :downcase)) (formatter-call-to-string (formatter "~A") nil))) "nil") (deftest format.a.3 (with-standard-io-syntax (let ((*print-case* :capitalize)) (format nil "~a" nil))) "Nil") (deftest formatter.a.3 (with-standard-io-syntax (let ((*print-case* :capitalize)) (formatter-call-to-string (formatter "~a") nil))) "Nil") (def-format-test format.a.4 "~:a" (nil) "()") (def-format-test format.a.5 "~:A" ('(nil)) "(NIL)") (def-format-test format.a.6 "~:A" (#(nil)) "#(NIL)") (deftest format.a.7 (let ((fn (formatter "~a"))) (loop for c across +standard-chars+ for s1 = (string c) for s2 = (format nil "~a" s1) for s3 = (formatter-call-to-string fn s1) unless (and (string= s1 s2) (string= s2 s3)) collect (list c s1 s2 s3))) nil) (deftest format.a.8 (let ((fn (formatter "~A"))) (loop with count = 0 for i from 0 below (min #x10000 char-code-limit) for c = (code-char i) for s1 = (and c (string c)) for s2 = (and c (format nil "~A" s1)) for s3 = (and c (formatter-call-to-string fn s1)) unless (or (null c) (string= s1 s2) (string= s2 s3)) do (incf count) and collect (list c s1 s2 s3) when (> count 100) collect "count limit exceeded" and do (loop-finish))) nil) (deftest format.a.9 (with-standard-io-syntax (apply #'values (loop for i from 1 to 10 for fmt = (format nil "~~~d@a" i) for s = (format nil fmt nil) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn nil) do (assert (string= s s2)) collect s))) "NIL" "NIL" "NIL" " NIL" " NIL" " NIL" " NIL" " NIL" " NIL" " NIL") (deftest format.a.10 (with-standard-io-syntax (apply #'values (loop for i from 1 to 10 for fmt = (format nil "~~~da" i) for s = (format nil fmt nil) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn nil) do (assert (string= s s2)) collect s))) "NIL" "NIL" "NIL" "NIL " "NIL " "NIL " "NIL " "NIL " "NIL " "NIL ") (deftest format.a.11 (with-standard-io-syntax (apply #'values (loop for i from 1 to 10 for fmt = (format nil "~~~d@:A" i) for s = (format nil fmt nil) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn nil) do (assert (string= s s2)) collect s))) "()" "()" " ()" " ()" " ()" " ()" " ()" " ()" " ()" " ()") (deftest format.a.12 (with-standard-io-syntax (apply #'values (loop for i from 1 to 10 for fmt = (format nil "~~~d:a" i) for s = (format nil fmt nil) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn nil) do (assert (string= s s2)) collect s))) "()" "()" "() " "() " "() " "() " "() " "() " "() " "() ") (deftest format.a.13 (with-standard-io-syntax (apply #'values (let ((fn (formatter "~V:a"))) (loop for i from 1 to 10 for s = (format nil "~v:A" i nil) for s2 = (formatter-call-to-string fn i nil) do (assert (string= s s2)) collect s)))) "()" "()" "() " "() " "() " "() " "() " "() " "() " "() ") (deftest format.a.14 (with-standard-io-syntax (apply #'values (let ((fn (formatter "~V@:A"))) (loop for i from 1 to 10 for s = (format nil "~v:@a" i nil) for s2 = (formatter-call-to-string fn i nil) do (assert (string= s s2)) collect s)))) "()" "()" " ()" " ()" " ()" " ()" " ()" " ()" " ()" " ()") (def-format-test format.a.15 "~vA" (nil nil) "NIL") (def-format-test format.a.16 "~v:A" (nil nil) "()") (def-format-test format.a.17 "~@A" (nil) "NIL") (def-format-test format.a.18 "~v@A" (nil nil) "NIL") (def-format-test format.a.19 "~v:@a" (nil nil) "()") (def-format-test format.a.20 "~v@:a" (nil nil) "()") ;;; With colinc specified (def-format-test format.a.21 "~3,1a" (nil) "NIL") (def-format-test format.a.22 "~4,3a" (nil) "NIL ") (def-format-test format.a.23 "~3,3@a" (nil) "NIL") (def-format-test format.a.24 "~4,4@a" (nil) " NIL") (def-format-test format.a.25 "~5,3@a" (nil) " NIL") (def-format-test format.a.26 "~5,3A" (nil) "NIL ") (def-format-test format.a.27 "~7,3@a" (nil) " NIL") (def-format-test format.a.28 "~7,3A" (nil) "NIL ") ;;; With minpad (deftest format.a.29 (let ((fn (formatter "~v,,2A"))) (loop for i from -4 to 10 for s = (format nil "~v,,2A" i "ABC") for s2 = (formatter-call-to-string fn i "ABC") do (assert (string= s s2)) collect s)) ("ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC ")) (def-format-test format.a.30 "~3,,+2A" ("ABC") "ABC ") (def-format-test format.a.31 "~3,,0A" ("ABC") "ABC") (def-format-test format.a.32 "~3,,-1A" ("ABC") "ABC") (def-format-test format.a.33 "~3,,0A" ("ABCD") "ABCD") (def-format-test format.a.34 "~3,,-1A" ("ABCD") "ABCD") ;;; With padchar (def-format-test format.a.35 "~4,,,'XA" ("AB") "ABXX") (def-format-test format.a.36 "~4,,,a" ("AB") "AB ") (def-format-test format.a.37 "~4,,,'X@a" ("AB") "XXAB") (def-format-test format.a.38 "~4,,,@A" ("AB") " AB") (def-format-test format.a.39 "~10,,,vA" (nil "abcde") "abcde ") (def-format-test format.a.40 "~10,,,v@A" (nil "abcde") " abcde") (def-format-test format.a.41 "~10,,,va" (#\* "abcde") "abcde*****") (def-format-test format.a.42 "~10,,,v@a" (#\* "abcde") "*****abcde") ;;; Other tests (def-format-test format.a.43 "~3,,vA" (nil "ABC") "ABC") (deftest format.a.44 (let ((fn (formatter "~3,,vA"))) (loop for i from 0 to 6 for s =(format nil "~3,,vA" i "ABC") for s2 = (formatter-call-to-string fn i "ABC") do (assert (string= s s2)) collect s)) ("ABC" "ABC " "ABC " "ABC " "ABC " "ABC " "ABC ")) (deftest format.a.44a (let ((fn (formatter "~3,,v@A"))) (loop for i from 0 to 6 for s = (format nil "~3,,v@A" i "ABC") for s2 = (formatter-call-to-string fn i "ABC") do (assert (string= s s2)) collect s)) ("ABC" " ABC" " ABC" " ABC" " ABC" " ABC" " ABC")) (def-format-test format.a.45 "~4,,va" (-1 "abcd") "abcd") (def-format-test format.a.46 "~5,vA" (nil "abc") "abc ") (def-format-test format.a.47 "~5,vA" (3 "abc") "abc ") (def-format-test format.a.48 "~5,v@A" (3 "abc") " abc") ;;; # parameters (def-format-test format.a.49 "~#A" ("abc" nil nil nil) "abc " 3) (def-format-test format.a.50 "~#@a" ("abc" nil nil nil nil nil) " abc" 5) (def-format-test format.a.51 "~5,#a" ("abc" nil nil nil) "abc " 3) (def-format-test format.a.52 "~5,#@A" ("abc" nil nil nil) " abc" 3) (def-format-test format.a.53 "~4,#A" ("abc" nil nil) "abc " 2) (def-format-test format.a.54 "~4,#@A" ("abc" nil nil) " abc" 2) (def-format-test format.a.55 "~#,#A" ("abc" nil nil nil) "abc " 3) (def-format-test format.a.56 "~#,#@A" ("abc" nil nil nil) " abc" 3) (def-format-test format.a.57 "~-100A" ("xyz") "xyz") (def-format-test format.a.58 "~-100000000000000000000a" ("xyz") "xyz") gcl27-2.7.0/ansi-tests/format-ampersand.lsp000066400000000000000000000056501454061450500205220ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jul 27 23:52:20 2004 ;;;; Contains: Tests of format with ~& directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-format-test format.&.1 "~0&" nil "") (def-format-test format.&.2 "~&" nil "") (def-format-test format.&.3 "X~&" nil #.(concatenate 'string "X" (string #\Newline))) (def-format-test format.&.4 "X~%~&" nil #.(concatenate 'string "X" (string #\Newline))) (deftest format.&.5 (loop for i from 1 to 100 for s1 = (make-string (1- i) :initial-element #\Newline) for format-string = (format nil "~~~D&" i) for s2 = (format nil format-string) unless (string= s1 s2) collect i) nil) (deftest formatter.&.5 (loop for i from 1 to 100 for s1 = (make-string (1- i) :initial-element #\Newline) for format-string = (format nil "~~~D&" i) for fn = (eval `(formatter ,format-string)) for s2 = (formatter-call-to-string fn) unless (string= s1 s2) collect i) nil) (deftest format.&.6 (loop for i from 1 to 100 for s1 = (concatenate 'string "X" (make-string i :initial-element #\Newline)) for format-string = (format nil "X~~~D&" i) for s2 = (format nil format-string) unless (string= s1 s2) collect i) nil) (deftest formatter.&.6 (loop for i from 1 to 100 for s1 = (concatenate 'string "X" (make-string i :initial-element #\Newline)) for format-string = (format nil "X~~~D&" i) for fn = (eval `(formatter ,format-string)) for s2 = (formatter-call-to-string fn) unless (string= s1 s2) collect i) nil) (def-format-test format.&.7 "~v&" (nil) "") (def-format-test format.&.8 "X~v&" (nil) #.(concatenate 'string "X" (string #\Newline))) (deftest format.&.9 (loop for i from 1 to 100 for s1 = (make-string (1- i) :initial-element #\Newline) for s2 = (format nil "~V&" i) unless (string= s1 s2) collect i) nil) (deftest formatter.&.9 (let ((fn (formatter "~V&"))) (loop for i from 1 to 100 for s1 = (make-string (1- i) :initial-element #\Newline) for s2 = (formatter-call-to-string fn i) unless (string= s1 s2) collect i)) nil) (deftest format.&.10 (loop for i from 1 to (min (- call-arguments-limit 3) 100) for s1 = (make-string (1- i) :initial-element #\Newline) for args = (make-list i) for s2 = (apply #'format nil "~#&" args) unless (string= s1 s2) collect i) nil) (deftest formatter.&.10 (let ((fn (formatter "~#&"))) (loop for i from 1 to (min (- call-arguments-limit 3) 100) for s1 = (make-string (1- i) :initial-element #\Newline) for args = (loop for j below i collect j) for s2 = (with-output-to-string (stream) (assert (equal (apply fn stream args) args))) unless (string= s1 s2) collect i)) nil) (def-format-test format.&.11 "X~V%" (0) "X") (def-format-test format.&.12 "X~#%" nil "X") (def-format-test format.&.13 "X~#%" ('a 'b 'c) #.(let ((nl (string #\Newline))) (concatenate 'string "X" nl nl nl)) 3) gcl27-2.7.0/ansi-tests/format-b.lsp000066400000000000000000000371731454061450500167760ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 1 05:10:10 2004 ;;;; Contains: Tests of the ~B format directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest format.b.1 (let ((fn (formatter "~b"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for s1 = (format nil "~B" i) for s2 = (formatter-call-to-string fn i) for j = (let ((*read-base* 2)) (read-from-string s1)) repeat 1000 when (or (not (string= s1 s2)) (/= i j) (find #\+ s1) (loop for c across s1 thereis (not (find c "-01")))) collect (list i s1 j s2)))) nil) (deftest format.b.2 (let ((fn (formatter "~@b"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for s1 = (format nil "~@b" i) for s2 = (formatter-call-to-string fn i) for j = (let ((*read-base* 2)) (read-from-string s1)) repeat 1000 when (or (/= i j) (not (string= s1 s2)) (loop for c across s1 thereis (not (find c "-+01")))) collect (list i s1 j s2)))) nil) (deftest format.b.3 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~b" i) for fmt = (format nil "~~~db" mincol) for s2 = (format nil fmt i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (list i mincol s1 s2 pos))) nil) (deftest formatter.b.3 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~b" i) for fmt = (format nil "~~~db" mincol) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn i) for pos = (search s1 s2) repeat 100 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (list i mincol s1 s2 pos))) nil) (deftest format.b.4 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~@B" i) for fmt = (format nil "~~~d@b" mincol) for s2 = (format nil fmt i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (and (>= i 0) (not (eql (elt s1 0) #\+))) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (list i mincol s1 s2 pos))) nil) (deftest formatter.b.4 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~@B" i) for fmt = (format nil "~~~d@b" mincol) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn i) for pos = (search s1 s2) repeat 100 when (or (null pos) (and (>= i 0) (not (eql (elt s1 0) #\+))) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (list i mincol s1 s2 pos))) nil) (deftest format.b.5 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~b" i) for fmt = (format nil "~~~d,'~c~c" mincol padchar (random-from-seq "bB")) for s2 = (format nil fmt i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 pos))) nil) (deftest formatter.b.5 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~b" i) for fmt = (format nil "~~~d,'~c~c" mincol padchar (random-from-seq "bB")) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn i) for pos = (search s1 s2) repeat 100 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 pos))) nil) (deftest format.b.6 (let ((fn (formatter "~v,vB"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~b" i) for s2 = (format nil "~v,vb" mincol padchar i) for s3 = (formatter-call-to-string fn mincol padchar i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (not (string= s2 s3)) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 s3 pos)))) nil) (deftest format.b.7 (let ((fn (formatter "~v,v@B"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~@B" i) for s2 = (format nil "~v,v@b" mincol padchar i) for s3 = (formatter-call-to-string fn mincol padchar i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (not (string= s2 s3)) (and (>= i 0) (not (eql (elt s1 0) #\+))) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 s3 pos)))) nil) ;;; Comma tests (deftest format.b.8 (let ((fn (formatter "~:B"))) (loop for i from -7 to 7 for s1 = (format nil "~b" i) for s2 = (format nil "~:b" i) for s3 = (formatter-call-to-string fn i) unless (and (string= s1 s2) (string= s2 s3)) collect (list i s1 s2 s3))) nil) (deftest format.b.9 (let ((fn (formatter "~:b"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = #\, for s1 = (format nil "~b" i) for s2 = (format nil "~:B" i) for s3 = (formatter-call-to-string fn i) repeat 1000 unless (and (string= s1 (remove commachar s2)) (string= s2 s3) (not (eql (elt s2 0) commachar)) (or (>= i 0) (not (eql (elt s2 1) commachar))) (let ((len (length s2)) (ci+1 4)) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (find (elt s2 i) "01"))))) collect (list x i commachar s1 s2 s3)))) nil) (deftest format.b.10 (let ((fn (formatter "~,,v:B"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for s1 = (format nil "~b" i) for s2 = (format nil "~,,v:b" commachar i) for s3 = (formatter-call-to-string fn commachar i) repeat 1000 unless (and (eql (elt s1 0) (elt s2 0)) (string= s2 s3) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 4) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2 s3)))) nil) (deftest format.b.11 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for s1 = (format nil "~b" i) for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "bB")) for s2 = (format nil fmt i) repeat 1000 unless (and (eql (elt s1 0) (elt s2 0)) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 4) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2))) nil) (deftest formatter.b.11 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for s1 = (format nil "~b" i) for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "bB")) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn i) repeat 100 unless (and (eql (elt s1 0) (elt s2 0)) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 4) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2))) nil) (deftest format.b.12 (let ((fn (formatter "~,,V,V:b"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for commaint = (1+ (random 20)) for s1 = (format nil "~b" i) for s2 = (format nil "~,,v,v:B" commachar commaint i) for s3 = (formatter-call-to-string fn commachar commaint i) repeat 1000 unless (and (eql (elt s1 0) (elt s2 0)) (string= s2 s3) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 (1+ commaint)) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2 s3)))) nil) (deftest format.b.13 (let ((fn (formatter "~,,V,V@:B"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for commaint = (1+ (random 20)) for s1 = (format nil "~@B" i) for s2 = (format nil "~,,v,v:@b" commachar commaint i) for s3 = (formatter-call-to-string fn commachar commaint i) repeat 1000 unless (and (string= s2 s3) (eql (elt s1 0) (elt s2 0)) (eql (elt s1 1) (elt s2 1)) (let ((len (length s2)) (ci+1 (1+ commaint)) (j 1)) (loop for i from 2 below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2 s3)))) nil) ;;; NIL arguments (def-format-test format.b.14 "~vb" (nil #b110100) "110100") (def-format-test format.b.15 "~6,vB" (nil #b100) " 100") (def-format-test format.b.16 "~,,v:b" (nil #b10011) "10,011") (def-format-test format.b.17 "~,,'*,v:B" (nil #b10110) "10*110") ;;; When the argument is not an integer, print as if using ~A and base 10 (deftest format.b.18 (let ((fn (formatter "~b"))) (loop for x in *mini-universe* for s1 = (format nil "~b" x) for s2 = (let ((*print-base* 2)) (format nil "~A" x)) for s3 = (formatter-call-to-string fn x) unless (or (integerp x) (and (string= s1 s2) (string= s1 s3))) collect (list x s1 s2 s3))) nil) (deftest format.b.19 (let ((fn (formatter "~:b"))) (loop for x in *mini-universe* for s1 = (format nil "~:B" x) for s2 = (let ((*print-base* 2)) (format nil "~A" x)) for s3 = (formatter-call-to-string fn x) unless (or (integerp x) (and (string= s1 s2) (string= s1 s3))) collect (list x s1 s2 s3))) nil) (deftest format.b.20 (let ((fn (formatter "~@b"))) (loop for x in *mini-universe* for s1 = (format nil "~@b" x) for s2 = (let ((*print-base* 2)) (format nil "~A" x)) for s3 = (formatter-call-to-string fn x) unless (or (integerp x) (and (string= s1 s2) (string= s1 s3))) collect (list x s1 s2 s3))) nil) (deftest format.b.21 (let ((fn (formatter "~:@b"))) (loop for x in *mini-universe* for s1 = (let ((*print-base* 2)) (format nil "~A" x)) for s2 = (format nil "~@:B" x) for s3 = (formatter-call-to-string fn x) for s4 = (let ((*print-base* 2)) (format nil "~A" x)) unless (or (integerp x) (and (string= s1 s2) (string= s1 s3)) (string/= s1 s4)) collect (list x s1 s2 s3))) nil) ;;; Must add tests for non-integers when the parameters ;;; are specified, but it's not clear what the meaning is. ;;; Does mincol apply to the ~A equivalent? What about padchar? ;;; Are comma-char and comma-interval always ignored? ;;; # arguments (deftest format.b.22 (apply #'values (let ((fn (formatter "~#B")) (bv #b11001)) (loop for i from 0 to 10 for args = (make-list i) for s = (apply #'format nil "~#b" bv args) for s2 = (with-output-to-string (stream) (assert (equal (apply fn stream bv args) args))) do (assert (string= s s2)) collect s))) "11001" "11001" "11001" "11001" "11001" " 11001" " 11001" " 11001" " 11001" " 11001" " 11001") (deftest format.b.23 (apply #'values (let ((fn (formatter "~,,,#:b")) (bv #b1100100010)) (loop for i from 0 to 10 for args = (make-list i) for s = (apply #'format nil "~,,,#:B" bv args) for s2 = (with-output-to-string (stream) (assert (equal (apply fn stream bv args) args))) do (assert (string= s s2)) collect s))) "1,1,0,0,1,0,0,0,1,0" "11,00,10,00,10" "1,100,100,010" "11,0010,0010" "11001,00010" "1100,100010" "110,0100010" "11,00100010" "1,100100010" "1100100010" "1100100010") (deftest format.b.24 (apply #'values (let ((fn (formatter "~,,,#@:B")) (bv #b1100100010)) (loop for i from 0 to 10 for args = (make-list i) for s = (apply #'format nil "~,,,#@:B" bv args) for s2 = (with-output-to-string (stream) (assert (equal (apply fn stream bv args) args))) do (assert (string= s s2)) collect s))) "+1,1,0,0,1,0,0,0,1,0" "+11,00,10,00,10" "+1,100,100,010" "+11,0010,0010" "+11001,00010" "+1100,100010" "+110,0100010" "+11,00100010" "+1,100100010" "+1100100010" "+1100100010") (def-format-test format.b.25 "~+10b" (#b1101) " 1101") (def-format-test format.b.26 "~+10@B" (#b1101) " +1101") (def-format-test format.b.27 "~-1b" (#b1101) "1101") (def-format-test format.b.28 "~-1000000000000000000B" (#b1101) "1101") (def-format-test format.b.29 "~vb" ((1- most-negative-fixnum) #b1101) "1101") ;;; Randomized test (deftest format.b.30 (let ((fn (formatter "~V,V,V,VB"))) (loop for mincol = (and (coin) (random 50)) for padchar = (and (coin) (random-from-seq +standard-chars+)) for commachar = (and (coin) (random-from-seq +standard-chars+)) for commaint = (and (coin) (1+ (random 10))) for k = (ash 1 (+ 2 (random 30))) for x = (- (random (+ k k)) k) for fmt = (concatenate 'string (if mincol (format nil "~~~d," mincol) "~,") (if padchar (format nil "'~c," padchar) ",") (if commachar (format nil "'~c," commachar) ",") (if commaint (format nil "~db" commaint) "b")) for s1 = (format nil fmt x) for s2 = (format nil "~v,v,v,vb" mincol padchar commachar commaint x) for s3 = (formatter-call-to-string fn mincol padchar commachar commaint x) repeat 2000 unless (and (string= s1 s2) (string= s2 s3)) collect (list mincol padchar commachar commaint fmt x s1 s2))) nil)gcl27-2.7.0/ansi-tests/format-brace.lsp000066400000000000000000000213751454061450500176260ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 25 22:08:51 2004 ;;;; Contains: Tests of the ~"{ ... ~} format directives (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-format-test format.{.1 (concatenate 'string "~{~" (string #\Newline) "~}") (nil) "") (def-format-test format.{.1a "~{~}" ("" nil) "") (def-format-test format.{.1b "~0{~}" ("" '(1 2 3)) "") (def-format-test format.{.2 "~{ ~}" (nil) "") (def-format-test format.{.3 "~{X Y Z~}" (nil) "") (def-format-test format.{.4 "~{~A~}" ('(1 2 3 4)) "1234") (def-format-test format.{.5 "~{~{~A~}~}" ('((1 2 3)(4 5)(6 7 8))) "12345678") (def-format-test format.{.6 "~{~1{~A~}~}" ('((1 2 3)(4 5)(6 7 8))) "146") (def-format-test format.{.7 (concatenate 'string "~1{~" (string #\Newline) "~}") (nil) "") (deftest format.{.8 (loop for i from 0 to 10 for s = (format nil "~v{~A~}" i '(1 2 3 4 5 6 7 8 9 0)) unless (string= s (subseq "1234567890" 0 i)) collect (list i s)) nil) (deftest formatter.{.8 (let ((fn (formatter "~V{~A~}"))) (loop for i from 0 to 10 for s = (formatter-call-to-string fn i '(1 2 3 4 5 6 7 8 9 0)) unless (string= s (subseq "1234567890" 0 i)) collect (list i s))) nil) (def-format-test format.{.9 "~#{~A~}" ('(1 2 3 4 5 6 7) nil nil nil) "1234" 3) ;;; (missing tests involved ~^ and have been moved to format-circumflex.lsp ;;; and renamed.) (def-format-test format.{.15 "~0{~}" ("~A" '(1 2 3)) "") (def-format-test format.{.16 "~1{~}" ("~A" '(4 5 6)) "4") (deftest format.{.17 (format nil "~{~}" (formatter "") nil) "") (deftest format.{.18 (format nil "~1{~}" (formatter "") '(1 2 3 4)) "") (deftest format.{.19 (format nil "~{~}" (formatter "~A") '(1 2 3 4)) "1234") (deftest format.{.20 (format nil "~3{~}" (formatter "~A") '(1 2 3 4)) "123") (def-format-test format.{.21 "~V{~}" (2 "~A" '(1 2 3 4 5)) "12") (def-format-test format.{.22 "~#{~}" ("~A" '(1 2 3 4 5)) "12") (def-format-test format.{.23 "~{FOO~:}" (nil) "FOO") (def-format-test format.{.24 "~{~A~:}" ('(1)) "1") (def-format-test format.{.25 "~{~A~:}" ('(1 2)) "12") (def-format-test format.{.26 "~{~A~:}" ('(1 2 3)) "123") (def-format-test format.{.27 "~0{FOO~:}" (nil) "") (def-format-test format.{.28 "~V{FOO~:}" (0 nil) "") (def-format-test format.{.29 "~1{FOO~:}" (nil) "FOO") (def-format-test format.{.30 "~2{FOO~:}" (nil) "FOO") (def-format-test format.{.31 (concatenate 'string "~2{~" (string #\Newline) "~:}") (nil) "") (def-format-test format.{.32 "~2{FOO~}" (nil) "") (def-format-test format.{.33 "~v{~a~}" (nil '(1 2 3 4 5 6 7)) "1234567") ;;; ~:{ ... ~} (def-format-test format.\:{.1 "~:{(~A ~A)~}" ('((1 2 3)(4 5)(6 7 8))) "(1 2)(4 5)(6 7)") (def-format-test format.\:{.2 (concatenate 'string "~:{~" (string #\Newline) "~}") (nil) "") (def-format-test format.\:{.3 "~:{~}" ("" nil) "") (def-format-test format.\:{.4 "~:{~}" ("~A" nil) "") (def-format-test format.\:{.5 "~:{~}" ("X" '(nil (1 2) (3))) "XXX") (deftest format.\:{.6 (format nil "~:{~}" (formatter "~A") '((1 2) (3) (4 5 6))) "134") (def-format-test format.\:{.7 "~0:{XYZ~}" ('((1))) "") (def-format-test format.\:{.8 "~2:{XYZ~}" ('((1))) "XYZ") (def-format-test format.\:{.9 "~2:{~A~}" ('((1) (2))) "12") (def-format-test format.\:{.10 "~2:{~A~}" ('((1 X) (2 Y) (3 Z))) "12") (deftest format.\:{.11 (loop for i from 0 to 10 collect (format nil "~v:{~A~}" i '((1) (2) (3 X) (4 Y Z) (5) (6)))) ("" "1" "12" "123" "1234" "12345" "123456" "123456" "123456" "123456" "123456")) (deftest formatter.\:{.11 (let ((fn (formatter "~v:{~A~}"))) (loop for i from 0 to 10 collect (formatter-call-to-string fn i '((1) (2) (3 X) (4 Y Z) (5) (6))))) ("" "1" "12" "123" "1234" "12345" "123456" "123456" "123456" "123456" "123456")) (def-format-test format.\:{.12 "~V:{X~}" (nil '((1) (2) (3) nil (5))) "XXXXX") (def-format-test format.\:{.13 "~#:{~A~}" ('((1) (2) (3) (4) (5)) 'foo 'bar) "123" 2) (def-format-test format.\:{.14 "~:{~A~:}" ('((1 X) (2 Y) (3) (4 A B))) "1234") (deftest format.\:{.15 (loop for i from 0 to 10 collect (format nil "~v:{~A~:}" i '((1 X) (2 Y) (3) (4 A B)))) ("" "1" "12" "123" "1234" "1234" "1234" "1234" "1234" "1234" "1234")) (deftest formatter.\:{.15 (let ((fn (formatter "~v:{~A~:}"))) (loop for i from 0 to 10 collect (formatter-call-to-string fn i '((1 X) (2 Y) (3) (4 A B))))) ("" "1" "12" "123" "1234" "1234" "1234" "1234" "1234" "1234" "1234")) (def-format-test format.\:{.16 "~:{ABC~:}" ('(nil)) "ABC") (def-format-test format.\:{.17 "~v:{ABC~:}" (nil '(nil)) "ABC") ;;; Tests of ~@{ ... ~} (def-format-test format.@{.1 (concatenate 'string "~@{~" (string #\Newline) "~}") nil "") (def-format-test format.@{.1A "~@{~}" ("") "") (def-format-test format.@{.2 "~@{ ~}" nil "") (def-format-test format.@{.3 "~@{X ~A Y Z~}" (nil) "X NIL Y Z") (def-format-test format.@{.4 "~@{~A~}" (1 2 3 4) "1234") (def-format-test format.@{.5 "~@{~{~A~}~}" ('(1 2 3) '(4 5) '(6 7 8)) "12345678") (def-format-test format.@{.6 "~@{~1{~A~}~}" ('(1 2 3) '(4 5) '(6 7 8)) "146") (def-format-test format.@{.7 "~1@{FOO~}" nil "") (def-format-test format.@{.8 "~v@{~A~}" (nil 1 4 7) "147") (def-format-test format.@{.9 "~#@{~A~}" (1 2 3) "123") (deftest format.@{.10 (loop for i from 0 to 10 for x = nil then (cons i x) collect (apply #'format nil "~v@{~A~}" i (reverse x))) ("" "1" "12" "123" "1234" "12345" "123456" "1234567" "12345678" "123456789" "12345678910")) (deftest formatter.@{.10 (let ((fn (formatter "~v@{~A~}"))) (loop for i from 0 to 10 for x = nil then (cons i x) for rest = (list 'a 'b 'c) collect (with-output-to-string (s) (assert (equal (apply fn s i (append (reverse x) rest)) rest))))) ("" "1" "12" "123" "1234" "12345" "123456" "1234567" "12345678" "123456789" "12345678910")) (def-format-test format.@{.11 "~@{X~:}" nil "X") (def-format-test format.@{.12 "~@{~}" ((formatter "X~AY") 1) "X1Y") (def-format-test format.@{.13 "~v@{~}" (1 (formatter "X") 'foo) "X" 1) ;;; ~:@{ (def-format-test format.\:@{.1 (concatenate 'string "~:@{~" (string #\Newline) "~}") nil "") (def-format-test format.\:@{.2 "~:@{~A~}" ('(1 2) '(3) '(4 5 6)) "134") (def-format-test format.\:@{.3 "~:@{(~A ~A)~}" ('(1 2 4) '(3 7) '(4 5 6)) "(1 2)(3 7)(4 5)") (def-format-test format.\:@{.4 "~:@{~}" ("(~A ~A)" '(1 2 4) '(3 7) '(4 5 6)) "(1 2)(3 7)(4 5)") (def-format-test format.\:@{.5 "~:@{~}" ((formatter "(~A ~A)") '(1 2 4) '(3 7) '(4 5 6)) "(1 2)(3 7)(4 5)") (def-format-test format.\:@.6 "~:@{~A~:}" ('(1 A) '(2 B) '(3) '(4 C D)) "1234") (def-format-test format.\:@.7 "~0:@{~A~:}" ('(1 A) '(2 B) '(3) '(4 C D)) "" 4) (def-format-test format.\:@.8 "~#:@{A~:}" (nil nil nil) "AAA") (def-format-test format.\:@.9 "~v:@{~A~}" (nil '(1) '(2) '(3)) "123") (deftest format.\:@.10 (loop for i from 0 to 10 for x = nil then (cons (list i) x) collect (apply #'format nil "~V:@{~A~}" i (reverse x))) ("" "1" "12" "123" "1234" "12345" "123456" "1234567" "12345678" "123456789" "12345678910")) (deftest formatter.\:@.10 (let ((fn (formatter "~V@:{~A~}"))) (loop for i from 0 to 10 for x = nil then (cons (list i) x) for rest = (list 'a 'b) collect (with-output-to-string (s) (assert (equal (apply fn s i (append (reverse x) rest)) rest))))) ("" "1" "12" "123" "1234" "12345" "123456" "1234567" "12345678" "123456789" "12345678910")) ;;; Error tests (deftest format.{.error.1 (signals-type-error x 'A (format nil "~{~A~}" x)) t) (deftest format.{.error.2 (signals-type-error x 1 (format nil "~{~A~}" x)) t) (deftest format.{.error.3 (signals-type-error x "foo" (format nil "~{~A~}" x)) t) (deftest format.{.error.4 (signals-type-error x #*01101 (format nil "~{~A~}" x)) t) (deftest format.{.error.5 (signals-error (format nil "~{~A~}" '(x y . z)) type-error) t) (deftest format.\:{.error.1 (signals-error (format nil "~:{~A~}" '(x)) type-error) t) (deftest format.\:{.error.2 (signals-type-error x 'x (format nil "~:{~A~}" x)) t) (deftest format.\:{.error.3 (signals-error (format nil "~:{~A~}" '((x) . y)) type-error) t) (deftest format.\:{.error.4 (signals-error (format nil "~:{~A~}" '("X")) type-error) t) (deftest format.\:{.error.5 (signals-error (format nil "~:{~A~}" '(#(X Y Z))) type-error) t) (deftest format.\:@{.error.1 (signals-type-error x 'x (format nil "~:@{~A~}" x)) t) (deftest format.\:@{.error.2 (signals-type-error x 0 (format nil "~:@{~A~}" x)) t) (deftest format.\:@{.error.3 (signals-type-error x #*01101 (format nil "~:@{~A~}" x)) t) (deftest format.\:@{.error.4 (signals-type-error x "abc" (format nil "~:@{~A~}" x)) t) (deftest format.\:@{.error.5 (signals-error (format nil "~:@{~A ~A~}" '(x . y)) type-error) t) gcl27-2.7.0/ansi-tests/format-c.lsp000066400000000000000000000060451454061450500167710ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jul 27 23:07:16 2004 ;;;; Contains: Tests of formatted output, ~C directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; Test of the ~C directive (deftest format.c.1 (loop for c across +standard-chars+ for s = (format nil "~C" c) unless (string= s (string c)) collect (list c s)) nil) (deftest format.c.1a (loop with count = 0 for i from 0 below (min #x10000 char-code-limit) for c = (code-char i) for s = (and c (format nil "~c" c)) unless (or (not c) (not (eql (char-code c) (char-int c))) (string= s (string c))) do (incf count) and collect (list i c s) when (> count 100) collect "count limit exceeded" and do (loop-finish)) nil) (deftest format.c.2 (loop for c across +standard-chars+ for s = (format nil "~:c" c) unless (or (not (graphic-char-p c)) (eql c #\Space) (string= s (string c))) collect (list c s)) nil) (deftest format.c.2a (loop with count = 0 for i from 0 below (min #x10000 char-code-limit) for c = (code-char i) for s = (and c (format nil "~:C" c)) unless (or (not c) (not (eql (char-code c) (char-int c))) (not (graphic-char-p c)) (eql c #\Space) (string= s (string c))) do (incf count) and collect (list i c s) when (> count 100) collect "count limit exceeded" and do (loop-finish)) nil) (def-format-test format.c.3 "~:C" (#\Space) #.(char-name #\Space)) (deftest format.c.4 (loop for c across +standard-chars+ for s = (format nil "~:C" c) unless (or (graphic-char-p c) (string= s (char-name c))) collect (list c (char-name c) s)) nil) (deftest format.c.4a (loop with count = 0 for i from 0 below (min #x10000 char-code-limit) for c = (code-char i) for s = (and c (format nil "~:c" c)) unless (or (not c) (not (eql (char-code c) (char-int c))) (graphic-char-p c) (string= s (char-name c))) do (incf count) and collect (print (list i c s)) when (> count 100) collect "count limit exceeded" and do (loop-finish)) nil) (deftest format.c.5 (loop for c across +standard-chars+ for s = (format nil "~@c" c) for c2 = (read-from-string s) unless (eql c c2) collect (list c s c2)) nil) (deftest format.c.5a (loop with count = 0 for i from 0 below (min #x10000 char-code-limit) for c = (code-char i) for s = (and c (format nil "~@C" c)) for c2 = (and c (read-from-string s)) unless (eql c c2) do (incf count) and collect (list c s c2) when (> count 100) collect "count limit exceeded" and do (loop-finish)) nil) (deftest format.c.6 (loop for c across +standard-chars+ for s1 = (format nil "~:C" c) for s2 = (format nil "~:@C" c) unless (eql (search s1 s2) 0) collect (list c s1 s2)) nil) (deftest format.c.6a (loop with count = 0 for i from 0 below (min #x10000 char-code-limit) for c = (code-char i) for s1 = (and c (format nil "~:C" c)) for s2 = (and c (format nil "~@:C" c)) unless (or (not c) (eql (search s1 s2) 0)) do (incf count) and collect (list c s1 s2) when (> count 100) collect "count limit exceeded" and do (loop-finish)) nil) gcl27-2.7.0/ansi-tests/format-circumflex.lsp000066400000000000000000000516401454061450500207110ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Nov 11 20:17:51 2004 ;;;; Contains: Tests of the ~^ format directive (inside other format constructs) (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; Tests of ~^ inside ~{ ... ~} (def-format-test format.^.{.1 "~{X ~A~^ Y ~A~^ ~}" ('(1 2 3 4 5)) "X 1 Y 2 X 3 Y 4 X 5") (def-format-test format.^.{.2 "~{X ~A~^ Y ~A~^ ~}" ('(1 2 3 4)) "X 1 Y 2 X 3 Y 4") (def-format-test format.^.{.3 "~1{~A~^~A~}" ('(1)) "1") (def-format-test format.^.{.4 "~0{~A~^~A~}" ('(1)) "") (def-format-test format.^.{.5 "~1{~A~^~A~}" ('(1 2 3)) "12") (def-format-test format.^.{.6 "~{~A~A~0^~A~}" ('(1 2 3 4 5 6)) "12") (def-format-test format.^.{.7 "~{~A~A~v^~A~}" ('(1 2 3 4 5 6 0 7 8 9 10 11 12)) "12456") (def-format-test format.^.{.8 "~{~#,3^~A~}" ('(1 2 3 4 5 6 7 8 9 10)) "1234567") (def-format-test format.^.{.9 "~{~2,#^~A~}~A" ('(1 2 3 4 5 6 7 8 9 10) 0) "123456780") (def-format-test format.^.{.10 "~{~#,#^~A~}" ('(1 2 3 4 5 6 7 8 9 10)) "") (def-format-test format.^.{.11 "~{~#,#,#^~A~}" ('(1 2 3 4 5 6 7 8 9 10)) "") (def-format-test format.^.{.12 "~{~#,1,2^~A~}" ('(1 2 3 4 5 6 7 8 9 10)) "123456789") (def-format-test format.^.{.13 "~{~#,#,v^~A~}" ('(1 2 3 4 5 6 7 8 9 10)) "246") (def-format-test format.^.{.14 "~{~#,#,v^~A~}" ('(1 2 3 4 5 6 7 8 9 10 11)) "246") (def-format-test format.^.{.15 "~{~#,#,v^~A~}" ('(1 2 3 4 5 6 7 8 9 10 11 12)) "246") (def-format-test format.^.{.16 "~{~#,#,v^~A~}" ('(1 2 3 4 5 6 7 8 9 10 11 12 13)) "246") (def-format-test format.^.{.17 "~{~#,#,v^~A~}" ('(1 2 3 4 5 6 7 8 9 10 11 12 13 14)) "2468") (def-format-test format.^.{.18 "~{~v,v^~A~}" ((list (1+ most-positive-fixnum) (1+ most-positive-fixnum) 1)) "") (def-format-test format.^.{.19 "~{~0,v,v^~A~}" ((list (1+ most-positive-fixnum) (1+ most-positive-fixnum) 1)) "") (def-format-test format.^.{.20 "~{~0,v,v^~A~}" ((list (1+ most-positive-fixnum) most-positive-fixnum 1)) "1") (def-format-test format.^.{.21 "~{~1,v^~A~}" ('(nil 8 nil 7 0 6 1 5)) "876") (def-format-test format.^.{.22 "~{~0,v^~A~}" ('(3 8 1 7 3 6 nil 5)) "876") (def-format-test format.^.{.23 "~{~1,2,v^~A~}" ('(0 1 0 2 0 3 3 4)) "123") (def-format-test format.^.{.24 "~{~1,2,v^~A~}" ('(0 1 0 2 0 3 nil 4)) "1234") (def-format-test format.^.{.25 "~{~1,1,v^~A~}" ('(0 1 0 2 0 3 nil 4)) "123") (def-format-test format.^.{.26 "~{~'X^~A~}" ('(1 2 3)) "123") (def-format-test format.^.{.27 "~{~v,'X^~A~}" ('(0 1 #\x 2 nil 3 #\X 4 0 5)) "123") (def-format-test format.^.{.28 "~{~'X,v^~A~}" ('(0 1 #\x 2 nil 3 #\X 4 0 5)) "123") (def-format-test format.^.{.29 "~{~v,v^~A~}" ('(0 2 1 #\x #\X 2 5 #\X 3 #\y #\y 4 1 2 5)) "123") (def-format-test format.^.{.30 "~{~',,',^~A~}" ('(1 2 3)) "") (def-format-test format.^.{.31 "~{~1,v,v^~A~}" ('(#\a nil 0)) "0") (def-format-test format.^.{.32 "~{~v,1,v^~A~}" ('(#\a nil 0)) "0") (def-format-test format.^.{.33 "~{~v,v,v^~A~}" ('(#\a #\a nil 0)) "") ;;; ~^ with ~:{ (def-format-test format.^.\:{.1 "~:{~A~^~A~A~}" ('((1)(2 3 4)(5 6 7 8))) "1234567") (def-format-test format.^.\:{.2 "~:{~A~0^~A~A~}" ('((1)(2 3 4)(5 6 7 8))) "125") (def-format-test format.^.\:{.3 "~:{~#^~A~}" ('((1)(2 3 4)()(5 6 7 8))()) "125" 1) (def-format-test format.^.\:{.4 "~:{~#^~A~#^~A~#^~A~#^~A~}" ('((1)(2 3 4)()(5 6 7 8))()) "12345678" 1) (def-format-test format.^.\:{.5 "~:{~v^~A~}" ('((1 2 3)(0)(2 4)(0 5)(1 6 7 8))) "246") (def-format-test format.^.\:{.6 "~:{~v^~A~}" ('((nil)(nil 1)(1 2))) "12") (def-format-test format.^.\:{.7 "~:{~v^~A~}" ('((#\x 1)(#\y 2)(0 3)(1 4))) "124") (def-format-test format.^.\:{.8 "~:{~v,3^~A~}" ('((1 1)(2 0)(3 4)(5 6))) "106") (def-format-test format.^.\:{.9 "~:{~3,v^~A~}" ('((1 1)(2 0)(3 4)(5 6))) "106") (def-format-test format.^.\:{.10 "~:{~v,3^~A~}" ('((#\x 1))) "1") (def-format-test format.^.\:{.11 "~:{~2,v^~A~}" ('((#\x 1))) "1") (def-format-test format.^.\:{.12 "~:{~v,v^~A~}" ('((1 2 0) (0 1 1) (1 0 2) (3 3 5) (4 5 6))) "0126") (def-format-test format.^.\:{.13 "~:{~v,v^~A~}" ('((1 2 0) (#\a #\A 1) (#\A #\A 2) (1 2 3))) "013") (def-format-test format.^.\:{.14 "~:{~'x,3^~A~}" ('((1))) "1") (def-format-test format.^.\:{.15 "~:{~3,'x^~A~}" ('((1))) "1") (def-format-test format.^.\:{.16 "~:{~'x,'x^~A~}" ('((1))) "") (def-format-test format.^.\:{.17 "~:{~#,1^~A~}" ('((1)(2 10)(3 a b)(4)(5 x)(6)(7 8))) "2357") (def-format-test format.^.\:{.18 "~:{~1,#^~A~}" ('((1)(2 10)(3 a b)(4)(5 x)(6)(7 8))) "2357") (def-format-test format.^.\:{.19 "~:{~#,#^~A~}" ('((1)()(2 10)(3 a b)(4)(5 x)(6)(7 8))) "") (def-format-test format.^.\:{.20 "~:{~0,v^~A~}" ('((0 1)(1 2)(nil 3)(2 4))) "24") (def-format-test format.^.\:{.21 "~:{~1,v^~A~}" ('((0 1)(1 2)(nil 3)(2 4))) "134") (def-format-test format.^.\:{.22 "~:{~1,1,1^~A~}" ('((1)(2 3)(4 5 6)(7 8 9 0))) "") (def-format-test format.^.\:{.23 "~:{~1,2,3^~A~}" ('((1)(2 3)(4 5 6)(7 8 9 0))) "") (def-format-test format.^.\:{.24 "~:{~1,2,1^~A~}" ('((1)(2 3)(4 5 6)(7 8 9 0))) "1247") (def-format-test format.^.\:{.25 "~:{~1,0,1^~A~}" ('((1)(2 3)(4 5 6)(7 8 9 0))) "1247") (def-format-test format.^.\:{.26 "~:{~3,2,1^~A~}" ('((1)(2 3)(4 5 6)(7 8 9 0))) "1247") (def-format-test format.^.\:{.27 "~:{~v,2,3^~A~}" ('((1 10)(2 20)(3 30)(4 40))) "3040") (def-format-test format.^.\:{.28 "~:{~1,v,3^~A~}" ('((0 7)(1 10)(2 20)(3 30)(4 40))) "740") (def-format-test format.^.\:{.29 "~:{~1,2,v^~A~}" ('((0 0)(1 10)(2 20)(3 30)(4 40)(0 50))) "01050") (def-format-test format.^.\:{.30 "~:{~1,2,v^~A~}" ('((nil 0))) "0") (def-format-test format.^.\:{.31 "~:{~#,3,3^~A~}" ('((1) (2 1) (3 2 1) (4 3 2 1) (5 4 3 2 1))) "45") (def-format-test format.^.\:{.32 "~:{~2,#,3^~A~}" ('((1) (2 1) (3 2 1) (4 3 2 1) (5 4 3 2 1))) "145") (def-format-test format.^.\:{.33 "~:{~0,3,#^~A~}" ('((1) (2 1) (3 2 1) (4 3 2 1) (5 4 3 2 1))) "12") (def-format-test format.^.\:{.34 "~:{~#,#,3^~A~}" ('((1) (2 1) (3 2 1) (4 3 2 1) (5 4 3 2 1))) "45") (def-format-test format.^.\:{.35 "~:{~3,#,#^~A~}" ('((1) (2 1) (3 2 1) (4 3 2 1) (5 4 3 2 1))) "12") (def-format-test format.^.\:{.36 "~:{~#,3,#^~A~}" ('((1) (2 1) (3 2 1) (4 3 2 1) (5 4 3 2 1))) "1245") (def-format-test format.^.\:{.37 "~:{~#,#,#^~A~}" ('((1) (2 1) (3 2 1) (4 3 2 1) (5 4 3 2 1))) "") (def-format-test format.^.\:{.38 "~:{~1,v,v^~A~}" ('((#\a nil 0))) "0") (def-format-test format.^.\:{.39 "~:{~v,1,v^~A~}" ('((#\a nil 0))) "0") ;;; Tests of ~^ inside ~@{ ... ~} (def-format-test format.^.@{.1 "~@{X ~A~^ Y ~A~^ ~}" (1 2 3 4 5) "X 1 Y 2 X 3 Y 4 X 5") (def-format-test format.^.@{.2 "~@{X ~A~^ Y ~A~^ ~}" (1 2 3 4) "X 1 Y 2 X 3 Y 4") (def-format-test format.^.@{.3 "~1@{~A~^~A~}" (1) "1") (def-format-test format.^.@{.4 "~0@{~A~^~A~}" (1) "" 1) (def-format-test format.^.@{.5 "~1@{~A~^~A~}" (1 2 3) "12" 1) (def-format-test format.^.@{.6 "~@{~A~A~0^~A~}" (1 2 3 4 5 6) "12" 4) (def-format-test format.^.@{.7 "~@{~A~A~v^~A~}" (1 2 3 4 5 6 0 7 8 9 10 11 12) "12456" 6) (def-format-test format.^.@{.8 "~@{~#,3^~A~}" (1 2 3 4 5 6 7 8 9 10) "1234567" 3) (def-format-test format.^.@{.9 "~@{~2,#^~A~}X~A" (1 2 3 4 5 6 7 8 9 10) "12345678X9" 1) (def-format-test format.^.@{.10 "~@{~#,#^~A~}" (1 2 3 4 5 6 7 8 9 10) "" 10) (def-format-test format.^.@{.11 "~@{~#,#,#^~A~}" (1 2 3 4 5 6 7 8 9 10) "" 10) (def-format-test format.^.@{.12 "~@{~#,1,2^~A~}" (1 2 3 4 5 6 7 8 9 10) "123456789" 1) (def-format-test format.^.@{.13 "~@{~#,#,v^~A~}" (1 2 3 4 5 6 7 8 9 10) "246" 3) (def-format-test format.^.@{.14 "~@{~#,#,v^~A~}" (1 2 3 4 5 6 7 8 9 10 11) "246" 4) (def-format-test format.^.@{.15 "~@{~#,#,v^~A~}" (1 2 3 4 5 6 7 8 9 10 11 12) "246" 5) (def-format-test format.^.@{.16 "~@{~#,#,v^~A~}" (1 2 3 4 5 6 7 8 9 10 11 12 13) "246" 6) (def-format-test format.^.@{.17 "~@{~#,#,v^~A~}" (1 2 3 4 5 6 7 8 9 10 11 12 13 14) "2468" 5) (def-format-test format.^.@{.18 "~@{~v,v^~A~}" ((1+ most-positive-fixnum) (1+ most-positive-fixnum) 1) "" 1) (def-format-test format.^.@{.19 "~@{~0,v,v^~A~}" ((1+ most-positive-fixnum) (1+ most-positive-fixnum) 1) "" 1) (def-format-test format.^.@{.20 "~@{~0,v,v^~A~}" ((1+ most-positive-fixnum) most-positive-fixnum 1) "1") (def-format-test format.^.@{.21 "~@{~1,v^~A~}" (nil 8 nil 7 0 6 1 5) "876" 1) (def-format-test format.^.@{.22 "~@{~0,v^~A~}" (3 8 1 7 3 6 nil 5) "876" 1) (def-format-test format.^.@{.23 "~@{~1,2,v^~A~}" (0 1 0 2 0 3 3 4) "123" 1) (def-format-test format.^.@{.24 "~@{~1,2,v^~A~}" (0 1 0 2 0 3 nil 4) "1234") (def-format-test format.^.@{.25 "~@{~1,1,v^~A~}" (0 1 0 2 0 3 nil 4) "123" 1) (def-format-test format.^.@{.26 "~@{~'X^~A~}" (1 2 3) "123") (def-format-test format.^.@{.27 "~@{~v,'X^~A~}" (0 1 #\x 2 nil 3 #\X 4 0 5) "123" 3) (def-format-test format.^.@{.28 "~@{~'X,v^~A~}" (0 1 #\x 2 nil 3 #\X 4 0 5) "123" 3) (def-format-test format.^.@{.29 "~@{~v,v^~A~}" (0 2 1 #\x #\X 2 5 #\X 3 #\y #\y 4 1 2 5) "123" 4) (def-format-test format.^.@{.30 "~@{~',,',^~A~}" (1 2 3) "" 3) (def-format-test format.^.@{.31 "~@{~1,v,v^~A~}" (#\a nil 0) "0") (def-format-test format.^.@{.32 "~@{~v,1,v^~A~}" (#\a nil 0) "0") (def-format-test format.^.@{.33 "~@{~v,v,v^~A~}" (#\a #\a nil 0) "" 1) ;;; Inside ~:@{ (def-format-test format.^.\:@{.1 "~:@{~A~^~A~A~}" ('(1) '(2 3 4) '(5 6 7 8)) "1234567") (def-format-test format.^.\:@{.2 "~@:{~A~0^~A~A~}" ('(1) '(2 3 4) '(5 6 7 8)) "125") (def-format-test format.^.\:@{.3 "~:@{~#^~A~}" ('(1) '(2 3 4) () '(5 6 7 8) ()) "125") (def-format-test format.^.\:@{.4 "~@:{~#^~A~#^~A~#^~A~#^~A~}" ('(1) '(2 3 4) () '(5 6 7 8) ()) "12345678") (def-format-test format.^.\:@{.5 "~:@{~v^~A~}" ('(1 2 3) '(0) '(2 4) '(0 5) '(1 6 7 8)) "246") (def-format-test format.^.\:@{.6 "~:@{~v^~A~}" ('(nil) '(nil 1) '(1 2)) "12") (def-format-test format.^.\:@{.7 "~:@{~v^~A~}" ('(#\x 1) '(#\y 2) '(0 3) '(1 4)) "124") (def-format-test format.^.\:@{.8 "~:@{~v,3^~A~}" ('(1 1) '(2 0) '(3 4) '(5 6)) "106") (def-format-test format.^.\:@{.9 "~@:{~3,v^~A~}" ('(1 1) '(2 0) '(3 4) '(5 6)) "106") (def-format-test format.^.\:@{.10 "~:@{~v,3^~A~}" ('(#\x 1)) "1") (def-format-test format.^.\:@{.11 "~:@{~2,v^~A~}" ('(#\x 1)) "1") (def-format-test format.^.\:@{.12 "~:@{~v,v^~A~}" ('(1 2 0) '(0 1 1) '(1 0 2) '(3 3 5) '(4 5 6)) "0126") (def-format-test format.^.\:@{.13 "~:@{~v,v^~A~}" ('(1 2 0) '(#\a #\A 1) '(#\A #\A 2) '(1 2 3)) "013") (def-format-test format.^.\:@{.14 "~:@{~'x,3^~A~}" ('(1)) "1") (def-format-test format.^.\:@{.15 "~:@{~3,'x^~A~}" ('(1)) "1") (def-format-test format.^.\:@{.16 "~:@{~'x,'x^~A~}" ('(1)) "") (def-format-test format.^.\:@{.17 "~:@{~#,1^~A~}" ('(1) '(2 10) '(3 a b) '(4) '(5 x) '(6) '(7 8)) "2357") (def-format-test format.^.\:@{.18 "~:@{~1,#^~A~}" ('(1) '(2 10) '(3 a b) '(4) '(5 x) '(6) '(7 8)) "2357") (def-format-test format.^.\:@{.19 "~:@{~#,#^~A~}" ('(1) '() '(2 10) '(3 a b) '(4) '(5 x) '(6) '(7 8)) "") (def-format-test format.^.\:@{.20 "~:@{~0,v^~A~}" ('(0 1) '(1 2) '(nil 3) '(2 4)) "24") (def-format-test format.^.\:@{.21 "~:@{~1,v^~A~}" ('(0 1) '(1 2) '(nil 3) '(2 4)) "134") (def-format-test format.^.\:@{.22 "~:@{~1,1,1^~A~}" ('(1) '(2 3) '(4 5 6) '(7 8 9 0)) "") (def-format-test format.^.\:@{.23 "~:@{~1,2,3^~A~}" ('(1) '(2 3) '(4 5 6) '(7 8 9 0)) "") (def-format-test format.^.\:@{.24 "~:@{~1,2,1^~A~}" ('(1) '(2 3) '(4 5 6) '(7 8 9 0)) "1247") (def-format-test format.^.\:@{.25 "~:@{~1,0,1^~A~}" ('(1) '(2 3) '(4 5 6) '(7 8 9 0)) "1247") (def-format-test format.^.\:@{.26 "~:@{~3,2,1^~A~}" ('(1) '(2 3) '(4 5 6) '(7 8 9 0)) "1247") (def-format-test format.^.\:@{.27 "~:@{~v,2,3^~A~}" ('(1 10) '(2 20) '(3 30) '(4 40)) "3040") (def-format-test format.^.\:@{.28 "~:@{~1,v,3^~A~}" ('(0 7) '(1 10) '(2 20) '(3 30) '(4 40)) "740") (def-format-test format.^.\:@{.29 "~:@{~1,2,v^~A~}" ('(0 0) '(1 10) '(2 20) '(3 30) '(4 40) '(0 50)) "01050") (def-format-test format.^.\:@{.30 "~:@{~1,2,v^~A~}" ('(nil 0)) "0") (def-format-test format.^.\:@{.31 "~:@{~#,3,3^~A~}" ('(1) '(2 1) '(3 2 1) '(4 3 2 1) '(5 4 3 2 1)) "45") (def-format-test format.^.\:@{.32 "~:@{~2,#,3^~A~}" ('(1) '(2 1) '(3 2 1) '(4 3 2 1) '(5 4 3 2 1)) "145") (def-format-test format.^.\:@{.33 "~:@{~0,3,#^~A~}" ('(1) '(2 1) '(3 2 1) '(4 3 2 1) '(5 4 3 2 1)) "12") (def-format-test format.^.\:@{.34 "~:@{~#,#,3^~A~}" ('(1) '(2 1) '(3 2 1) '(4 3 2 1) '(5 4 3 2 1)) "45") (def-format-test format.^.\:@{.35 "~:@{~3,#,#^~A~}" ('(1) '(2 1) '(3 2 1) '(4 3 2 1) '(5 4 3 2 1)) "12") (def-format-test format.^.\:@{.36 "~:@{~#,3,#^~A~}" ('(1) '(2 1) '(3 2 1) '(4 3 2 1) '(5 4 3 2 1)) "1245") (def-format-test format.^.\:@{.37 "~:@{~#,#,#^~A~}" ('(1) '(2 1) '(3 2 1) '(4 3 2 1) '(5 4 3 2 1)) "") (def-format-test format.^.\:@{.38 "~:@{~1,v,v^~A~}" ('(#\a nil 0)) "0") (def-format-test format.^.\:@{.39 "~:@{~v,1,v^~A~}" ('(#\a nil 0)) "0") ;;; ~:^ in ~:{ (def-format-test format.\:^.\:{.1 "~:{~:^~A~}" (nil) "") (def-format-test format.\:^.\:{.2 "(~:{~A~:^,~})" ('((1)(2)(3))) "(1,2,3)") (def-format-test format.\:^.\:{.3 "~:{~:^~A~}" ('((1)(2)(3)(4))) "123") ;;; arguments (def-format-test format.\:^.\:{.4 "~:{~0:^~A~}" ('((1)(2))) "") (def-format-test format.\:^.\:{.5 "~:{~1:^~A~}" ('((1)(2))) "12") (def-format-test format.\:^.\:{.6 "~:{~'X:^~A~}" ('((1)(2))) "12") (def-format-test format.\:^.\:{.7 "~:{~v:^~A~}" ('((1 8)(2 3 4)(3 1)(0)(6 7)(8 10))) "831") (def-format-test format.\:^.\:{.8 "~:{~V:^~A~}" ('((#\X 1)(0 2))) "1") (def-format-test format.\:^.\:{.9 "~:{~#:^~A~}" ('((1)(2)(3 4)(5 6 7)()(8 9 10))) "1235") (def-format-test format.\:^.\:{.10 "~:{~1,1:^~A~}" ('(()(1)(2 3))) "") (def-format-test format.\:^.\:{.11 "~:{~0,1:^~A~}" ('((1)(2 3))) "12") (def-format-test format.\:^.\:{.12 "~:{~v,1:^~A~}" ('((2 3)(4 5 6)(0 2)(1 7)(9 10))) "352") (def-format-test format.\:^.\:{.13 "~:{~1,V:^~A~}" ('((2 3)(4 5 6)(0 2)(1 7)(9 10))) "352") (def-format-test format.\:^.\:{.14 "~:{~V,v:^~A~}" ('((0 1 2) (1 0 3) (4 4) () (5 6 7))) "23") (def-format-test format.\:^.\:{.15 "~:{~#,1:^~A~}" ('((2 3 4)(4 5)(0)(1 7)(9 10))) "24") (def-format-test format.\:^.\:{.16 "~:{~1,#:^~A~}" ('((2 3 4)(4 5)(0)(1 7)(9 10))) "24") (def-format-test format.\:^.\:{.17 "~:{~#,#:^~A~}" ('(nil)) "") (def-format-test format.\:^.\:{.18 "~:{~#,#:^~A~}" ('((1))) "") (def-format-test format.\:^.\:{.19 "~:{~#,v:^~A~}" ('((1 2)(3 4)(2 5 6)(1)(2))) "245") (def-format-test format.\:^.\:{.20 "~:{~V,#:^~A~}" ('((0 2)(1 3 4)(1 3)()(0 7))) "23") (def-format-test format.\:^.\:{.21 "~:{~'X,'Y:^~A~}" ('((1)(2))) "12") (def-format-test format.\:^.\:{.22 "~:{~'X,'X:^~A~}" ('((1)(2))) "") (def-format-test format.\:^.\:{.23 "~:{~1,2,3:^~A~}" ('((1)(2))) "") (def-format-test format.\:^.\:{.24 "~:{~1,2,1:^~A~}" ('((1)(2))) "12") (def-format-test format.\:^.\:{.25 "~:{~2,1,3:^~A~}" ('((1)(2))) "12") (def-format-test format.\:^.\:{.26 "~:{~1,1,v:^~A~}" ('((0 4)(nil 1)(0 5))) "4") (def-format-test format.\:^.\:{.27 "~:{~v,2,2:^~A~}" ('((3 4)(1 1)(4 5))) "4") (def-format-test format.\:^.\:{.28 "~:{~1,v,2:^~A~}" ('((0 2)(3 4)(1 1)(4 5))) "24") (def-format-test format.\:^.\:{.29 "~:{~V,v,3:^~A~}" ('((1 4 0)(2 1 7)(4 4 8 0)(1 2 6)(9 8 0))) "078") (def-format-test format.\:^.\:{.30 "~:{~v,2,v:^~A~}" ('((1 1 0)(3 2 5)(2 1 6)(1 2 0)(10 11 13))) "056") (def-format-test format.\:^.\:{.31 "~:{~2,V,v:^~A~}" ('((1 1 0)(3 2 5)(2 1 6)(10 11 13)(0 1 0))) "056") (def-format-test format.\:^.\:{.32 "~:{~v,v,V:^~A~}" ('((1 2 1 0)(2 1 1 4)(2 3 1 6)(1 2 3)(0 1 0 8))) "046") (def-format-test format.\:^.\:{.33 "~:{~#,2,2:^~A~}" ('((1 2 3)(2 X X)(0 A B C D)(4 5)(5 7 8 9))) "120") (def-format-test format.\:^.\:{.34 "~:{~2,#,3:^~A~}" ('((1)(2 3 4 5)(3 4)(4 5 6 7 8)())) "12") (def-format-test format.\:^.\:{.35 "~:{~1,3,#:^~A~}" ('((1)(2 3)(3 4)(4 5 6)(5))) "123") (def-format-test format.\:^.\:{.36 "~:{~#,#,2:^~A~}" ('((1 2 3)(2 X X)(0 A B C D)(4 5)(5 7 8 9))) "120") (def-format-test format.\:^.\:{.37 "~:{~3,#,#:^~A~}" ('((1)(2 3)(3 4)(4 5 6)(5))) "123") (def-format-test format.\:^.\:{.38 "~:{~#,2,#:^~A~}" ('((1 2 3)(2)(0 A B C D)(4 5)(5 7 8 9))) "120") (def-format-test format.\:^.\:{.39 "~:{~#,#,#:^~A~}" ('((1 2 3)(2)(0 A B C D)(4 5)(5 7 8 9))) "") ;;; ~:^ in ~:@{ (def-format-test format.\:^.\:@{.1 "~:@{~:^~A~}" nil "") (def-format-test format.\:^.\:@{.2 "(~:@{~A~:^,~})" ('(1) '(2) '(3)) "(1,2,3)") (def-format-test format.\:^.\:@{.3 "~:@{~:^~A~}" ('(1) '(2) '(3) '(4)) "123") (def-format-test format.\:^.\:@{.4 "~:@{~0:^~A~}" ('(1) '(2)) "" 1) (def-format-test format.\:^.\:@{.5 "~:@{~1:^~A~}" ('(1) '(2)) "12") (def-format-test format.\:^.\:@{.6 "~:@{~'X:^~A~}" ('(1) '(2)) "12") (def-format-test format.\:^.\:@{.7 "~:@{~v:^~A~}" ('(1 8) '(2 3 4) '(3 1) '(0) '(6 7) '(8 10)) "831" 2) (def-format-test format.\:^.\:@{.8 "~:@{~V:^~A~}" ('(#\X 1) '(0 2)) "1") (def-format-test format.\:^.\:@{.9 "~:@{~#:^~A~}" ('(1) '(2) '(3 4) '(5 6 7) () '(8 9 10)) "1235" 1) (def-format-test format.\:^.\:@{.10 "~:@{~1,1:^~A~}" (() '(1) '(2 3)) "" 2) (def-format-test format.\:^.\:@{.11 "~:@{~0,1:^~A~}" ('(1) '(2 3)) "12") (def-format-test format.\:^.\:@{.12 "~:@{~v,1:^~A~}" ('(2 3) '(4 5 6) '(0 2) '(1 7) '(9 10)) "352" 1) (def-format-test format.\:^.\:@{.13 "~:@{~1,V:^~A~}" ('(2 3) '(4 5 6) '(0 2) '(1 7) '(9 10)) "352" 1) (def-format-test format.\:^.\:@{.14 "~:@{~V,v:^~A~}" ('(0 1 2) '(1 0 3) '(4 4) () '(5 6 7)) "23" 2) (def-format-test format.\:^.\:@{.15 "~:@{~#,1:^~A~}" ('(2 3 4) '(4 5) '(0) '(1 7) '(9 10)) "24" 2) (def-format-test format.\:^.\:@{.16 "~:@{~1,#:^~A~}" ('(2 3 4) '(4 5) '(0) '(1 7) '(9 10)) "24" 2) (def-format-test format.\:^.\:@{.17 "~:@{~#,#:^~A~}" (nil) "") (def-format-test format.\:^.\:@{.18 "~:@{~#,#:^~A~}" ('(1)) "") (def-format-test format.\:^.\:@{.19 "~:@{~#,v:^~A~}" ('(1 2) '(3 4) '(2 5 6) '(1) '(2)) "245" 1) (def-format-test format.\:^.\:@{.20 "~:@{~V,#:^~A~}" ('(0 2) '(1 3 4) '(1 3) () '(0 7)) "23" 2) (def-format-test format.\:^.\:@{.21 "~:@{~'X,'Y:^~A~}" ('(1) '(2)) "12") (def-format-test format.\:^.\:@{.22 "~:@{~'X,'X:^~A~}" ('(1) '(2)) "" 1) (def-format-test format.\:^.\:@{.23 "~:@{~1,2,3:^~A~}" ('(1) '(2)) "" 1) (def-format-test format.\:^.\:@{.24 "~:@{~1,2,1:^~A~}" ('(1) '(2)) "12") (def-format-test format.\:^.\:@{.25 "~:@{~2,1,3:^~A~}" ('(1) '(2)) "12") (def-format-test format.\:^.\:@{.26 "~:@{~1,1,v:^~A~}" ('(0 4) '(nil 1) '(0 5)) "4" 1) (def-format-test format.\:^.\:@{.27 "~:@{~v,2,2:^~A~}" ('(3 4) '(1 1) '(4 5)) "4" 1) (def-format-test format.\:^.\:@{.28 "~:@{~1,v,2:^~A~}" ('(0 2) '(3 4) '(1 1) '(4 5)) "24" 1) (def-format-test format.\:^.\:@{.29 "~:@{~V,v,3:^~A~}" ('(1 4 0) '(2 1 7) '(4 4 8 0) '(1 2 6) '(9 8 0)) "078" 1) (def-format-test format.\:^.\:@{.30 "~:@{~v,2,v:^~A~}" ('(1 1 0) '(3 2 5) '(2 1 6) '(1 2 0) '(10 11 13)) "056" 1) (def-format-test format.\:^.\:@{.31 "~:@{~2,V,v:^~A~}" ('(1 1 0) '(3 2 5) '(2 1 6) '(10 11 13) '(0 1 0)) "056" 1) (def-format-test format.\:^.\:@{.32 "~:@{~v,v,V:^~A~}" ('(1 2 1 0) '(2 1 1 4) '(2 3 1 6) '(1 2 3) '(0 1 0 8)) "046" 1) (def-format-test format.\:^.\:@{.33 "~:@{~#,2,2:^~A~}" ('(1 2 3) '(2 X X) '(0 A B C D) '(4 5) '(5 7 8 9)) "120" 1) (def-format-test format.\:^.\:@{.34 "~:@{~2,#,3:^~A~}" ('(1) '(2 3 4 5) '(3 4) '(4 5 6 7 8) ()) "12" 2) (def-format-test format.\:^.\:@{.35 "~:@{~1,3,#:^~A~}" ('(1) '(2 3) '(3 4) '(4 5 6) '(5)) "123" 1) (def-format-test format.\:^.\:@{.36 "~:@{~#,#,2:^~A~}" ('(1 2 3) '(2 X X) '(0 A B C D) '(4 5) '(5 7 8 9)) "120" 1) (def-format-test format.\:^.\:@{.37 "~:@{~3,#,#:^~A~}" ('(1) '(2 3) '(3 4) '(4 5 6) '(5)) "123" 1) (def-format-test format.\:^.\:@{.38 "~:@{~#,2,#:^~A~}" ('(1 2 3) '(2) '(0 A B C D) '(4 5) '(5 7 8 9)) "120" 1) (def-format-test format.\:^.\:@{.39 "~:@{~#,#,#:^~A~}" ('(1 2 3) '(2) '(0 A B C D) '(4 5) '(5 7 8 9)) "" 4) ;;; ~^ inside ~?, ~@? (def-format-test format.^.?.1 "~AY~?X~A" (1 "~A~0^~A" '(2 4) 3) "1Y2X3") (def-format-test format.^.?.2 "~AY~?X~A" (1 "~A~^~A" '(2) 3) "1Y2X3") (def-format-test format.^.?.3 "~AY~?X~A" (1 "~A~^~A~^~A" '(2 4) 3) "1Y24X3") (def-format-test format.^.?.4 "~A~?X~A" (1 "~{~^~A~}~AY~A" '((2 3) 4 5) 6) "1234Y5X6") (def-format-test format.^.@?.1 "~AY~@?X~A" (1 "~A~0^~A" 2 3 4) "1Y2X3" 1) (def-format-test format.^.@?.2 "~A~@?X~A" (1 "~{~^~A~}~AY~A" '(2 3) 4 5 6) "1234Y5X6") ;;; ~^ in ~[ (def-format-test format.^.\[.1 "~{~[X~;Y~;Z~;~0^~]~}" ('(0 1 2 3 4)) "XYZ") (def-format-test format.^.\[.2 "~{~[X~;Y~;Z~:;~0^~]~}" ('(1 0 2 8 9 10 0)) "YXZ") (def-format-test format.^.\[.3 "~{~[X~;Y~0^NO~;Z~;~^~]~}" ('(0 1 2 3 4)) "XY") ;;; ~^ in ~( (def-format-test format.^.\(.1 "~{~(~C~C~0^~C~)W~}" ('(#\X #\Y #\Z #\A)) "xy") (def-format-test format.^.\:\(.1 "~{~:(~C~C~0^~C~)U~}" ('(#\X #\Y #\Z #\A)) "Xy") (def-format-test format.^.@\(.1 "~{~@(~CA ~Cb ~0^~C~)V~}" ('(#\x #\y #\Z #\A)) "Xa yb ") (def-format-test format.^.@\:\(.1 "~{~@:(~CA ~Cb ~0^~C~)W~}" ('(#\x #\Y #\Z #\A)) "XA YB ") gcl27-2.7.0/ansi-tests/format-conditional.lsp000066400000000000000000000106641454061450500210540ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 25 19:27:25 2004 ;;;; Contains: Tests of the ~[ ~] forms (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-format-test format.cond.1 "~[~]" (0) "") (def-format-test format.cond.2 "~[a~]" (0) "a") (def-format-test format.cond.3 "~[a~]" (-1) "") (def-format-test format.cond.4 "~[a~]" ((1- most-negative-fixnum)) "") (def-format-test format.cond.5 "~[a~]" (1) "") (def-format-test format.cond.6 "~[a~]" ((1+ most-positive-fixnum)) "") (deftest format.cond.7 (loop for i from -1 to 10 collect (format nil "~[a~;b~;c~;d~;e~;f~;g~;h~;i~]" i)) ("" "a" "b" "c" "d" "e" "f" "g" "h" "i" "" "")) (deftest formatter.cond.7 (let ((fn (formatter "~[a~;b~;c~;d~;e~;f~;g~;h~;i~]"))) (loop for i from -1 to 10 collect (formatter-call-to-string fn i))) ("" "a" "b" "c" "d" "e" "f" "g" "h" "i" "" "")) (def-format-test format.cond.8 "~0[a~;b~;c~;d~]" (3) "a" 1) (def-format-test format.cond.9 "~-1[a~;b~;c~;d~]" (3) "" 1) (def-format-test format.cond.10 "~1[a~;b~;c~;d~]" (3) "b" 1) (def-format-test format.cond.11 "~4[a~;b~;c~;d~]" (3) "" 1) (def-format-test format.cond.12 "~100000000000000000000000000000000[a~;b~;c~;d~]" (3) "" 1) (deftest format.cond.13 (loop for i from -1 to 10 collect (format nil "~v[a~;b~;c~;d~;e~;f~;g~;h~;i~]" i nil)) ("" "a" "b" "c" "d" "e" "f" "g" "h" "i" "" "")) (deftest formatter.cond.13 (let ((fn (formatter "~V[a~;b~;c~;d~;e~;f~;g~;h~;i~]"))) (loop for i from -1 to 10 collect (formatter-call-to-string fn i))) ("" "a" "b" "c" "d" "e" "f" "g" "h" "i" "" "")) (deftest format.cond.14 (loop for i from -1 to 10 collect (format nil "~v[a~;b~;c~;d~;e~;f~;g~;h~;i~]" nil i)) ("" "a" "b" "c" "d" "e" "f" "g" "h" "i" "" "")) (deftest formatter.cond.14 (let ((fn (formatter "~v[a~;b~;c~;d~;e~;f~;g~;h~;i~]"))) (loop for i from -1 to 10 collect (formatter-call-to-string fn nil i))) ("" "a" "b" "c" "d" "e" "f" "g" "h" "i" "" "")) (def-format-test format.cond.15 "~#[A~;B~]" nil "A") (def-format-test format.cond.16 "~#[A~;B~]" (nil) "B" 1) ;;; ~[ .~:; ~] (deftest format.cond\:.1 (loop for i from -100 to 100 for s = (format nil "~[~:;a~]" i) unless (or (zerop i) (string= s "a")) collect (list i s)) nil) (deftest formatter.cond\:.1 (let ((fn (formatter "~[~:;a~]"))) (loop for i from -100 to 100 for s = (formatter-call-to-string fn i) unless (or (zerop i) (string= s "a")) collect (list i s))) nil) (def-format-test format.cond\:.2 "~[a~:;b~]" (0) "a") (def-format-test format.cond\:.3 "~[a~:;b~]" ((1- most-negative-fixnum)) "b") (def-format-test format.cond\:.4 "~[a~:;b~]" ((1+ most-positive-fixnum)) "b") (deftest format.cond\:.5 (loop for i from -1 to 10 collect (format nil "~[a~;b~;c~;d~:;e~]" i)) ("e" "a" "b" "c" "d" "e" "e" "e" "e" "e" "e" "e")) (deftest formatter.cond\:.5 (let ((fn (formatter "~[a~;b~;c~;d~:;e~]"))) (loop for i from -1 to 10 collect (formatter-call-to-string fn i))) ("e" "a" "b" "c" "d" "e" "e" "e" "e" "e" "e" "e")) (deftest format.cond\:.6 (loop for i from -1 to 10 collect (format nil "~v[a~;b~;c~;d~:;e~]" i nil)) ("e" "a" "b" "c" "d" "e" "e" "e" "e" "e" "e" "e")) (deftest formatter.cond\:.6 (let ((fn (formatter "~v[a~;b~;c~;d~:;e~]"))) (loop for i from -1 to 10 collect (formatter-call-to-string fn i))) ("e" "a" "b" "c" "d" "e" "e" "e" "e" "e" "e" "e")) (deftest format.cond\:.7 (loop for i from -1 to 10 collect (format nil "~v[a~;b~;c~;d~:;e~]" nil i)) ("e" "a" "b" "c" "d" "e" "e" "e" "e" "e" "e" "e")) (deftest formatter.cond\:.7 (let ((fn (formatter "~v[a~;b~;c~;d~:;e~]"))) (loop for i from -1 to 10 collect (formatter-call-to-string fn nil i))) ("e" "a" "b" "c" "d" "e" "e" "e" "e" "e" "e" "e")) (def-format-test format.cond\:.8 "~#[A~:;B~]" nil "A") (def-format-test format.cond\:.9 "~#[A~:;B~]" (nil nil) "B" 2) ;;; ~:[...~] (def-format-test format.\:cond.1 "~:[a~;b~]" (nil) "a") (deftest format.\:cond.2 (loop for x in *mini-universe* for s = (format nil "~:[a~;b~]" x) when (and x (not (string= s "b"))) collect (list x s)) nil) (deftest formatter.\:cond.2 (let ((fn (formatter "~:[a~;b~]"))) (loop for x in *mini-universe* for s = (formatter-call-to-string fn x) when (and x (not (string= s "b"))) collect (list x s))) nil) ;;; ~@[ ... ~] (def-format-test format.@cond.1 "~@[X~]Y~A" (1) "XY1") (def-format-test format.@cond.2 "~@[X~]Y~A" (nil 2) "Y2") gcl27-2.7.0/ansi-tests/format-d.lsp000066400000000000000000000406311454061450500167710ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jul 31 05:19:39 2004 ;;;; Contains: Tests of the ~D format directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest format.d.1 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for s1 = (format nil "~D" i) for j = (read-from-string s1) repeat 1000 when (or (/= i j) (find #\. s1) (find #\+ s1) (find-if #'alpha-char-p s1)) collect (list i s1 j))) nil) (deftest formatter.d.1 (let ((fn (formatter "~D"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for s1 = (formatter-call-to-string fn i) for j = (read-from-string s1) repeat 1000 when (or (/= i j) (find #\. s1) (find #\+ s1) (find-if #'alpha-char-p s1)) collect (list i s1 j)))) nil) (deftest format.d.2 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for s1 = (format nil "~@d" i) for j = (read-from-string s1) repeat 1000 when (or (/= i j) (find #\. s1) ;; (find #\+ s1) (find-if #'alpha-char-p s1)) collect (list i s1 j))) nil) (deftest formatter.d.2 (let ((fn (formatter "~@D"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for s1 = (formatter-call-to-string fn i) for j = (read-from-string s1) repeat 1000 when (or (/= i j) (find #\. s1) ;; (find #\+ s1) (find-if #'alpha-char-p s1)) collect (list i s1 j)))) nil) (deftest format.d.3 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~d" i) for s2 = (format nil (format nil "~~~dd" mincol) i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (list i mincol s1 s2 pos))) nil) (deftest formatter.d.3 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~d" i) for format-string = (format nil "~~~dd" mincol) ; for s2 = (format nil format-string i) for fn = (eval `(formatter ,format-string)) for s2 = (formatter-call-to-string fn i) for pos = (search s1 s2) repeat 100 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (list i mincol s1 s2 pos))) nil) (deftest format.d.4 (with-standard-io-syntax (loop with limit = 10 with count = 0 for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~@D" i) for format-string = (format nil "~~~d@d" mincol) for s2 = (format nil format-string i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (and (>= i 0) (not (eql (elt s1 0) #\+))) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (if (> (incf count) limit) "Count limit exceeded" (list i mincol s1 format-string s2 pos)) while (<= count limit))) nil) (deftest formatter.d.4 (with-standard-io-syntax (loop with limit = 10 with count = 0 for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~@D" i) for format-string = (format nil "~~~d@d" mincol) for fn = (eval `(formatter ,format-string)) for s2 = (formatter-call-to-string fn i) for pos = (search s1 s2) repeat 100 when (or (null pos) (and (>= i 0) (not (eql (elt s1 0) #\+))) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (if (> (incf count) limit) "Count limit exceeded" (list i mincol s1 s2 pos)) while (<= count limit))) nil) (deftest format.d.5 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~d" i) for s2 = (format nil (format nil "~~~d,'~cd" mincol padchar) i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 pos))) nil) (deftest formatter.d.5 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~d" i) for format-string = (format nil "~~~d,'~cd" mincol padchar) for fn = (eval `(formatter ,format-string)) for s2 = (formatter-call-to-string fn i) for pos = (search s1 s2) repeat 100 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 pos))) nil) (deftest format.d.6 (let ((fn (formatter "~v,vd"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~d" i) for s2 = (format nil "~v,vD" mincol padchar i) for s3 = (formatter-call-to-string fn mincol padchar i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (not (string= s2 s3)) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 s3 pos)))) nil) (deftest format.d.7 (let ((fn (formatter "~v,v@D"))) (with-standard-io-syntax (loop with limit = 10 with count = 0 for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~@d" i) for s2 = (format nil "~v,v@d" mincol padchar i) for s3 = (formatter-call-to-string fn mincol padchar i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (not (string= s2 s3)) (and (>= i 0) (not (eql (elt s1 0) #\+))) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (if (> (incf count) limit) "Count limit exceeded" (list i mincol s1 s2 s3 pos)) while (<= count limit)))) nil) ;;; Comma tests (deftest format.d.8 (let ((fn1 (formatter "~d")) (fn2 (formatter "~:d"))) (loop for i from -999 to 999 for s1 = (format nil "~d" i) for s2 = (format nil "~:d" i) for s3 = (formatter-call-to-string fn1 i) for s4 = (formatter-call-to-string fn2 i) unless (and (string= s1 s2) (string= s1 s3) (string= s1 s4)) collect (list i s1 s2 s3 s4))) nil) (deftest format.d.9 (let ((fn1 (formatter "~d")) (fn2 (formatter "~:d"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = #\, for s1 = (format nil "~d" i) for s2 = (format nil "~:d" i) for s3 = (formatter-call-to-string fn1 i) for s4 = (formatter-call-to-string fn2 i) repeat 1000 unless (and (string= s1 s3) (string= s2 s4) (string= s1 (remove commachar s2)) (not (eql (elt s2 0) commachar)) (or (>= i 0) (not (eql (elt s2 1) commachar))) (let ((len (length s2)) (ci+1 4)) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (find (elt s2 i) "0123456789"))))) collect (list x i commachar s1 s2 s3 s4)))) nil) (deftest format.d.10 (let ((fn (formatter "~,,v:d"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for s1 = (format nil "~d" i) for s2 = (format nil "~,,v:d" commachar i) for s3 = (formatter-call-to-string fn commachar i) repeat 1000 unless (and (string= s2 s3) (eql (elt s1 0) (elt s2 0)) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 4) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2 s3)))) nil) (deftest format.d.11 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for s1 = (format nil "~d" i) for format-string = (format nil "~~,,'~c:d" commachar) for s2 = (format nil format-string i) repeat 1000 unless (and (eql (elt s1 0) (elt s2 0)) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 4) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2))) nil) (deftest formatter.d.11 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for s1 = (format nil "~d" i) for format-string = (format nil "~~,,'~c:d" commachar) for fn = (eval `(formatter ,format-string)) ; for s2 = (format nil format-string i) for s2 = (formatter-call-to-string fn i) repeat 100 unless (and (eql (elt s1 0) (elt s2 0)) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 4) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2))) nil) (deftest format.d.12 (let ((fn (formatter "~,,v,v:d"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for commaint = (1+ (random 20)) for s1 = (format nil "~d" i) for s2 = (format nil "~,,v,v:D" commachar commaint i) for s3 = (formatter-call-to-string fn commachar commaint i) repeat 1000 unless (and (string= s2 s3) (eql (elt s1 0) (elt s2 0)) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 (1+ commaint)) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2 s3)))) nil) (deftest format.d.13 (let ((fn (formatter "~,,v,v:@D"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for commaint = (1+ (random 20)) for s1 = (format nil "~@d" i) for s2 = (format nil "~,,v,v:@d" commachar commaint i) for s3 = (formatter-call-to-string fn commachar commaint i) repeat 1000 unless (and (eql (elt s1 0) (elt s2 0)) (eql (elt s1 1) (elt s2 1)) (let ((len (length s2)) (ci+1 (1+ commaint)) (j 1)) (loop for i from 2 below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2 s3)))) nil) ;;; NIL arguments (def-format-test format.d.14 "~vD" (nil 100) "100") (def-format-test format.d.15 "~6,vD" (nil 100) " 100") (def-format-test format.d.16 "~,,v:d" (nil 12345) "12,345") (def-format-test format.d.17 "~,,'*,v:d" (nil 12345) "12*345") ;;; When the argument is not an integer, print as if using ~A and base 10 (deftest format.d.18 (loop for x in *mini-universe* for s1 = (format nil "~d" x) for s2 = (format nil "~A" x) unless (or (integerp x) (string= s1 s2)) collect (list x s1 s2)) nil) (deftest format.d.19 (loop for x in *mini-universe* for s1 = (format nil "~:d" x) for s2 = (format nil "~A" x) unless (or (integerp x) (string= s1 s2)) collect (list x s1 s2)) nil) (deftest format.d.20 (loop for x in *mini-universe* for s1 = (format nil "~@d" x) for s2 = (format nil "~A" x) unless (or (integerp x) (string= s1 s2)) collect (list x s1 s2)) nil) (deftest format.d.21 (loop for x in *mini-universe* for s1 = (format nil "~A" x) for s2 = (format nil "~@:d" x) for s3 = (format nil "~A" x) unless (or (integerp x) (string= s1 s2) (not (string= s1 s3))) collect (list x s1 s2)) nil) ;;; Must add tests for non-integers when the parameters ;;; are specified, but it's not clear what the meaning is. ;;; Does mincol apply to the ~A equivalent? What about padchar? ;;; Are comma-char and comma-interval always ignored? ;;; # arguments (deftest format.d.22 (apply #'values (loop for i from 0 to 10 for args = (make-list i) for s = (apply #'format nil "~#d" 12345 args) collect s)) "12345" "12345" "12345" "12345" "12345" " 12345" " 12345" " 12345" " 12345" " 12345" " 12345") (deftest formatter.d.22 (apply #'values (let ((fn (formatter "~#D"))) (loop for i from 0 to 10 for args = (make-list i) ; for s = (apply #'format nil "~#d" 12345 args) for s = (with-output-to-string (stream) (assert (equal (apply fn stream 12345 args) args))) collect s))) "12345" "12345" "12345" "12345" "12345" " 12345" " 12345" " 12345" " 12345" " 12345" " 12345") (deftest format.d.23 (apply #'values (let ((fn (formatter "~,,,#:D"))) (loop for i from 0 to 10 for args = (make-list i) for s = (apply #'format nil "~,,,#:d" 1234567890 args) for s2 = (with-output-to-string (stream) (assert (equal (apply fn stream 1234567890 args) args))) do (assert (string= s s2)) collect s))) "1,2,3,4,5,6,7,8,9,0" "12,34,56,78,90" "1,234,567,890" "12,3456,7890" "12345,67890" "1234,567890" "123,4567890" "12,34567890" "1,234567890" "1234567890" "1234567890") (deftest format.d.24 (apply #'values (let ((fn (formatter "~,,,#:@d"))) (loop for i from 0 to 10 for args = (make-list i) for s = (apply #'format nil "~,,,#@:D" 1234567890 args) for s2 = (with-output-to-string (stream) (assert (equal (apply fn stream 1234567890 args) args))) do (assert (string= s s2)) collect s))) "+1,2,3,4,5,6,7,8,9,0" "+12,34,56,78,90" "+1,234,567,890" "+12,3456,7890" "+12345,67890" "+1234,567890" "+123,4567890" "+12,34567890" "+1,234567890" "+1234567890" "+1234567890") (def-format-test format.d.25 "~+10d" (1234) " 1234") (def-format-test format.d.26 "~+10@d" (1234) " +1234") (def-format-test format.d.27 "~-1d" (1234) "1234") (def-format-test format.d.28 "~-1000000000000000000d" (1234) "1234") (def-format-test format.d.29 "~vd" ((1- most-negative-fixnum) 1234) "1234") ;;; Randomized test (deftest format.d.30 (let ((fn (formatter "~v,v,v,vD"))) (loop for mincol = (and (coin) (random 50)) for padchar = (and (coin) (random-from-seq +standard-chars+)) for commachar = (and (coin) (random-from-seq +standard-chars+)) for commaint = (and (coin) (1+ (random 10))) for k = (ash 1 (+ 2 (random 30))) for x = (- (random (+ k k)) k) for fmt = (concatenate 'string (if mincol (format nil "~~~d," mincol) "~,") (if padchar (format nil "'~c," padchar) ",") (if commachar (format nil "'~c," commachar) ",") (if commaint (format nil "~dd" commaint) "d")) for s1 = (format nil fmt x) for s2 = (format nil "~v,v,v,vd" mincol padchar commachar commaint x) for s3 = (formatter-call-to-string fn mincol padchar commachar commaint x) repeat 2000 unless (and (string= s1 s2) (string= s2 s3)) collect (list mincol padchar commachar commaint fmt x s1 s2 s3))) nil) gcl27-2.7.0/ansi-tests/format-f.lsp000066400000000000000000000403171454061450500167740ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 1 07:14:17 2004 ;;;; Contains: Tests of the ~f format directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; Equivalent to PRIN1 for 0 or (abs x) in range [10^-3,10^7). (deftest format.f.1 (let ((*print-readably* nil) (fn (formatter "~F"))) (loop for type in '(short-float single-float double-float long-float short-float single-float double-float long-float) for x in '(0.0s0 0.0f0 0.0d0 0.0l0 -0.0s0 -0.0f0 -0.0d0 -0.0l0) for s1 = (let ((*read-default-float-format* type)) (format nil "~f" x)) for s2 = (let ((*read-default-float-format* type)) (prin1-to-string x)) for s3 = (let ((*read-default-float-format* type)) (formatter-call-to-string fn x)) unless (and (string= s1 s2) (string= s1 s3)) collect (list x type s1 s2 s3))) nil) (deftest format.f.2 (let ((*print-readably* nil) (fn (formatter "~f"))) (loop for i = (random 4) for type = (elt #(short-float single-float double-float long-float) i) for x = (expt (coerce 10 type) (- (random 10.0s0) 3)) for s1 = (let ((*read-default-float-format* type)) (format nil "~f" x)) for s2 = (let ((*read-default-float-format* type)) (prin1-to-string x)) for s3 = (let ((*read-default-float-format* type)) (formatter-call-to-string fn x)) repeat 1000 when (and (<= 1/1000 x) (< x 10000000) (or (not (string= s1 s2)) (not (string= s1 s3)))) collect (list x s1 s2 s3))) nil) (deftest format.f.3 (let ((*print-readably* nil) (fn (formatter "~F"))) (loop for i = (random 4) for type = (elt #(short-float single-float double-float long-float) i) for x = (- (expt (coerce 10 type) (- (random 10.0s0) 3))) for s1 = (let ((*read-default-float-format* type)) (format nil "~f" x)) for s2 = (let ((*read-default-float-format* type)) (prin1-to-string x)) for s3 = (let ((*read-default-float-format* type)) (formatter-call-to-string fn x)) repeat 1000 when (and (>= -1/1000 x) (> x -10000000) (not (and (string= s1 s2) (string= s1 s3)))) collect (list x s1 s2 s3))) nil) (deftest format.f.4 (let ((fn (formatter "~3f"))) (loop for x in (remove-duplicates '(1 1.0s0 1.0f0 1.0d0 1.0l0)) for s = (format nil "~3f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "1.0") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.5 (let ((fn (formatter "~2f"))) (loop for x in (remove-duplicates '(1 1.0s0 1.0f0 1.0d0 1.0l0)) for s = (format nil "~2f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "1.") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.6 (let ((fn (formatter "~4F"))) (loop for x in (remove-duplicates '(1 1.0s0 1.0f0 1.0d0 1.0l0)) for s = (format nil "~4F" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s " 1.0") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.7 (let ((fn (formatter "~4@F"))) (loop for x in (remove-duplicates '(1 1.0s0 1.0f0 1.0d0 1.0l0)) for s = (format nil "~4@f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "+1.0") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.8 (let ((fn (formatter "~3@F"))) (loop for x in (remove-duplicates '(1 1.0s0 1.0f0 1.0d0 1.0l0)) for s = (format nil "~3@F" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "+1.") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.9 (let ((fn (formatter "~4f"))) (loop for x in (remove-duplicates '(1 1.0s0 1.0f0 1.0d0 1.0l0)) for s = (format nil "~4f" (- x)) for s2 = (formatter-call-to-string fn (- x)) unless (and (string= s "-1.0") (string= s s2)) collect (list (- x) s s2))) nil) (deftest format.f.10 (let ((fn (formatter "~3F"))) (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) for s = (format nil "~3f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "0.5") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.11 (let ((fn (formatter "~4f"))) (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) for s = (format nil "~4f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s " 0.5") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.12 (let ((fn (formatter "~4,2F"))) (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) for s = (format nil "~4,2f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "0.50") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.13 (let ((fn (formatter "~3,2F"))) (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) for s = (format nil "~3,2f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s ".50") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.14 (let ((fn (formatter "~2,1F"))) (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) for s = (format nil "~2,1f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s ".5") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.15 (let ((fn (formatter "~4,2@F"))) (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) for s = (format nil "~4,2@f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "+.50") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.16 (let ((fn (formatter "~2,2F"))) (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) for s = (format nil "~2,2f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s ".50") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.17 (let ((fn (formatter "~,2F"))) (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) for s = (format nil "~,2f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "0.50") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.18 (let ((fn (formatter "~,2F"))) (loop for xn in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) for x = (- xn) for s = (format nil "~,2f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "-0.50") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.19 (let ((fn (formatter "~4,2,-1F"))) (loop for x in (remove-duplicates '(5 5.0s0 5.0f0 5.0d0 5.0l0)) for s = (format nil "~4,2,-1f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "0.50") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.20 (let ((fn (formatter "~4,2,0F"))) (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) for s = (format nil "~4,2,0f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "0.50") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.21 (let ((fn (formatter "~4,2,1f"))) (loop for x in (remove-duplicates '(1/20 0.05s0 0.05f0 0.05d0 0.05l0)) for s = (format nil "~4,2,1f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "0.50") (string= s s2)) collect (list x s s2))) nil) ;;; overflow (deftest format.f.22 (let ((fn (formatter "~5,1,,'*F"))) (loop for x in (remove-duplicates '(1000 1000.0s0 1000.0f0 1000.0d0 1000.0l0)) for s = (format nil "~5,1,,'*f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "*****") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.23 (let ((fn (formatter "~5,1,,'*f"))) (loop for x in (remove-duplicates '(100 100.0s0 100.0f0 100.0d0 100.0l0)) for s = (format nil "~5,1,,'*f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "100.0") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.24 (let ((fn (formatter "~4,0,,'*F"))) (loop for x in (remove-duplicates '(100 100.0s0 100.0f0 100.0d0 100.0l0)) for s = (format nil "~4,0,,'*f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "100.") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.25 (let ((fn (formatter "~1,1,,f"))) (loop for x in (remove-duplicates '(100 100.0s0 100.0f0 100.0d0 100.0l0)) for s = (format nil "~1,1,,f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "100.0") (string= s s2)) collect (list x s s2))) nil) ;;; padchar (deftest format.f.26 (let ((fn (formatter "~10,1,,f"))) (loop for x in (remove-duplicates '(100 100.0s0 100.0f0 100.0d0 100.0l0)) for s = (format nil "~10,1,,f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s " 100.0") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.27 (let ((fn (formatter "~10,1,,,'*F"))) (loop for x in (remove-duplicates '(100 100.0s0 100.0f0 100.0d0 100.0l0)) for s = (format nil "~10,1,,,'*f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "*****100.0") (string= s s2)) collect (list x s s2))) nil) ;;; v parameters (deftest format.f.28 (let ((fn (formatter "~VF"))) (loop for x = (random 100.0) for s1 = (format nil "~f" x) for s2 = (format nil "~vf" nil x) for s3 = (formatter-call-to-string fn nil x) repeat 100 unless (and (string= s1 s2) (string= s2 s3)) collect (list x s1 s2 s3))) nil) (deftest format.f.29 (let ((fn (formatter "~,vf"))) (loop for x = (random 100.0) for s1 = (format nil "~f" x) for s2 = (format nil "~,vf" nil x) for s3 = (formatter-call-to-string fn nil x) repeat 100 unless (and (string= s1 s2) (string= s2 s3)) collect (list x s1 s2 s3))) nil) (deftest format.f.30 (let ((fn (formatter "~,,Vf"))) (loop for x = (random 100.0) for s1 = (format nil "~f" x) for s2 = (format nil "~,,vf" nil x) for s3 = (formatter-call-to-string fn nil x) repeat 100 unless (and (string= s1 s2) (string= s2 s3)) collect (list x s1 s2 s3))) nil) (deftest format.f.31 (let ((fn (formatter "~,,,vF"))) (loop for x = (random 100.0) for s1 = (format nil "~f" x) for s2 = (format nil "~,,,vf" nil x) for s3 = (formatter-call-to-string fn nil x) repeat 100 unless (and (string= s1 s2) (string= s2 s3)) collect (list x s1 s2 s3))) nil) (deftest format.f.32 (let ((fn (formatter "~,,,,VF"))) (loop for x = (random 100.0) for s1 = (format nil "~f" x) for s2 = (format nil "~,,,,vf" nil x) for s3 = (formatter-call-to-string fn nil x) repeat 100 unless (and (string= s1 s2) (string= s2 s3)) collect (list x s1 s2 s3))) nil) ;;; Randomized tests #| (deftest format.f.33 (let ((bound (if (> 10000000 most-positive-short-float) most-positive-short-float (coerce 10000000 'short-float)))) (loop for d = (random 10) for w = (+ 1 d (random 10)) for x = (random bound) for xr = (rational x) for s = (format nil "~v,vf" w d x) for sr = (decode-fixed-decimal-string s) for eps = (expt 1/10 d) for abs-xr-sr = (abs (- xr sr)) for abs-xr-sr-hi = (abs (- xr (+ sr eps))) for abs-xr-sr-lo = (abs (- xr (- sr eps))) repeat 100 unless (and (<= abs-xr-sr abs-xr-sr-hi) (<= abs-xr-sr abs-xr-sr-lo)) collect (list d w x xr s sr eps abs-xr-sr abs-xr-sr-hi abs-xr-sr-lo))) nil) |# (deftest format.f.34 (with-standard-io-syntax (let ((*read-default-float-format* 'short-float)) (loop for i from (- 1 (ash 1 13)) below (ash 1 13) for sf = (coerce i 'short-float) for s = (format nil "~f" sf) for i2 = (floor (read-from-string s)) unless (or (zerop i) (eql i i2)) collect (list i sf s i2)))) nil) (deftest format.f.35 (with-standard-io-syntax (let ((*read-default-float-format* 'single-float)) (loop for i = (- (random (1- (ash 1 25))) -1 (ash 1 24)) for sf = (coerce i 'single-float) for s = (format nil "~f" sf) for i2 = (floor (read-from-string s)) repeat 2000 unless (or (zerop i) (eql i i2)) collect (list i sf s i2)))) nil) (deftest format.f.36 (with-standard-io-syntax (let ((*read-default-float-format* 'double-float)) (loop for i = (- (random (1- (ash 1 51))) -1 (ash 1 50)) for sf = (coerce i 'double-float) for s = (format nil "~f" sf) for i2 = (floor (read-from-string s)) repeat 2000 unless (or (zerop i) (eql i i2)) collect (list i sf s i2)))) nil) (deftest format.f.37 (with-standard-io-syntax (let ((*read-default-float-format* 'long-float)) (loop for i = (- (random (1- (ash 1 51))) -1 (ash 1 50)) for sf = (coerce i 'long-float) for s = (format nil "~f" sf) for i2 = (floor (read-from-string s)) repeat 2000 unless (or (zerop i) (eql i i2)) collect (list i sf s i2)))) nil) (deftest format.f.38 (funcall (compile nil '(lambda () (with-standard-io-syntax (let ((*read-default-float-format* 'short-float) (total 0) (len 0)) (loop for i from (- 1 (ash 1 13)) below (ash 1 13) unless (zerop i) nconc (loop for sf = (coerce i 'short-float) for w = (random 8) for d = (random 4) for s = (format nil "~v,vf" w d sf) for i2 = (ignore-errors (floor (read-from-string s))) repeat 5 ; do (print (list w d s i i2)) unless (eql i i2) do (incf total) and collect (list i sf w d s i2)) when (> total 100) collect "count limit exceeded" and do (loop-finish))))))) nil) (deftest format.f.39 (with-standard-io-syntax (let ((*read-default-float-format* 'single-float)) (loop for i = (- (random (1- (ash 1 25))) -1 (ash 1 24)) for sf = (coerce i 'single-float) for w = (and (coin) (random 16)) for d = (random 4) for s = (format nil "~v,vf" w d sf) for i2 = (floor (read-from-string s)) repeat 2000 unless (or (zerop i) (eql i i2)) collect (list i sf w d s i2)))) nil) (deftest format.f.40 (with-standard-io-syntax (let ((*read-default-float-format* 'double-float)) (loop for i = (- (random (1- (ash 1 51))) -1 (ash 1 50)) for sf = (coerce i 'double-float) for w = (and (coin) (random 30)) for d = (random 6) for s = (format nil "~v,vf" w d sf) for i2 = (floor (read-from-string s)) repeat 2000 unless (or (zerop i) (eql i i2)) collect (list i sf w d s i2)))) nil) (deftest format.f.41 (with-standard-io-syntax (let ((*read-default-float-format* 'long-float)) (loop for i = (- (random (1- (ash 1 51))) -1 (ash 1 50)) for sf = (coerce i 'long-float) for w = (and (coin) (random 30)) for d = (random 6) for s = (format nil "~v,vf" w d sf) for i2 = (floor (read-from-string s)) repeat 2000 unless (or (zerop i) (eql i i2)) collect (list i sf w d s i2)))) nil) (deftest format.f.42 (let ((chars +standard-chars+)) (loop for k = (and (coin) (random 6)) for x = (random (/ (random-from-seq #(#.(coerce (* 32 (1- (ash 1 13))) 'short-float) #.(coerce (* 256 (1- (ash 1 24))) 'single-float) #.(coerce (* 256 (1- (ash 1 50))) 'double-float) #.(coerce (* 256 (1- (ash 1 50))) 'long-float))) (if k (expt 10 k) 1))) for w = (and (coin) (random 30)) for d = (and (coin) (random 10)) for overflowchar = (and (coin) (random-from-seq chars)) for padchar = (and (coin) (random-from-seq chars)) for f1 = (concatenate 'string "~" (if w (format nil "~d" w) "") "," (if d (format nil "~d" d) "") "," (if k (format nil "~d" k) "") "," (if overflowchar (format nil "'~c" overflowchar) "") "," (if padchar (format nil "'~c" padchar) "") (string (random-from-seq "fF"))) for s1 = (format nil f1 x) for s2 = (format nil "~v,v,v,v,vf" w d k overflowchar padchar x) repeat 2000 unless (string= s1 s2) collect (list x w d k overflowchar padchar f1 s1 s2))) nil) ;;; This failed in sbcl 0.8.12.25 (def-format-test format.f.43 "~,,,,',f" (0.0) "0.0") (deftest format.f.44 (loop for i from 0 below (min #x10000 char-code-limit) for x = 2312.9817 for c = (code-char i) for f1 = (and c (format nil "~~,,,,'~cf" c)) for s1 = (and c (ignore-errors (format nil f1 x))) for s2 = (and c (format nil "~,,,,vf" c x)) unless (equal s1 s2) collect (list i c f1 s1 s2)) nil) gcl27-2.7.0/ansi-tests/format-goto.lsp000066400000000000000000000050561454061450500175200ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Aug 24 06:56:13 2004 ;;;; Contains: Tests of the ~* format directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; ~* (def-format-test format.*.1 "~A~*~A" (1 2 3) "13") (def-format-test format.*.2 "~A~0*~A" (1 2 3) "12" 1) (def-format-test format.*.3 "~A~v*~A" (1 0 2) "12") (def-format-test format.*.4 "~A~v*~A" (1 1 2 3) "13") (def-format-test format.*.5 "~A~v*~A" (1 nil 2 3) "13") (def-format-test format.*.6 "~A~1{~A~*~A~}~A" (0 '(1 2 3) 4) "0134") (def-format-test format.*.7 "~A~1{~A~0*~A~}~A" (0 '(1 2 3) 4) "0124") (def-format-test format.*.8 "~A~{~A~*~A~}~A" (0 '(1 2 3 4 5 6) 7) "013467") (def-format-test format.*.9 "~A~{~A~A~A~A~v*~^~A~A~A~A~}~A" (0 '(1 2 3 4 nil 6 7 8 9 #\A) 5) "01234789A5") ;;; ~:* (def-format-test format.\:*.1 "~A~:*~A" (1 2 3) "11" 2) (def-format-test format.\:*.2 "~A~A~:*~A" (1 2 3) "122" 1) (def-format-test format.\:*.3 "~A~A~0:*~A" (1 2 3) "123") (def-format-test format.\:*.4 "~A~A~2:*~A" (1 2 3) "121" 2) (def-format-test format.\:*.5 "~A~A~v:*~A" (1 2 0 3) "123") (def-format-test format.\:*.6 "~A~A~v:*~A" (6 7 2 3) "677" 2) (def-format-test format.\:*.7 "~A~A~v:*~A" (6 7 nil 3) "67NIL" 1) (def-format-test format.\:*.8 "~A~1{~A~:*~A~}~A" (0 '(1 2 3) 4) "0114") (def-format-test format.\:*.9 "~A~1{~A~A~A~:*~A~}~A" (0 '(1 2 3 4) 5) "012335") (def-format-test format.\:*.10 "~A~1{~A~A~A~2:*~A~A~}~A" (0 '(1 2 3 4) 5) "0123235") (def-format-test format.\:*.11 "~A~{~A~A~A~3:*~A~A~A~A~}~A" (0 '(1 2 3 4) 5) "012312345") (def-format-test format.\:*.12 "~A~{~A~A~A~A~4:*~^~A~A~A~A~}~A" (0 '(1 2 3 4) 5) "0123412345") (def-format-test format.\:*.13 "~A~{~A~A~A~A~v:*~^~A~}~A" (0 '(1 2 3 4 nil) 5) "01234NIL5") ;;; ~@* (def-format-test format.@*.1 "~A~A~@*~A~A" (1 2 3 4) "1212" 2) (def-format-test format.@*.2 "~A~A~1@*~A~A" (1 2 3 4) "1223" 1) (def-format-test format.@*.3 "~A~A~2@*~A~A" (1 2 3 4) "1234") (def-format-test format.@*.4 "~A~A~3@*~A~A" (1 2 3 4 5) "1245") (def-format-test format.@*.5 "~A~A~v@*~A~A" (1 2 nil 3 4) "1212" 3) (def-format-test format.@*.6 "~A~A~v@*~A~A" (1 2 1 3 4) "1221" 2) (def-format-test format.@*.7 "~A~A~v@*~A~A" (6 7 2 3 4) "6723" 1) (def-format-test format.@*.8 "~A~{~A~A~@*~A~A~}~A" (0 '(1 2) 9) "012129") (def-format-test format.@*.9 "~A~{~A~A~0@*~A~A~}~A" (0 '(1 2) 9) "012129") (def-format-test format.@*.10 "~A~1{~A~A~v@*~A~A~}~A" (0 '(1 2 nil) 9) "012129") (def-format-test format.@*.11 "~A~{~A~A~1@*~A~}~A" (0 '(1 2) 9) "01229") gcl27-2.7.0/ansi-tests/format-i.lsp000066400000000000000000000033061454061450500167740ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 21 07:01:36 2004 ;;;; Contains: Tests for the ~I format directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; pprint-indent.9 (def-pprint-test format.i.1 (format nil "~" '(M M)) "M M") ;;; See pprint-indent.10 (def-pprint-test format.i.2 (format nil "~:" '(M M)) "(M M)") ;;; See pprint-indent.11 (def-pprint-test format.i.3 (format nil "~<(~;M~-1:i~:@_M~;)~:>" '(M M)) "(M M)") (def-pprint-test format.i.4 (format nil "~:" '(M M)) "(M M)") (def-pprint-test format.i.5 (format nil "~<(~;M~:I~:@_M~;)~:>" '(M M)) "(M M)") (def-pprint-test format.i.6 (format nil "~<(~;M~v:i~:@_M~;)~:>" '(nil)) "(M M)") (def-pprint-test format.i.7 (format nil "~:" '(M M)) "(M M)") (def-pprint-test format.i.8 (format nil "~" '(M M)) "M M") ;;; See pprint-indent.13 (def-pprint-test format.i.9 (format nil "~" '(M M)) "MMM MMMMM") (def-pprint-test format.i.10 (format nil "~:" '(M M)) "(MMM MMMMM)") (def-pprint-test format.i.11 (format nil "~" '(M M)) "MMM MMMMM") (def-pprint-test format.i.12 (format nil "XXX~" '(M M)) "XXXMMM MMMMM") (def-pprint-test format.i.13 (format nil "XXX~" '(M M)) "XXXMMM MMMMM") (def-pprint-test format.i.14 (format nil "XXX~" '(M M)) "XXXMMM MMMMM") (def-pprint-test format.i.15 (format nil "XXX~" '(nil)) "XXXMMM MMMMM") (def-pprint-test format.i.16 (format nil "XXX~" '(2)) "XXXMMM MMMMM") gcl27-2.7.0/ansi-tests/format-justify.lsp000066400000000000000000000153311454061450500202420ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 22 18:09:49 2004 ;;;; Contains: Tests of the ~< ~> directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-pprint-test format.justify.1 (format nil "~<~>") "") (def-pprint-test format.justify.2 (loop for i from 1 to 20 for s1 = (make-string i :initial-element #\x) for s2 = (format nil "~<~A~>" s1) unless (string= s1 s2) collect (list i s1 s2)) nil) (def-pprint-test format.justify.3 (loop for i from 1 to 20 for s1 = (make-string i :initial-element #\x) for s2 = (format nil "~<~A~;~A~>" s1 s1) unless (string= s2 (concatenate 'string s1 s1)) collect (list i s1 s2)) nil) (def-pprint-test format.justify.4 (loop for i from 1 to 20 for s1 = (make-string i :initial-element #\x) for expected = (concatenate 'string s1 " " s1) for s2 = (format nil "~,,1<~A~;~A~>" s1 s1) unless (string= s2 expected) collect (list i expected s2)) nil) (def-pprint-test format.justify.5 (loop for i from 1 to 20 for s1 = (make-string i :initial-element #\x) for expected = (concatenate 'string s1 "," s1) for s2 = (format nil "~,,1,',<~A~;~A~>" s1 s1) unless (string= s2 expected) collect (list i expected s2)) nil) (def-pprint-test format.justify.6 (loop for i from 1 to 20 for s1 = (make-string i :initial-element #\x) for expected = (concatenate 'string s1 " " s1) for s2 = (format nil "~,,2<~A~;~A~>" s1 s1) unless (string= s2 expected) collect (list i expected s2)) nil) (def-pprint-test format.justify.7 (loop for mincol = (random 50) for len = (random 50) for s1 = (make-string len :initial-element #\x) for s2 = (format nil "~v<~A~>" mincol s1) for expected = (if (< len mincol) (concatenate 'string (make-string (- mincol len) :initial-element #\Space) s1) s1) repeat 100 unless (string= s2 expected) collect (list mincol len s1 s2 expected)) nil) (def-pprint-test format.justify.8 (loop for mincol = (random 50) for minpad = (random 10) for len = (random 50) for s1 = (make-string len :initial-element #\x) for s2 = (format nil "~v,,v<~A~>" mincol minpad s1) for expected = (if (< len mincol) (concatenate 'string (make-string (- mincol len) :initial-element #\Space) s1) s1) repeat 100 unless (string= s2 expected) collect (list mincol minpad len s1 s2 expected)) nil) (def-pprint-test format.justify.9 (loop for mincol = (random 50) for padchar = (random-from-seq +standard-chars+) for len = (random 50) for s1 = (make-string len :initial-element #\x) for s2 = (format nil "~v,,,v<~A~>" mincol padchar s1) for expected = (if (< len mincol) (concatenate 'string (make-string (- mincol len) :initial-element padchar) s1) s1) repeat 100 unless (string= s2 expected) collect (list mincol padchar len s1 s2 expected)) nil) (def-pprint-test format.justify.10 (loop for mincol = (random 50) for padchar = (random-from-seq +standard-chars+) for len = (random 50) for s1 = (make-string len :initial-element #\x) for s2 = (format nil (format nil "~~~d,,,'~c<~~A~~>" mincol padchar) s1) for expected = (if (< len mincol) (concatenate 'string (make-string (- mincol len) :initial-element padchar) s1) s1) repeat 500 unless (string= s2 expected) collect (list mincol padchar len s1 s2 expected)) nil) (def-pprint-test format.justify.11 (loop for i = (1+ (random 20)) for colinc = (1+ (random 10)) for s1 = (make-string i :initial-element #\x) for s2 = (format nil "~,v<~A~>" colinc s1) for expected-len = (* colinc (ceiling i colinc)) for expected = (concatenate 'string (make-string (- expected-len i) :initial-element #\Space) s1) repeat 10 unless (string= expected s2) collect (list i colinc expected s2)) nil) (def-pprint-test format.justify.12 (format nil "~") "") (def-pprint-test format.justify.13 (format nil "~") "XXXXXX") (def-pprint-test format.justify.13a (format nil "~<~~>") "XXXXXX") (def-pprint-test format.justify.14 (format nil "~") "XXXXXX") (def-pprint-test format.justify.15 (format nil "~13,,2") "aaa bbb ccc") (def-pprint-test format.justify.16 (format nil "~10@") "abcdef ") (def-pprint-test format.justify.17 (format nil "~10:@") " abcdef ") (def-pprint-test format.justify.18 (format nil "~10:") " abcdef") (def-pprint-test format.justify.19 (format nil "~4@<~>") " ") (def-pprint-test format.justify.20 (format nil "~5:@<~>") " ") (def-pprint-test format.justify.21 (format nil "~6:<~>") " ") (def-pprint-test format.justify.22 (format nil "~v<~A~>" nil "XYZ") "XYZ") (def-pprint-test format.justify.23 (format nil "~,v<~A~;~A~>" nil "ABC" "DEF") "ABCDEF") (def-pprint-test format.justify.24 (format nil "~,,v<~A~;~A~>" nil "ABC" "DEF") "ABCDEF") (def-pprint-test format.justify.25 (format nil "~,,1,v<~A~;~A~>" nil "ABC" "DEF") "ABC DEF") (def-pprint-test format.justify.26 (format nil "~,,1,v<~A~;~A~>" #\, "ABC" "DEF") "ABC,DEF") (def-pprint-test format.justify.27 (format nil "~6") " abc") (def-pprint-test format.justify.28 (format nil "~6@") "abc ") ;;; ~:; tests (def-pprint-test format.justify.29 (format nil "~%X ~,,1<~%X ~:;AAA~;BBB~;CCC~>") " X AAA BBB CCC") (def-pprint-test format.justify.30 (format nil "~%X ~<~%X ~0,3:;AAA~>~<~%X ~0,3:;BBB~>~<~%X ~0,3:;CCC~>") " X X AAA X BBB X CCC") (def-pprint-test format.justify.31 (format nil "~%X ~<~%X ~0,30:;AAA~>~<~%X ~0,30:;BBB~>~<~%X ~0,30:;CCC~>") " X AAABBBCCC") (def-pprint-test format.justify.32 (format nil "~%X ~<~%X ~0,3:;AAA~>,~<~%X ~0,3:;BBB~>,~<~%X ~0,3:;CCC~>") " X X AAA, X BBB, X CCC") ;;; Error cases ;;; See 22.3.5.2 ;;; Interaction with ~W (deftest format.justify.error.w.1 (signals-error-always (format nil "~< ~W ~>" nil) error) t t) (deftest format.justify.error.w.2 (signals-error-always (format nil "~~W" nil) error) t t) (deftest format.justify.error.w.3 (signals-error-always (format nil "~w~" nil) error) t t) ;;; Interaction with ~_ (deftest format.justify.error._.1 (signals-error-always (format nil "~< ~_ ~>") error) t t) (deftest format.justify.error._.2 (signals-error-always (format nil "~~_") error) t t) (deftest format.justify.error._.3 (signals-error-always (format nil "~_~") error) t t) ;;; Interaction with ~I (deftest format.justify.error.i.1 (signals-error-always (format nil "~< ~i ~>") error) t t) (deftest format.justify.error.i.2 (signals-error-always (format nil "~~I") error) t t) (deftest format.justify.error.i.3 (signals-error-always (format nil "~i~") error) t t) gcl27-2.7.0/ansi-tests/format-logical-block.lsp000066400000000000000000000167461454061450500212620ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 8 12:17:31 2004 ;;;; Contains: Tests of the ~< ~:> format directives (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; Error cases ;;; Prefix and suffix cannot contain format directives (deftest format.logical-block.error.1 (signals-error-always (format nil "~" '(X) '(Y)) error) t t) (deftest format.logical-block.error.2 (signals-error-always (format nil "~" '(X) '(Y)) error) t t) (deftest format.logical-block.error.3 (signals-error-always (format nil "~" '(X) '(Y)) error) t t) (deftest format.logical-block.error.4 (signals-error-always (format nil "~" '(X) '(Y)) error) t t) (deftest format.logical-block.error.5 (signals-error-always (format nil "~" '(X) '(Y)) error) t t) (deftest format.logical-block.error.6 (signals-error-always (format nil "~" '(X) '(Y)) error) t t) (deftest format.logical-block.error.7 (signals-error-always (format nil "~<~;~A~;bar~A~:>" '(X) '(Y)) error) t t) (deftest format.logical-block.error.8 (signals-error-always (format nil "~<~@;~A~;bar~A~:>" '(X) '(Y)) error) t t) (deftest format.logical-block.error.9 (signals-error-always (format nil "~:" '(X) '(Y)) error) t t) (deftest format.logical-block.error.10 (signals-error-always (format nil "~:" '(X) '(Y)) error) t t) (deftest format.logical-block.error.11 (signals-error-always (format nil "~:" '(X) '(Y)) error) t t) (deftest format.logical-block.error.12 (signals-error-always (format nil "~:" '(X) '(Y)) error) t t) (deftest format.logical-block.error.13 (signals-error-always (format nil "~:" '(X) '(Y)) error) t t) (deftest format.logical-block.error.14 (signals-error-always (format nil "~:" '(X) '(Y)) error) t t) (deftest format.logical-block.error.15 (signals-error-always (format nil "~:<~;~A~;bar~A~:>" '(X) '(Y)) error) t t) (deftest format.logical-block.error.16 (signals-error-always (format nil "~:<~@;~A~;bar~A~:>" '(X) '(Y)) error) t t) (deftest format.logical-block.error.17 (signals-error-always (format nil "~@" '(X) '(Y)) error) t t) (deftest format.logical-block.error.18 (signals-error-always (format nil "~@" '(X) '(Y)) error) t t) (deftest format.logical-block.error.19 (signals-error-always (format nil "~@" '(X) '(Y)) error) t t) (deftest format.logical-block.error.20 (signals-error-always (format nil "~@" '(X) '(Y)) error) t t) (deftest format.logical-block.error.21 (signals-error-always (format nil "~@" '(X) '(Y)) error) t t) (deftest format.logical-block.error.22 (signals-error-always (format nil "~@" '(X) '(Y)) error) t t) (deftest format.logical-block.error.23 (signals-error-always (format nil "~@<~;~A~;bar~A~:>" '(X) '(Y)) error) t t) (deftest format.logical-block.error.24 (signals-error-always (format nil "~@<~@;~A~;bar~A~:>" '(X) '(Y)) error) t t) (deftest format.logical-block.error.25 (signals-error-always (format nil "1~Z~>2" nil nil nil) error) t t) ;;; "an error is also signaled if the ~<...~:;...~> form of ~<...~> is used ;;; in the same format string with ~W, ~_, ~<...~:>, ~I, or ~:T." (deftest format.logical-block.error.26 (signals-error-always (format nil "~<~:;~>~<~:>" nil nil nil) error) t t) (deftest format.logical-block.error.27 (signals-error-always (format nil "~<~:>~<~:;~>" nil nil nil) error) t t) ;;; Non-error tests (def-pprint-test format.logical-block.1 (format nil "~<~A~:>" '(nil)) "NIL") (def-pprint-test format.logical-block.2 (format nil "~@<~A~:>" nil) "NIL") (def-pprint-test format.logical-block.3 (format nil "~:<~A~:>" '(nil)) "(NIL)") (def-pprint-test format.logical-block.4 (format nil "~:@<~A~:>" nil) "(NIL)") (def-pprint-test format.logical-block.5 (format nil "~@:<~A~:>" nil) "(NIL)") (def-pprint-test format.logical-block.6 (format nil "~<~@{~A~^*~}~:>" '(1 2 3)) "1*2*3") (def-pprint-test format.logical-block.7 (format nil "~:<~@{~A~^*~}~:>" '(1 2 3)) "(1*2*3)") (def-pprint-test format.logical-block.8 (format nil "~:<~@{~A~^*~}~:>" 1) "1") (def-pprint-test format.logical-block.9 (format nil "~<~;~A~;~:>" '(1 2 3)) "1") (def-pprint-test format.logical-block.10 (format nil "~<~;~A~:>" '(1 2 3)) "1") (def-pprint-test format.logical-block.11 (format nil "~@<~;~A~;~:>" '(1 2 3)) "(1 2 3)") (def-pprint-test format.logical-block.12 (format nil "~@<~;~A~:>" '(1 2 3)) "(1 2 3)") (def-pprint-test format.logical-block.13 (format nil "~:<[~;~@{~A~^/~}~:>" '(1 2 3)) "[1/2/3)") (def-pprint-test format.logical-block.14 (format nil "~:<~;~@{~A~^/~}~;]~:>" '(1 2 3)) "1/2/3]") (def-pprint-test format.logical-block.15 (format nil "~:<[~;~@{~A~^/~}~;]~:>" '(1 2 3)) "[1/2/3]") (def-pprint-test format.logical-block.16 (format nil "~@<~@{~A~^*~}~:>" 1 2 3) "1*2*3") (def-pprint-test format.logical-block.17 (format nil "~@<~@{~A~^ ~_~}~:>" 1 2 3) "1 2 3") (def-pprint-test format.logical-block.18 (format nil "~@<~@{~A~^ ~_~}~:>" 1 2 3) "1 2 3" :margin 2) (def-pprint-test format.logical-block.19 (format nil "~:@<~@{~A~^ ~_~}~:>" 1 2 3) "(1 2 3)" :margin 2) (def-pprint-test format.logical-block.20 (format nil "~@:<~@{~A~^ ~}~:>" 1 2 3) "(1 2 3)" :margin 2) (def-pprint-test format.logical-block.21 (format nil "~@:<~@{~A~^ ~:_~}~:>" 1 2 3) "(1 2 3)" :margin 2) (def-pprint-test format.logical-block.22 (format nil "~:@<~@{~A~^ ~}~:@>" 1 2 3) "(1 2 3)" :margin 2) (def-pprint-test format.logical-block.23 (format nil "~:@<~@{~A~^/~ ~}~:@>" 1 2 3) "(1/2/3)" :margin 2) (def-pprint-test format.logical-block.24 (format nil "~:@<~@{~A~^ ~:_~}~:>" 1 2 3) "(1 2 3)" :margin 2) (def-pprint-test format.logical-block.25 (format nil "~:@<~@{~A~^ ~}~:@>" 1 2 3) "(1 2 3)" :margin 2) (def-pprint-test format.logical-block.26 (format nil "~:@<~@{~A~^~}~:@>" "1 2 3") "(1 2 3)" :margin 2) (def-pprint-test format.logical-block.27 (format nil "~@<**~@;~@{~A~^ ~}~:@>" 1 2 3) "**1 **2 **3" :margin 3) (def-pprint-test format.logical-block.28 (format nil "~@<**~@;~@{~A~^ ~}~;XX~:@>" 1 2 3) "**1 **2 **3XX" :margin 3) (def-pprint-test format.logical-block.29 (format nil "~:@<**~@;~@{~A~^ ~}~:@>" 1 2 3) "**1 **2 **3)" :margin 3) ;;; Circularity detection (def-pprint-test format.logical-block.circle.1 (format nil "~:<~@{~A~^ ~}~:>" (let ((x (list 0))) (list x x))) "(#1=(0) #1#)" :circle t) (def-pprint-test format.logical-block.circle.2 (format nil "~:<~@{~A~^ ~}~:>" (let ((x (list 0))) (cons x x))) "(#1=(0) . #1#)" :circle t) (def-pprint-test format.logical-block.circle.3 (format nil "~:<~@{~A~^ ~}~:>" (let ((x (list 0))) (setf (cdr x) x) x)) "#1=(0 . #1#)" :circle t :len 500) (def-pprint-test format.logical-block.circle.4 (format nil "~:<~@{~A~^ ~}~:>" (let ((x (list 0))) (list x x))) "((0) (0))") (def-pprint-test format.logical-block.circle.5 (format nil "~:<~@{~A~^ ~}~:>" (let ((x (list 0))) (cons x x))) "((0) 0)") ;;; ~^ terminates a logical block (def-pprint-test format.logical-block.escape.1 (format nil "~<~A~^xxxx~:>" '(1)) "1") (def-pprint-test format.logical-block.escape.2 (format nil "~<~<~A~^xxx~:>yyy~:>" '((1))) "1yyy") gcl27-2.7.0/ansi-tests/format-newline.lsp000066400000000000000000000010271454061450500202030ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Nov 27 08:07:16 2004 ;;;; Contains: Tests of ~ (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-format-test format.newline.1 (concatenate 'string "~" (string #\Newline) " X") nil "X") (def-format-test format.newline.2 (concatenate 'string "A~:" (string #\Newline) " X") nil "A X") (def-format-test format.newline.3 (concatenate 'string "A~@" (string #\Newline) " X") nil #.(concatenate 'string "A" (string #\Newline) "X")) gcl27-2.7.0/ansi-tests/format-o.lsp000066400000000000000000000372161454061450500170110ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 1 06:36:30 2004 ;;;; Contains: Tests of format directive ~O (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest format.o.1 (let ((fn (formatter "~o"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for s1 = (format nil "~O" i) for j = (let ((*read-base* 8)) (read-from-string s1)) for s2 = (formatter-call-to-string fn i) repeat 1000 when (or (/= i j) (not (string= s1 s2)) (find #\. s1) (find #\+ s1) (find-if #'alpha-char-p s1)) collect (list i s1 j s2)))) nil) (deftest format.o.2 (let ((fn (formatter "~@O"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for s1 = (format nil "~@o" i) for j = (let ((*read-base* 8)) (read-from-string s1)) for s2 = (formatter-call-to-string fn i) repeat 1000 when (or (/= i j) (not (string= s1 s2)) (find #\. s1) ;; (find #\+ s1) (find-if #'alpha-char-p s1)) collect (list i s1 j s2)))) nil) (deftest format.o.3 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~o" i) for fmt = (format nil "~~~do" mincol) for s2 = (format nil fmt i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (list i mincol s1 s2 pos))) nil) (deftest formatter.o.3 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~o" i) for fmt = (format nil "~~~do" mincol) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn i) for pos = (search s1 s2) repeat 100 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (list i mincol s1 s2 pos))) nil) (deftest format.o.4 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~@O" i) for fmt = (format nil "~~~d@o" mincol) for s2 = (format nil fmt i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (and (>= i 0) (not (eql (elt s1 0) #\+))) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (list i mincol s1 s2 pos))) nil) (deftest formatter.o.4 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~@O" i) for fmt = (format nil "~~~d@o" mincol) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn i) for pos = (search s1 s2) repeat 100 when (or (null pos) (and (>= i 0) (not (eql (elt s1 0) #\+))) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (list i mincol s1 s2 pos))) nil) (deftest format.o.5 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~o" i) for fmt = (format nil "~~~d,'~c~c" mincol padchar (random-from-seq "oO")) for s2 = (format nil fmt i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 pos))) nil) (deftest formatter.o.5 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~o" i) for fmt = (format nil "~~~d,'~c~c" mincol padchar (random-from-seq "oO")) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn i) for pos = (search s1 s2) repeat 100 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 pos))) nil) (deftest format.o.6 (let ((fn (formatter "~V,Vo"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~o" i) for s2 = (format nil "~v,vO" mincol padchar i) for s3 = (formatter-call-to-string fn mincol padchar i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (not (string= s2 s3)) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 s3 pos)))) nil) (deftest format.o.7 (let ((fn (formatter "~v,V@O"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~@o" i) for s2 = (format nil "~v,v@o" mincol padchar i) for s3 = (formatter-call-to-string fn mincol padchar i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (not (string= s2 s3)) (and (>= i 0) (not (eql (elt s1 0) #\+))) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 s3 pos)))) nil) ;;; Comma tests (deftest format.o.8 (let ((fn (formatter "~:O"))) (loop for i from #o-777 to #o777 for s1 = (format nil "~o" i) for s2 = (format nil "~:o" i) for s3 = (formatter-call-to-string fn i) unless (and (string= s1 s2) (string= s2 s3)) collect (list i s1 s2 s3))) nil) (deftest format.o.9 (let ((fn (formatter "~:o"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = #\, for s1 = (format nil "~o" i) for s2 = (format nil "~:O" i) for s3 = (formatter-call-to-string fn i) repeat 1000 unless (and (string= s1 (remove commachar s2)) (string= s2 s3) (not (eql (elt s2 0) commachar)) (or (>= i 0) (not (eql (elt s2 1) commachar))) (let ((len (length s2)) (ci+1 4)) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (find (elt s2 i) "01234567"))))) collect (list x i commachar s1 s2 s3)))) nil) (deftest format.o.10 (let ((fn (formatter "~,,v:o"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for s1 = (format nil "~o" i) for s2 = (format nil "~,,v:o" commachar i) for s3 = (formatter-call-to-string fn commachar i) repeat 1000 unless (and (eql (elt s1 0) (elt s2 0)) (string= s2 s3) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 4) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2 s3)))) nil) (deftest format.o.11 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for s1 = (format nil "~o" i) for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "oO")) for s2 = (format nil fmt i) repeat 1000 unless (and (eql (elt s1 0) (elt s2 0)) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 4) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2))) nil) (deftest formatter.o.11 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for s1 = (format nil "~o" i) for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "oO")) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn i) repeat 100 unless (and (eql (elt s1 0) (elt s2 0)) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 4) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2))) nil) (deftest format.o.12 (let ((fn (formatter "~,,V,v:O"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for commaint = (1+ (random 20)) for s1 = (format nil "~o" i) for s2 = (format nil "~,,v,v:O" commachar commaint i) for s3 = (formatter-call-to-string fn commachar commaint i) repeat 1000 unless (and (eql (elt s1 0) (elt s2 0)) (string= s2 s3) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 (1+ commaint)) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2 s3)))) nil) (deftest format.o.13 (let ((fn (formatter "~,,v,V@:O"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for commaint = (1+ (random 20)) for s1 = (format nil "~@o" i) for s2 = (format nil "~,,v,v:@o" commachar commaint i) for s3 = (formatter-call-to-string fn commachar commaint i) repeat 1000 unless (and (string= s2 s3) (eql (elt s1 0) (elt s2 0)) (eql (elt s1 1) (elt s2 1)) (let ((len (length s2)) (ci+1 (1+ commaint)) (j 1)) (loop for i from 2 below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2 s3)))) nil) ;;; NIL arguments (def-format-test format.o.14 "~vO" (nil #o100) "100") (def-format-test format.o.15 "~6,vO" (nil #o100) " 100") (def-format-test format.o.16 "~,,v:o" (nil #o12345) "12,345") (def-format-test format.o.17 "~,,'*,v:o" (nil #o12345) "12*345") ;;; When the argument is not an integer, print as if using ~A and base 10 (deftest format.o.18 (let ((fn (formatter "~o"))) (loop for x in *mini-universe* for s1 = (format nil "~o" x) for s2 = (let ((*print-base* 8)) (format nil "~A" x)) for s3 = (formatter-call-to-string fn x) unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) collect (list x s1 s2 s3))) nil) (deftest format.o.19 (let ((fn (formatter "~:o"))) (loop for x in *mini-universe* for s1 = (format nil "~:o" x) for s2 = (let ((*print-base* 8)) (format nil "~A" x)) for s3 = (formatter-call-to-string fn x) unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) collect (list x s1 s2 s3))) nil) (deftest format.o.20 (let ((fn (formatter "~@o"))) (loop for x in *mini-universe* for s1 = (format nil "~@o" x) for s2 = (let ((*print-base* 8)) (format nil "~A" x)) for s3 = (formatter-call-to-string fn x) unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) collect (list x s1 s2 s3))) nil) (deftest format.o.21 (let ((fn (formatter "~:@o"))) (loop for x in *mini-universe* for s1 = (let ((*print-base* 8)) (format nil "~A" x)) for s2 = (format nil "~@:o" x) for s3 = (formatter-call-to-string fn x) for s4 = (let ((*print-base* 8)) (format nil "~A" x)) unless (or (integerp x) (and (string= s1 s2) (string= s2 s3)) (string/= s1 s4)) collect (list x s1 s2 s3))) nil) ;;; Must add tests for non-integers when the parameters ;;; are specified, but it's not clear what the meaning is. ;;; Does mincol apply to the ~A equivalent? What about padchar? ;;; Are comma-char and comma-interval always ignored? ;;; # arguments (deftest format.o.22 (apply #'values (let ((fn (formatter "~#o")) (n #o12345)) (loop for i from 0 to 10 for args = (make-list i) for s = (apply #'format nil "~#o" n args) for s2 = (with-output-to-string (stream) (assert (equal (apply fn stream n args) args))) do (assert (string= s s2)) collect s))) "12345" "12345" "12345" "12345" "12345" " 12345" " 12345" " 12345" " 12345" " 12345" " 12345") (deftest format.o.23 (apply #'values (let ((fn (formatter "~,,,#:o")) (n #o1234567012)) (loop for i from 0 to 10 for args = (make-list i) for s = (apply #'format nil "~,,,#:o" n args) for s2 = (with-output-to-string (stream) (assert (equal (apply fn stream n args) args))) do (assert (string= s s2)) collect s))) "1,2,3,4,5,6,7,0,1,2" "12,34,56,70,12" "1,234,567,012" "12,3456,7012" "12345,67012" "1234,567012" "123,4567012" "12,34567012" "1,234567012" "1234567012" "1234567012") (deftest format.o.24 (apply #'values (let ((fn (formatter "~,,,#:@o")) (n #o1234567012)) (loop for i from 0 to 10 for args = (make-list i) for s = (apply #'format nil "~,,,#@:O" n args) for s2 = (with-output-to-string (stream) (assert (equal (apply fn stream n args) args))) do (assert (string= s s2)) collect s))) "+1,2,3,4,5,6,7,0,1,2" "+12,34,56,70,12" "+1,234,567,012" "+12,3456,7012" "+12345,67012" "+1234,567012" "+123,4567012" "+12,34567012" "+1,234567012" "+1234567012" "+1234567012") (def-format-test format.o.25 "~+10o" (#o1234) " 1234") (def-format-test format.o.26 "~+10@O" (#o1234) " +1234") (def-format-test format.o.27 "~-1O" (#o1234) "1234") (def-format-test format.o.28 "~-1000000000000000000o" (#o1234) "1234") (def-format-test format.o.29 "~vo" ((1- most-negative-fixnum) #o1234) "1234") ;;; Randomized test (deftest format.o.30 (let ((fn (formatter "~v,v,v,vo"))) (loop for mincol = (and (coin) (random 50)) for padchar = (and (coin) (random-from-seq +standard-chars+)) for commachar = (and (coin) (random-from-seq +standard-chars+)) for commaint = (and (coin) (1+ (random 10))) for k = (ash 1 (+ 2 (random 30))) for x = (- (random (+ k k)) k) for fmt = (concatenate 'string (if mincol (format nil "~~~d," mincol) "~,") (if padchar (format nil "'~c," padchar) ",") (if commachar (format nil "'~c," commachar) ",") (if commaint (format nil "~do" commaint) "o")) for s1 = (format nil fmt x) for s2 = (format nil "~v,v,v,vo" mincol padchar commachar commaint x) for s3 = (formatter-call-to-string fn mincol padchar commachar commaint x) repeat 2000 unless (and (string= s1 s2) (string= s2 s3)) collect (list mincol padchar commachar commaint fmt x s1 s2 s3))) nil) gcl27-2.7.0/ansi-tests/format-p.lsp000066400000000000000000000033711454061450500170050ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Oct 17 21:32:45 2004 ;;;; Contains: Tests of the ~P format directives (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-format-test format.p.1 "~p" (1) "") (def-format-test format.p.2 "~P" (2) "s") (def-format-test format.p.3 "~p" (0) "s") (def-format-test format.p.4 "~P" (1.0) "s") (deftest format.p.5 (loop for x in *universe* for s = (format nil "~p" x) unless (or (eql x 1) (string= s "s")) collect (list x s)) nil) (deftest formatter.p.5 (let ((fn (formatter "~p"))) (loop for x in *universe* for s = (formatter-call-to-string fn x) unless (or (eql x 1) (string= s "s")) collect (list x s))) nil) ;;; :p (def-format-test format.p.6 "~D cat~:P" (1) "1 cat") (def-format-test format.p.7 "~D cat~:p" (2) "2 cats") (def-format-test format.p.8 "~D cat~:P" (0) "0 cats") (def-format-test format.p.9 "~D cat~:p" ("No") "No cats") ;;; :@p (def-format-test format.p.10 "~D penn~:@P" (1) "1 penny") (def-format-test format.p.11 "~D penn~:@p" (2) "2 pennies") (def-format-test format.p.12 "~D penn~@:P" (0) "0 pennies") (def-format-test format.p.13 "~D penn~@:p" ("No") "No pennies") ;;; @p (def-format-test format.p.14 "~@p" (1) "y") (def-format-test format.p.15 "~@P" (2) "ies") (def-format-test format.p.16 "~@p" (0) "ies") (def-format-test format.p.17 "~@P" (1.0) "ies") (deftest format.p.18 (loop for x in *universe* for s = (format nil "~@p" x) unless (or (eql x 1) (string= s "ies")) collect (list x s)) nil) (deftest formatter.p.18 (let ((fn (formatter "~@P"))) (loop for x in *universe* for s = (formatter-call-to-string fn x) unless (or (eql x 1) (string= s "ies")) collect (list x s))) nil) gcl27-2.7.0/ansi-tests/format-page.lsp000066400000000000000000000020511454061450500174540ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jul 28 00:20:46 2004 ;;;; Contains: Tests of format with ~| directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-format-test format.page.1 "~0|" nil "") (deftest format.page.2 (let ((s (format nil "~|"))) (cond ((string= s "") nil) ((> (length s) 1) (values s :too-long)) (t (let ((c (elt s 0))) (loop for i from 2 to 100 for s = (format nil (format nil "~~~D|" i)) unless (and (= (length s) i) (every #'(lambda (c2) (char= c c2)) s)) collect i))))) nil) (deftest format.page.3 (let ((s (format nil "~|"))) (cond ((string= s "") nil) ((> (length s) 1) (values s :too-long)) (t (let ((c (elt s 0))) (loop for i from 2 to 100 for s = (format nil "~v|" i) unless (and (= (length s) i) (every #'(lambda (c2) (char= c c2)) s)) collect i))))) nil) (def-format-test format.page.4 "~V|" (0) "") (def-format-test format.page.5 "~v|" (nil) #.(format nil "~|")) gcl27-2.7.0/ansi-tests/format-paren.lsp000066400000000000000000000076531454061450500176620ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Oct 17 20:28:24 2004 ;;;; Contains: Tests of the ~( format directives (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-format-test format.paren.1 "~(XXyy~AuuVV~)" ("ABc dEF ghI") "xxyyabc def ghiuuvv") ;;; Conversion of simple characters to downcase (deftest format.paren.2 (loop for i from 0 below (min char-code-limit (ash 1 16)) for c = (code-char i) when (and c (eql (char-code c) (char-int c)) (upper-case-p c) (let ((s1 (format nil "~(~c~)" c)) (s2 (string (char-downcase c)))) (if (or (not (eql (length s1) 1)) (not (eql (length s2) 1)) (not (eql (elt s1 0) (elt s2 0)))) (list i c s1 s2) nil))) collect it) nil) (deftest formatter.paren.2 (let ((fn (formatter "~(~c~)"))) (loop for i from 0 below (min char-code-limit (ash 1 16)) for c = (code-char i) when (and c (eql (char-code c) (char-int c)) (upper-case-p c) (let ((s1 (formatter-call-to-string fn c)) (s2 (string (char-downcase c)))) (if (or (not (eql (length s1) 1)) (not (eql (length s2) 1)) (not (eql (elt s1 0) (elt s2 0)))) (list i c s1 s2) nil))) collect it)) nil) (def-format-test format.paren.3 "~@(this is a TEST.~)" nil "This is a test.") (def-format-test format.paren.4 "~@(!@#$%^&*this is a TEST.~)" nil "!@#$%^&*This is a test.") (def-format-test format.paren.5 "~:(this is a TEST.~)" nil "This Is A Test.") (def-format-test format.paren.6 "~:(this is7a TEST.~)" nil "This Is7a Test.") (def-format-test format.paren.7 "~:@(this is AlSo A teSt~)" nil "THIS IS ALSO A TEST") (deftest format.paren.8 (loop for i from 0 below (min char-code-limit (ash 1 16)) for c = (code-char i) when (and c (eql (char-code c) (char-int c)) (lower-case-p c) (let ((s1 (format nil "~@:(~c~)" c)) (s2 (string (char-upcase c)))) (if (or (not (eql (length s1) 1)) (not (eql (length s2) 1)) (not (eql (elt s1 0) (elt s2 0)))) (list i c s1 s2) nil))) collect it) nil) (deftest formatter.paren.8 (let ((fn (formatter "~@:(~c~)"))) (loop for i from 0 below (min char-code-limit (ash 1 16)) for c = (code-char i) when (and c (eql (char-code c) (char-int c)) (lower-case-p c) (let ((s1 (formatter-call-to-string fn c)) (s2 (string (char-upcase c)))) (if (or (not (eql (length s1) 1)) (not (eql (length s2) 1)) (not (eql (elt s1 0) (elt s2 0)))) (list i c s1 s2) nil))) collect it)) nil) ;;; Nested conversion (def-format-test format.paren.9 "~(aBc ~:(def~) GHi~)" nil "abc def ghi") (def-format-test format.paren.10 "~(aBc ~(def~) GHi~)" nil "abc def ghi") (def-format-test format.paren.11 "~@(aBc ~:(def~) GHi~)" nil "Abc def ghi") (def-format-test format.paren.12 "~(aBc ~@(def~) GHi~)" nil "abc def ghi") (def-format-test format.paren.13 "~(aBc ~:(def~) GHi~)" nil "abc def ghi") (def-format-test format.paren.14 "~:(aBc ~(def~) GHi~)" nil "Abc Def Ghi") (def-format-test format.paren.15 "~:(aBc ~:(def~) GHi~)" nil "Abc Def Ghi") (def-format-test format.paren.16 "~:(aBc ~@(def~) GHi~)" nil "Abc Def Ghi") (def-format-test format.paren.17 "~:(aBc ~@:(def~) GHi~)" nil "Abc Def Ghi") (def-format-test format.paren.18 "~@(aBc ~(def~) GHi~)" nil "Abc def ghi") (def-format-test format.paren.19 "~@(aBc ~:(def~) GHi~)" nil "Abc def ghi") (def-format-test format.paren.20 "~@(aBc ~@(def~) GHi~)" nil "Abc def ghi") (def-format-test format.paren.21 "~@(aBc ~@:(def~) GHi~)" nil "Abc def ghi") (def-format-test format.paren.22 "~:@(aBc ~(def~) GHi~)" nil "ABC DEF GHI") (def-format-test format.paren.23 "~@:(aBc ~:(def~) GHi~)" nil "ABC DEF GHI") (def-format-test format.paren.24 "~:@(aBc ~@(def~) GHi~)" nil "ABC DEF GHI") (def-format-test format.paren.25 "~@:(aBc ~@:(def~) GHi~)" nil "ABC DEF GHI") gcl27-2.7.0/ansi-tests/format-percent.lsp000066400000000000000000000032701454061450500202040ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jul 27 23:47:44 2004 ;;;; Contains: Tests of format with ~% directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-format-test format.%.1 "~%" nil #.(string #\Newline)) (deftest format.%.2 (loop for i from 0 to 100 for s1 = (make-string i :initial-element #\Newline) for format-string = (format nil "~~~D%" i) for s2 = (format nil format-string) for fn = (eval `(formatter ,s2)) for s3 = (formatter-call-to-string fn) unless (and (string= s1 s2) (string= s1 s3)) collect i) nil) (def-format-test format.%.3 "~v%" (nil) #.(string #\Newline)) (def-format-test format.%.4 "~V%" (1) #.(string #\Newline)) (deftest format.%.5 (loop for i from 0 to 100 for s1 = (make-string i :initial-element #\Newline) for s2 = (format nil "~v%" i) unless (string= s1 s2) collect i) nil) (deftest formatter.%.5 (let ((fn (formatter "~v%"))) (loop for i from 0 to 100 for s1 = (make-string i :initial-element #\Newline) for s2 = (formatter-call-to-string fn i) unless (string= s1 s2) collect i)) nil) (deftest format.%.6 (loop for i from 0 to (min (- call-arguments-limit 3) 100) for args = (make-list i) for s1 = (make-string i :initial-element #\Newline) for s2 = (apply #'format nil "~#%" args) unless (string= s1 s2) collect i) nil) (deftest formatter.%.6 (let ((fn (formatter "~#%"))) (loop for i from 0 to (min (- call-arguments-limit 3) 100) for args = (make-list i) for s1 = (make-string i :initial-element #\Newline) for s2 = (with-output-to-string (stream) (assert (equal (apply fn stream args) args))) unless (string= s1 s2) collect i)) nil) gcl27-2.7.0/ansi-tests/format-question.lsp000066400000000000000000000014731454061450500204160ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Oct 17 20:08:18 2004 ;;;; Contains: Tests of the ~? and ~@? format directives (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-format-test format.?.1 "~?" ("" nil) "") (def-format-test format.?.2 "~?" ("~A" '(1)) "1") (def-format-test format.?.3 "~?" ("" '(1)) "") (def-format-test format.?.4 "~? ~A" ("" '(1) 2) " 2") (def-format-test format.?.5 "a~?z" ("b~?y" '("c~?x" ("~A" (1)))) "abc1xyz") ;;; Tests of ~@? (def-format-test format.@?.1 "~@?" ("") "") (def-format-test format.@?.2 "~@?" ("~A" 1) "1") (def-format-test format.@?.3 "~@? ~A" ("<~A>" 1 2) "<1> 2") (def-format-test format.@?.4 "a~@?z" ("b~@?y" "c~@?x" "~A" 1) "abc1xyz") (def-format-test format.@?.5 "~{~A~@?~A~}" ('(1 "~4*" 2 3 4 5 6)) "16") gcl27-2.7.0/ansi-tests/format-r.lsp000066400000000000000000000324041454061450500170060ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jul 28 00:33:02 2004 ;;;; Contains: Tests of the format directive ~R (in-package :cl-test) ;;; Test of various radixes (compile-and-load "printer-aux.lsp") (compile-and-load "roman-numerals.lsp") (deftest format.r.1 (loop for i from 2 to 36 for s = (format nil "~~~dR" i) nconc (loop for x = (let ((bound (ash 1 (+ 2 (random 40))))) (- (random (* bound 2)) bound)) for s1 = (format nil s x) for s2 = (with-standard-io-syntax (write-to-string x :base i :readably nil)) repeat 100 unless (string= s1 s2) collect (list i x s1 s2))) nil) (deftest formatter.r.1 (loop for i from 2 to 36 for s = (format nil "~~~dR" i) for fn = (eval `(formatter ,s)) nconc (loop for x = (let ((bound (ash 1 (+ 2 (random 40))))) (- (random (* bound 2)) bound)) for s1 = (formatter-call-to-string fn x) for s2 = (with-standard-io-syntax (write-to-string x :base i :readably nil)) repeat 100 unless (string= s1 s2) collect (list i x s1 s2))) nil) (def-format-test format.r.2 "~2r" (14) "1110") (def-format-test format.r.3 "~3r" (29) "1002") (deftest format.r.4 (loop for base from 2 to 36 nconc (loop for mincol from 0 to 20 for fmt = (format nil "~~~D,~DR" base mincol) for s = (format nil fmt base) unless (if (<= mincol 2) (string= s "10") (string= (concatenate 'string (make-string (- mincol 2) :initial-element #\Space) "10") s)) collect (list base mincol s))) nil) (deftest formatter.r.4 (loop for base from 2 to 36 nconc (loop for mincol from 0 to 20 for fmt = (format nil "~~~D,~DR" base mincol) for fn = (eval `(formatter ,fmt)) for s = (formatter-call-to-string fn base) unless (if (<= mincol 2) (string= s "10") (string= (concatenate 'string (make-string (- mincol 2) :initial-element #\Space) "10") s)) collect (list base mincol s))) nil) (deftest format.r.5 (loop for base from 2 to 36 nconc (loop for mincol from 0 to 20 for fmt = (format nil "~~~D,~D,'*r" base mincol) for s = (format nil fmt base) unless (if (<= mincol 2) (string= s "10") (string= (concatenate 'string (make-string (- mincol 2) :initial-element #\*) "10") s)) collect (list base mincol s))) nil) (deftest formatter.r.5 (loop for base from 2 to 36 nconc (loop for mincol from 0 to 20 for fmt = (format nil "~~~D,~D,'*r" base mincol) for fn = (eval `(formatter ,fmt)) for s = (formatter-call-to-string fn base) unless (if (<= mincol 2) (string= s "10") (string= (concatenate 'string (make-string (- mincol 2) :initial-element #\*) "10") s)) collect (list base mincol s))) nil) (deftest format.r.6 (loop for base from 2 to 36 for s = (format nil "~vr" base (1+ base)) unless (string= s "11") collect (list base s)) nil) (deftest formatter.r.6 (let ((fn (formatter "~vr"))) (loop for base from 2 to 36 for s = (formatter-call-to-string fn base (1+ base)) unless (string= s "11") collect (list base s))) nil) (defparameter *english-number-names* '("zero" "one" "two" "three" "four" "five" "six" "seven" "eight" "nine" "ten" "eleven" "twelve" "thirteen" "fourteen" "fifteen" "sixteen" "seventeen" "eighteen" "nineteen" "twenty" "twenty-one" "twenty-two" "twenty-three" "twenty-four" "twenty-five" "twenty-six" "twenty-seven" "twenty-eight" "twenty-nine" "thirty" "thirty-one" "thirty-two" "thirty-three" "thirty-four" "thirty-five" "thirty-six" "thirty-seven" "thirty-eight" "thirty-nine" "forty" "forty-one" "forty-two" "forty-three" "forty-four" "forty-five" "forty-six" "forty-seven" "forty-eight" "forty-nine" "fifty" "fifty-one" "fifty-two" "fifty-three" "fifty-four" "fifty-five" "fifty-six" "fifty-seven" "fifty-eight" "fifty-nine" "sixty" "sixty-one" "sixty-two" "sixty-three" "sixty-four" "sixty-five" "sixty-six" "sixty-seven" "sixty-eight" "sixty-nine" "seventy" "seventy-one" "seventy-two" "seventy-three" "seventy-four" "seventy-five" "seventy-six" "seventy-seven" "seventy-eight" "seventy-nine" "eighty" "eighty-one" "eighty-two" "eighty-three" "eighty-four" "eighty-five" "eighty-six" "eighty-seven" "eighty-eight" "eighty-nine" "ninety" "ninety-one" "ninety-two" "ninety-three" "ninety-four" "ninety-five" "ninety-six" "ninety-seven" "ninety-eight" "ninety-nine" "one hundred")) (deftest format.r.7 (loop for i from 0 to 100 for s1 = (format nil "~r" i) for s2 in *english-number-names* unless (string= s1 s2) collect (list i s1 s2)) nil) (deftest formatter.r.7 (let ((fn (formatter "~r"))) (loop for i from 0 to 100 for s1 = (formatter-call-to-string fn i) for s2 in *english-number-names* unless (string= s1 s2) collect (list i s1 s2))) nil) (deftest format.r.7a (loop for i from 1 to 100 for s1 = (format nil "~r" (- i)) for s2 in (cdr *english-number-names*) for s3 = (concatenate 'string "negative " s2) for s4 = (concatenate 'string "minus " s2) unless (or (string= s1 s3) (string= s1 s4)) collect (list i s1 s3 s4)) nil) (def-format-test format.r.8 "~vr" (nil 5) "five") (def-format-test format.r.9 "~#r" (4 nil nil) "11" 2) (deftest format.r.10 (with-standard-io-syntax (let ((*print-radix* t)) (format nil "~10r" 123))) "123") (deftest formatter.r.10 (let ((fn (formatter "~10r"))) (with-standard-io-syntax (let ((*print-radix* t)) (values (format nil fn 123) (formatter-call-to-string fn 123))))) "123" "123") (def-format-test format.r.11 "~8@R" (65) "+101") (def-format-test format.r.12 "~2:r" (126) "1,111,110") (def-format-test format.r.13 "~3@:r" (#3r2120012102) "+2,120,012,102") (deftest format.r.14 (loop for i from 2 to 36 for s = (format nil "~~~d:R" i) nconc (loop for x = (let ((bound (ash 1 (+ 2 (random 40))))) (- (random (* bound 2)) bound)) for s1 = (remove #\, (format nil s x)) for y = (let ((*read-base* i)) (read-from-string s1)) repeat 100 unless (= x y) collect (list i x s1 y))) nil) (deftest format.r.15 (loop for i = (+ 2 (random 35)) for interval = (1+ (random 20)) for comma = (loop for c = (random-from-seq +standard-chars+) unless (alphanumericp c) return c) for s = (format nil "~~~d,,,'~c,~d:R" i comma interval) for x = (let ((bound (ash 1 (+ 2 (random 40))))) (- (random (* bound 2)) bound)) for s1 = (remove comma (format nil s x)) for y = (let ((*read-base* i)) (read-from-string s1)) repeat 1000 unless (or (and (eql comma #\-) (< x 0)) (= x y)) collect (list i interval comma x s1 y)) nil) (def-format-test format.r.16 "~2,,,,1000000000000000000r" (17) "10001") (def-format-test format.r.17 "~8,10:@r" (#o526104) " +526,104") (defparameter *english-ordinal-names* '("zeroth" "first" "second" "third" "fourth" "fifth" "sixth" "seventh" "eighth" "ninth" "tenth" "eleventh" "twelfth" "thirteenth" "fourteenth" "fifteenth" "sixteenth" "seventeenth" "eighteenth" "nineteenth" "twentieth" "twenty-first" "twenty-second" "twenty-third" "twenty-fourth" "twenty-fifth" "twenty-sixth" "twenty-seventh" "twenty-eighth" "twenty-ninth" "thirtieth" "thirty-first" "thirty-second" "thirty-third" "thirty-fourth" "thirty-fifth" "thirty-sixth" "thirty-seventh" "thirty-eighth" "thirty-ninth" "fortieth" "forty-first" "forty-second" "forty-third" "forty-fourth" "forty-fifth" "forty-sixth" "forty-seventh" "forty-eighth" "forty-ninth" "fiftieth" "fifty-first" "fifty-second" "fifty-third" "fifty-fourth" "fifty-fifth" "fifty-sixth" "fifty-seventh" "fifty-eighth" "fifty-ninth" "sixtieth" "sixty-first" "sixty-second" "sixty-third" "sixty-fourth" "sixty-fifth" "sixty-sixth" "sixty-seventh" "sixty-eighth" "sixty-ninth" "seventieth" "seventy-first" "seventy-second" "seventy-third" "seventy-fourth" "seventy-fifth" "seventy-sixth" "seventy-seventh" "seventy-eighth" "seventy-ninth" "eightieth" "eighty-first" "eighty-second" "eighty-third" "eighty-fourth" "eighty-fifth" "eighty-sixth" "eighty-seventh" "eighty-eighth" "eighty-ninth" "ninetieth" "ninety-first" "ninety-second" "ninety-third" "ninety-fourth" "ninety-fifth" "ninety-sixth" "ninety-seventh" "ninety-eighth" "ninety-ninth" "one hundredth")) (deftest format.r.18 (loop for i from 0 to 100 for s1 = (format nil "~:r" i) for s2 in *english-ordinal-names* unless (string= s1 s2) collect (list i s1 s2)) nil) (deftest formatter.r.18 (let ((fn (formatter "~:r"))) (loop for i from 0 to 100 for s1 = (formatter-call-to-string fn i) for s2 in *english-ordinal-names* unless (string= s1 s2) collect (list i s1 s2))) nil) (deftest format.r.18a (loop for i from 1 to 100 for s1 = (format nil "~:r" (- i)) for s2 in (cdr *english-ordinal-names*) for s3 = (concatenate 'string "negative " s2) for s4 = (concatenate 'string "minus " s2) unless (or (string= s1 s3) (string= s1 s4)) collect (list i s1 s3 s4)) nil) (deftest format.r.19 (loop for i from 1 for s1 in *roman-numerals* for s2 = (format nil "~@R" i) unless (string= s1 s2) collect (list i s1 s2)) nil) (deftest formatter.r.19 (let ((fn (formatter "~@r"))) (loop for i from 1 for s1 in *roman-numerals* for s2 = (formatter-call-to-string fn i) unless (string= s1 s2) collect (list i s1 s2))) nil) ;;; Old roman numerals (defun old-roman-numeral (x) (assert (typep x '(integer 1))) (let ((n-m 0) (n-d 0) (n-c 0) (n-l 0) (n-x 0) (n-v 0) ) (loop while (>= x 1000) do (incf n-m) (decf x 1000)) (when (>= x 500) (incf n-d) (decf x 500)) (loop while (>= x 100) do (incf n-c) (decf x 100)) (when (>= x 50) (incf n-l) (decf x 50)) (loop while (>= x 10) do (incf n-x) (decf x 10)) (when (>= x 5) (incf n-v) (decf x 5)) (concatenate 'string (make-string n-m :initial-element #\M) (make-string n-d :initial-element #\D) (make-string n-c :initial-element #\C) (make-string n-l :initial-element #\L) (make-string n-x :initial-element #\X) (make-string n-v :initial-element #\V) (make-string x :initial-element #\I)))) (deftest format.r.20 (loop for i from 1 to 4999 for s1 = (format nil "~:@r" i) for s2 = (old-roman-numeral i) unless (string= s1 s2) collect (list i s1 s2)) nil) (deftest formatter.r.20 (let ((fn (formatter "~@:R"))) (loop for i from 1 to 4999 for s1 = (formatter-call-to-string fn i) for s2 = (old-roman-numeral i) unless (string= s1 s2) collect (list i s1 s2))) nil) (deftest format.r.21 (loop for i from 1 to 4999 for s1 = (format nil "~:@r" i) for s2 = (format nil "~@:R" i) unless (string= s1 s2) collect (list i s1 s2)) nil) ;; Combinations of mincol and comma chars (def-format-test format.r.22 "~2,12,,'*:r" (#b1011101) " 1*011*101") (def-format-test format.r.23 "~3,14,'X,',:R" (#3r1021101) "XXXXX1,021,101") ;; v directive in various positions (def-format-test format.r.24 "~10,vr" (nil 12345) "12345") (deftest format.r.25 (loop for i from 0 to 5 for s = (format nil "~10,vr" i 12345) unless (string= s "12345") collect (list i s)) nil) (deftest formatter.r.25 (let ((fn (formatter "~10,vr"))) (loop for i from 0 to 5 for s = (formatter-call-to-string fn i 12345) unless (string= s "12345") collect (list i s))) nil) (def-format-test format.r.26 "~10,#r" (12345 nil nil nil nil nil) " 12345" 5) (def-format-test format.r.27 "~10,12,vr" (#\/ 123456789) "///123456789") (def-format-test format.r.28 "~10,,,v:r" (#\/ 123456789) "123/456/789") (def-format-test format.r.29 "~10,,,v:r" (nil 123456789) "123,456,789") (def-format-test format.r.30 "~8,,,,v:R" (nil #o12345670) "12,345,670") (def-format-test format.r.31 "~8,,,,v:R" (2 #o12345670) "12,34,56,70") (def-format-test format.r.32 "~16,,,,#:r" (#x12345670 nil nil nil) "1234,5670" 3) (def-format-test format.r.33 "~16,,,,1:r" (#x12345670) "1,2,3,4,5,6,7,0") ;;; Explicit signs (def-format-test format.r.34 "~+10r" (12345) "12345") (def-format-test format.r.35 "~10,+8r" (12345) " 12345") (def-format-test format.r.36 "~10,0r" (12345) "12345") (def-format-test format.r.37 "~10,-1r" (12345) "12345") (def-format-test format.r.38 "~10,-1000000000000000r" (12345) "12345") ;;; Randomized test (deftest format.r.39 (let ((fn (formatter "~v,v,v,v,vr"))) (loop for radix = (+ 2 (random 35)) for mincol = (and (coin) (random 50)) for padchar = (and (coin) (random-from-seq +standard-chars+)) for commachar = (and (coin) (random-from-seq +standard-chars+)) for commaint = (and (coin) (1+ (random 10))) for k = (ash 1 (+ 2 (random 30))) for x = (- (random (+ k k)) k) for fmt = (concatenate 'string (format nil "~~~d," radix) (if mincol (format nil "~d," mincol) ",") (if padchar (format nil "'~c," padchar) ",") (if commachar (format nil "'~c," commachar) ",") (if commaint (format nil "~dr" commaint) "r")) for s1 = (format nil fmt x) for s2 = (format nil "~v,v,v,v,vr" radix mincol padchar commachar commaint x) for s3 = (formatter-call-to-string fn radix mincol padchar commachar commaint x) repeat 2000 unless (and (string= s1 s2) (string= s1 s3)) collect (list radix mincol padchar commachar commaint fmt x s1 s2 s3))) nil) gcl27-2.7.0/ansi-tests/format-s.lsp000066400000000000000000000200531454061450500170040ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Aug 3 11:55:07 2004 ;;;; Contains: Test of the ~S format directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest format.s.1 (let ((*print-readably* nil) (*print-case* :upcase)) (format nil "~s" nil)) "NIL") (deftest formatter.s.1 (let ((*print-readably* nil) (*print-case* :upcase)) (formatter-call-to-string (formatter "~s") nil)) "NIL") (def-format-test format.s.2 "~:s" (nil) "()") (deftest format.s.3 (let ((*print-readably* nil) (*print-case* :upcase)) (format nil "~:s" '(nil))) "(NIL)") (deftest formatter.s.3 (let ((*print-readably* nil) (*print-case* :upcase)) (formatter-call-to-string (formatter "~:s") '(nil))) "(NIL)") (deftest format.s.4 (let ((*print-readably* nil) (*print-case* :downcase)) (format nil "~s" 'nil)) "nil") (deftest formatter.s.4 (let ((*print-readably* nil) (*print-case* :downcase)) (formatter-call-to-string (formatter "~s") 'nil)) "nil") (deftest format.s.5 (let ((*print-readably* nil) (*print-case* :capitalize)) (format nil "~s" 'nil)) "Nil") (deftest formatter.s.5 (let ((*print-readably* nil) (*print-case* :capitalize)) (formatter-call-to-string (formatter "~s") 'nil)) "Nil") (def-format-test format.s.6 "~:s" (#(nil)) "#(NIL)") (deftest format.s.7 (let ((fn (formatter "~S"))) (with-standard-io-syntax (let ((*print-readably* nil)) (loop for c across +standard-chars+ for s = (format nil "~S" c) for s2 = (formatter-call-to-string fn c) for c2 = (read-from-string s) unless (and (eql c c2) (string= s s2)) collect (list c s c2 s2))))) nil) (deftest format.s.8 (let ((fn (formatter "~s"))) (with-standard-io-syntax (let ((*print-readably* nil)) (loop with count = 0 for i from 0 below (min #x10000 char-code-limit) for c = (code-char i) for s1 = (and c (format nil "#\\~:c" c)) for s2 = (and c (format nil "~S" c)) for s3 = (formatter-call-to-string fn c) unless (or (null c) (graphic-char-p c) (and (string= s1 s2) (string= s2 s3))) do (incf count) and collect (list c s1 s2) when (> count 100) collect "count limit exceeded" and do (loop-finish))))) nil) (deftest format.s.9 (with-standard-io-syntax (let ((*print-readably* nil)) (apply #'values (loop for i from 1 to 10 for fmt = (format nil "~~~d@s" i) for s = (format nil fmt nil) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn nil) do (assert (string= s s2)) collect s)))) "NIL" "NIL" "NIL" " NIL" " NIL" " NIL" " NIL" " NIL" " NIL" " NIL") (deftest format.s.10 (with-standard-io-syntax (let ((*print-readably* nil)) (apply #'values (loop for i from 1 to 10 for fmt = (format nil "~~~dS" i) for s = (format nil fmt nil) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn nil) do (assert (string= s s2)) collect s)))) "NIL" "NIL" "NIL" "NIL " "NIL " "NIL " "NIL " "NIL " "NIL " "NIL ") (deftest format.s.11 (with-standard-io-syntax (let ((*print-readably* nil)) (apply #'values (loop for i from 1 to 10 for fmt = (format nil "~~~d@:S" i) for s = (format nil fmt nil) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn nil) do (assert (string= s s2)) collect s)))) "()" "()" " ()" " ()" " ()" " ()" " ()" " ()" " ()" " ()") (deftest format.s.12 (with-standard-io-syntax (let ((*print-readably* nil)) (apply #'values (loop for i from 1 to 10 for fmt = (format nil "~~~d:s" i) for s = (format nil fmt nil) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn nil) do (assert (string= s s2)) collect s)))) "()" "()" "() " "() " "() " "() " "() " "() " "() " "() ") (deftest format.s.13 (with-standard-io-syntax (let ((*print-readably* nil) (fn (formatter "~V:s"))) (apply #'values (loop for i from 1 to 10 for s = (format nil "~v:S" i nil) for s2 = (formatter-call-to-string fn i nil) do (assert (string= s s2)) collect s)))) "()" "()" "() " "() " "() " "() " "() " "() " "() " "() ") (deftest format.s.14 (with-standard-io-syntax (let ((*print-readably* nil) (fn (formatter "~V@:s"))) (apply #'values (loop for i from 1 to 10 for s = (format nil "~v:@s" i nil) for s2 = (formatter-call-to-string fn i nil) do (assert (string= s s2)) collect s)))) "()" "()" " ()" " ()" " ()" " ()" " ()" " ()" " ()" " ()") (def-format-test format.s.15 "~vS" (nil nil) "NIL") (def-format-test format.s.16 "~v:S" (nil nil) "()") (def-format-test format.s.17 "~@S" (nil) "NIL") (def-format-test format.s.18 "~v@S" (nil nil) "NIL") (def-format-test format.s.19 "~v:@s" (nil nil) "()") (def-format-test format.s.20 "~v@:s" (nil nil) "()") ;;; With colinc specified (def-format-test format.s.21 "~3,1s" (nil) "NIL") (def-format-test format.s.22 "~4,3s" (nil) "NIL ") (def-format-test format.s.23 "~3,3@s" (nil) "NIL") (def-format-test format.s.24 "~4,4@s" (nil) " NIL") (def-format-test format.s.25 "~5,3@s" (nil) " NIL") (def-format-test format.s.26 "~5,3S" (nil) "NIL ") (def-format-test format.s.27 "~7,3@s" (nil) " NIL") (def-format-test format.s.28 "~7,3S" (nil) "NIL ") ;;; With minpad (deftest format.s.29 (with-standard-io-syntax (let ((*print-readably* nil) (*package* (find-package :cl-test)) (fn (formatter "~V,,2s"))) (loop for i from -4 to 10 for s = (format nil "~v,,2S" i 'ABC) for s2 = (formatter-call-to-string fn i 'ABC) do (assert (string= s s2)) collect s))) ("ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC ")) (def-format-test format.s.30 "~3,,+2S" ('ABC) "ABC ") (def-format-test format.s.31 "~3,,0S" ('ABC) "ABC") (def-format-test format.s.32 "~3,,-1S" ('ABC) "ABC") (def-format-test format.s.33 "~3,,0S" ('ABCD) "ABCD") (def-format-test format.s.34 "~3,,-1S" ('ABCD) "ABCD") ;;; With padchar (def-format-test format.s.35 "~4,,,'XS" ('AB) "ABXX") (def-format-test format.s.36 "~4,,,s" ('AB) "AB ") (def-format-test format.s.37 "~4,,,'X@s" ('AB) "XXAB") (def-format-test format.s.38 "~4,,,@S" ('AB) " AB") (def-format-test format.s.39 "~10,,,vS" (nil 'ABCDE) "ABCDE ") (def-format-test format.s.40 "~10,,,v@S" (nil 'ABCDE) " ABCDE") (def-format-test format.s.41 "~10,,,vs" (#\* 'ABCDE) "ABCDE*****") (def-format-test format.s.42 "~10,,,v@s" (#\* 'ABCDE) "*****ABCDE") ;;; Other tests (def-format-test format.s.43 "~3,,vS" (nil 246) "246") (deftest format.s.44 (with-standard-io-syntax (let ((*print-readably* nil) (*package* (find-package :cl-test)) (fn (formatter "~3,,vs"))) (loop for i from 0 to 6 for s = (format nil "~3,,vS" i 'ABC) for s2 = (formatter-call-to-string fn i 'ABC) do (assert (string= s s2)) collect s))) ("ABC" "ABC " "ABC " "ABC " "ABC " "ABC " "ABC ")) (deftest format.s.44a (with-standard-io-syntax (let ((*print-readably* nil) (*package* (find-package :cl-test)) (fn (formatter "~3,,V@S"))) (loop for i from 0 to 6 for s = (format nil "~3,,v@S" i 'ABC) for s2 = (formatter-call-to-string fn i 'ABC) do (assert (string= s s2)) collect s))) ("ABC" " ABC" " ABC" " ABC" " ABC" " ABC" " ABC")) (def-format-test format.s.45 "~4,,vs" (-1 1234) "1234") (def-format-test format.s.46 "~5,vS" (nil 123) "123 ") (def-format-test format.s.47 "~5,vS" (3 456) "456 ") (def-format-test format.s.48 "~5,v@S" (3 789) " 789") gcl27-2.7.0/ansi-tests/format-slash.lsp000066400000000000000000000077541454061450500176710ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 21 09:51:08 2004 ;;;; Contains: Tests for format directive ~/.../ (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-pprint-test format./.1 (format nil "~/pprint-linear/" 1) "1") (def-pprint-test format./.2 (format nil "~/pprint-linear/" 2) "2" :pretty nil) (def-pprint-test format./.3 (format nil "~/pprint-linear/" '(17)) "17") (def-pprint-test format./.4 (format nil "~:/pprint-linear/" '(17)) "(17)") (def-pprint-test format./.5 (format nil "~@/pprint-linear/" 1) "1") (def-pprint-test format./.6 (format nil "~@:/pprint-linear/" 1) "1") (def-pprint-test format./.7 (format nil "~/PPRINT-LINEAR/" 1) "1") (def-pprint-test format./.8 (format nil "~/pPrINt-lINeaR/" 1) "1") (def-pprint-test format./.9 (progn (setf (symbol-function 'FUNCTION-FOR-FORMAT-SLASH-9) #'pprint-linear) (format nil "~/CL-TEST::FUNCTION-FOR-FORMAT-SLASH-9/" 1)) "1") ;;; Single : doesn't mean it has to be exported (def-pprint-test format./.10 (progn (setf (symbol-function 'FUNCTION-FOR-FORMAT-SLASH-10) #'pprint-linear) (format nil "~/cl-test:FUNCTION-FOR-FORMAT-SLASH-10/" 1)) "1") (def-pprint-test format./.11 (progn (setf (symbol-function '|FUNCTION:FOR::FORMAT:SLASH:11|) #'pprint-linear) (format nil "~/cL-tESt:FUNCTION:FOR::FORMAT:SLASH:11/" 1)) "1") (def-pprint-test format./.12 (format nil "~<~/pprint-tabular/~:>" '((|M|))) "M") (def-pprint-test format./.13 (format nil "~<~:/pprint-tabular/~:>" '((|M|))) "(M)") (def-pprint-test format./.14 (format nil "~<~:@/pprint-tabular/~:>" '((|M|))) "(M)") (def-pprint-test format./.15 (format nil "~<~@/pprint-tabular/~:>" '((|M|))) "M") (def-pprint-test format./.16 (format nil "~<~4:/pprint-tabular/~:>" '((|M| |M|))) "(M M)") (def-pprint-test format./.17 (format nil "~<~v:/pprint-tabular/~:>" '(nil (|M| |M|))) "(M M)") (def-pprint-test format./.18 (format nil "~<~v:/pprint-tabular/~:>" '(3 (|M| |M|))) "(M M)") (declaim (special *expected-args*)) (def-pprint-test format./.19 (progn (setf (symbol-function 'function-for-format-slash-19) #'(lambda (stream &rest args) (assert (= (length args) (length *expected-args*))) (assert (equal (car args) (car *expected-args*))) (assert (if (cadr args) (cadr *expected-args*) (not (cadr *expected-args*)))) (assert (if (caddr args) (caddr *expected-args*) (not (caddr *expected-args*)))) (apply #'pprint-fill stream (subseq args 0 3)))) (list (let ((*expected-args* '(1 nil nil))) (format nil "~/cl-test::function-for-format-slash-19/" 1)) (let ((*expected-args* '(2 t nil))) (format nil "~:/cl-test::function-for-format-slash-19/" 2)) (let ((*expected-args* '(3 nil t))) (format nil "~@/cl-test::function-for-format-slash-19/" 3)) (let ((*expected-args* '(4 t t))) (format nil "~:@/cl-test::function-for-format-slash-19/" 4)) (let ((*expected-args* '(5 t t))) (format nil "~@:/cl-test::function-for-format-slash-19/" 5)) (let ((*expected-args* '(6 t t 18))) (format nil "~18@:/cl-test::function-for-format-slash-19/" 6)) (let ((*expected-args* '(7 nil nil 19))) (format nil "~v/cl-test::function-for-format-slash-19/" 19 7)) (let ((*expected-args* '(8 t nil #\X))) (format nil "~'X:/cl-test::function-for-format-slash-19/" 8)) (let ((*expected-args* '(9 nil t #\,))) (format nil "~',@/cl-test::function-for-format-slash-19/" 9)) (let ((*expected-args* '(10 nil t -1))) (format nil "~-1@/cl-test::function-for-format-slash-19/" 10)) (let ((*expected-args* '(11 nil t 1 2 3 4 5 6 7 8 9 10))) (format nil "~1,2,3,4,5,6,7,8,9,10@/cl-test::function-for-format-slash-19/" 11)) (let ((*expected-args* '(12 nil t 1 2 3 4 5 6 7 8 9 10))) (format nil "~v,v,v,v,v,v,v,v,v,v@/cl-test::function-for-format-slash-19/" 1 2 3 4 5 6 7 8 9 10 12)) )) ("1" "2" "3" "4" "5" "6" "7" "8" "9" "10" "11" "12")) gcl27-2.7.0/ansi-tests/format-t.lsp000066400000000000000000000206511454061450500170110ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 21 12:45:22 2004 ;;;; Contains: Tests of the ~T format directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-pprint-test format.t.1 (format nil "~0,0T") "") (def-pprint-test format.t.2 (format nil "~1,0T") " ") (def-pprint-test format.t.3 (format nil "~0,1T") " ") (def-pprint-test format.t.4 (loop for i from 0 to 20 for s = (format nil "~0,vT" i) unless (string= s (make-string i :initial-element #\Space)) collect (list i s)) nil) (def-pprint-test format.t.5 (loop for i from 0 to 20 for s = (format nil "~v,0T" i) unless (string= s (make-string i :initial-element #\Space)) collect (list i s)) nil) (def-pprint-test format.t.6 (loop for n1 = (random 30) for s1 = (make-string n1 :initial-element #\X) for n2 = (random 30) for inc = (random 20) for s2 = (cond ((< n1 n2) (concatenate 'string s1 (make-string (- n2 n1) :initial-element #\Space))) ((= inc 0) s1) (t (loop do (incf n2 inc) while (<= n2 n1)) (concatenate 'string s1 (make-string (- n2 n1) :initial-element #\Space)))) for pretty = (coin) for result = (let ((*print-pretty* pretty)) (format nil (format nil "~A~~~D,~DT" s1 n2 inc))) repeat 100 unless (string= s2 result) collect (list n1 n2 inc pretty s2 result)) nil) (def-pprint-test format.t.7 (loop for n1 = (random 30) for s1 = (make-string n1 :initial-element #\X) for n2 = (random 30) for inc = (random 20) for s2 = (cond ((< n1 n2) (concatenate 'string s1 (make-string (- n2 n1) :initial-element #\Space))) ((= inc 0) s1) (t (loop do (incf n2 inc) while (<= n2 n1)) (concatenate 'string s1 (make-string (- n2 n1) :initial-element #\Space)))) for pretty = (coin) for result = (let ((*print-pretty* pretty)) (format nil "~A~v,vt" s1 n2 inc)) repeat 100 unless (string= s2 result) collect (list n1 n2 inc pretty s2 result)) nil) (def-pprint-test format.t.8 (loop for i from 1 to 20 for s = (format nil " ~v,vT" nil i) unless (string= s (make-string (1+ i) :initial-element #\Space)) collect (list i s)) nil) (def-pprint-test format.t.9 (loop for i from 1 to 20 for s = (format nil "~v,vT" i nil) unless (string= s (make-string i :initial-element #\Space)) collect (list i s)) nil) (def-pprint-test format.t.10 (format nil "XXXXX~2,0T") "XXXXX") ;;; @t (def-pprint-test format.@t.1 (format nil "~1,1@t") " ") (def-pprint-test format.@t.2 (loop for colnum from 0 to 20 for s1 = (format nil "~v,1@t" colnum) for s2 = (make-string colnum :initial-element #\Space) unless (string= s1 s2) collect (list colnum s1 s2)) nil) (def-pprint-test format.@t.3 (loop for colnum = (random 50) for colinc = (1+ (random 20)) for s1 = (format nil "~v,v@t" colnum colinc) for s2 = (make-string (* colinc (ceiling colnum colinc)) :initial-element #\Space) repeat 100 unless (string= s1 s2) collect (list colnum colinc s1 s2)) nil) (def-pprint-test format.@t.4 (loop for colnum = (random 50) for colinc = (1+ (random 20)) for s1 = (format nil "~v,1@T~0,v@t" colnum colinc) for s2 = (make-string (* colinc (ceiling colnum colinc)) :initial-element #\Space) repeat 100 unless (string= s1 s2) collect (list colnum colinc s1 s2)) nil) (def-pprint-test format.@t.5 (loop for colnum = (random 50) for colinc = (1+ (random 20)) for pretty = (coin) for s1 = (let ((*pretty* pretty)) (format nil (format nil "~~~d,~d@t" colnum colinc))) for s2 = (make-string (* colinc (ceiling colnum colinc)) :initial-element #\Space) repeat 100 unless (string= s1 s2) collect (list colnum colinc pretty s1 s2)) nil) ;;; Pretty printing (colon modifier) ;;; Not a pretty printing stream (def-pprint-test format.\:t.1 (format nil "XX~10:tYY") "XXYY") ;;; A pretty printing stream, but *print-pretty* is nil (def-pprint-test format.\:t.2 (with-output-to-string (s) (pprint-logical-block (s '(a b c)) (format s "XX~10:tYY"))) "XXYY" :pretty nil) (def-pprint-test format.\:t.3 (with-output-to-string (s) (pprint-logical-block (s '(a b c)) (let ((*print-pretty* nil)) (format s "XX~10:tYY")))) "XXYY") ;;; Positive tests (def-pprint-test format.\:t.4 (format nil "~<[~;~0,0:T~;]~:>" '(a)) "[]") (def-pprint-test format.\:t.5 (format nil "~<[~;~1,0:T~;]~:>" '(a)) "[ ]") (def-pprint-test format.\:t.5a (format nil "~<[~;~,0:T~;]~:>" '(a)) "[ ]") (def-pprint-test format.\:t.6 (format nil "~<[~;~0,1:T~;]~:>" '(a)) "[ ]") (def-pprint-test format.\:t.6a (format nil "~<[~;~0,:T~;]~:>" '(a)) "[ ]") (def-pprint-test format.\:t.6b (format nil "~<[~;~0:T~;]~:>" '(a)) "[ ]") (def-pprint-test format.\:t.7 (loop for i from 0 to 20 for s = (format nil "~" (list i)) unless (string= s (concatenate 'string "X" (make-string i :initial-element #\Space) "Y")) collect (list i s)) nil) (def-pprint-test format.\:t.8 (loop for i from 0 to 20 for s = (format nil "~" (list i)) unless (string= s (concatenate 'string "ABC" (make-string i :initial-element #\Space) "DEF")) collect (list i s)) nil) (def-pprint-test format.\:t.9 (loop for n0 = (random 10) for s0 = (make-string n0 :initial-element #\Space) for n1 = (random 30) for s1 = (make-string n1 :initial-element #\X) for n2 = (random 30) for inc = (random 20) for s2 = (cond ((< n1 n2) (concatenate 'string s0 s1 (make-string (- n2 n1) :initial-element #\Space))) ((= inc 0) (concatenate 'string s0 s1)) (t (loop do (incf n2 inc) while (<= n2 n1)) (concatenate 'string s0 s1 (make-string (- n2 n1) :initial-element #\Space)))) for result = (format nil (format nil "~A~~<~A~~~D,~D:T~~:>" s0 s1 n2 inc) '(a)) repeat 100 unless (string= s2 result) collect (list n0 n1 n2 inc s2 result)) nil) (def-pprint-test format.\:t.10 (format nil "~<[~;~2,0:T~;]~:>" '(a)) "[ ]") (def-pprint-test format.\:t.11 (format nil "~<[~;XXXX~2,0:T~;]~:>" '(a)) "[XXXX]") (def-pprint-test format.\:t.12 (loop for n0 = (random 20) for s0 = (make-string n0 :initial-element #\Space) for n1 = (random 30) for s1 = (make-string n1 :initial-element #\X) for n2 = (random 30) for inc = (random 20) for s2 = (cond ((< n1 n2) (concatenate 'string s0 s1 (make-string (- n2 n1) :initial-element #\Space))) ((= inc 0) (concatenate 'string s0 s1)) (t (loop do (incf n2 inc) while (<= n2 n1)) (concatenate 'string s0 s1 (make-string (- n2 n1) :initial-element #\Space)))) for result = (format nil "~A~<~A~v,v:t~:>" s0 (list s1 n2 inc)) repeat 100 unless (string= s2 result) collect (list n1 n2 inc s2 result)) nil) ;;; see 22.3.5.2 (deftest format.\:t.error.1 (signals-error-always (format nil "~") error) t t) (deftest format.\:t.error.2 (signals-error-always (format nil "~ZZZ~4,5:tWWW") error) t t) (deftest format.\:t.error.3 (signals-error-always (format nil "AAAA~1,1:TBBB~ZZZ") error) t t) ;;; ~:@t (def-pprint-test format.\:@t.1 (format nil "~" '(a)) "XXX YYY") (def-pprint-test format.\:@t.1a (format nil "~" '(a)) "XXX YYY") (def-pprint-test format.\:@t.1b (format nil "~" '(a)) "XXX YYY") (def-pprint-test format.\:@t.1c (format nil "~" '(a)) "XXX YYY") (def-pprint-test format.\:@t.1d (format nil "~" '(a)) "XXX YYY") (def-pprint-test format.\:@t.2 (loop for colnum from 0 to 20 for s1 = (format nil "~" (list colnum)) for s2 = (concatenate 'string "XXXX" (make-string colnum :initial-element #\Space)) unless (string= s1 s2) collect (list colnum s1 s2)) nil) (def-pprint-test format.\:@t.3 (loop for s0 = (make-string (random 20) :initial-element #\M) for colnum = (random 50) for colinc = (1+ (random 20)) for s1 = (format nil "~A~<~v,v:@t~:>" s0 (list colnum colinc)) for s2 = (concatenate 'string s0 (make-string (* colinc (ceiling colnum colinc)) :initial-element #\Space)) repeat 100 unless (string= s1 s2) collect (list colnum colinc s1 s2)) nil) ;;; Turned off if not pretty printing (def-pprint-test format.\:@t.4 (format nil "XX~10,20:@tYY") "XXYY" :pretty nil) (def-pprint-test format.\:@t.5 (with-output-to-string (s) (pprint-logical-block (s '(a b c)) (format s "XX~10,20@:tYY"))) "XXYY" :pretty nil) gcl27-2.7.0/ansi-tests/format-tilde.lsp000066400000000000000000000034361454061450500176510ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jul 28 00:27:00 2004 ;;;; Contains: Tests of format directive ~~ (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-format-test format.~.1 "~~" nil "~") (deftest format.~.2 (loop for i from 0 to 100 for s = (make-string i :initial-element #\~) for format-string = (format nil "~~~D~~" i) for s2 = (format nil format-string) unless (string= s s2) collect (list i s s2)) nil) (deftest formatter.~.2 (loop for i from 0 to 100 for s = (make-string i :initial-element #\~) for format-string = (format nil "~~~D~~" i) for fn = (eval `(formatter ,format-string)) for s2 = (formatter-call-to-string fn) unless (string= s s2) collect (list i s s2)) nil) (def-format-test format.~.3 "~v~" (0) "") (deftest format.~.4 (loop for i from 0 to 100 for s = (make-string i :initial-element #\~) for s2 = (format nil "~V~" i) unless (string= s s2) collect (list i s s2)) nil) (deftest formatter.~.4 (let ((fn (formatter "~v~"))) (loop for i from 0 to 100 for s = (make-string i :initial-element #\~) for s2 = (formatter-call-to-string fn i) unless (string= s s2) collect (list i s s2))) nil) (deftest format.~.5 (loop for i from 0 to (min (- call-arguments-limit 3) 100) for s = (make-string i :initial-element #\~) for args = (make-list i) for s2 = (apply #'format nil "~#~" args) unless (string= s s2) collect (list i s s2)) nil) (deftest formatter.~.5 (let ((fn (formatter "~#~"))) (loop for i from 0 to (min (- call-arguments-limit 3) 100) for s = (make-string i :initial-element #\~) for args = (make-list i) for s2 = (with-output-to-string (stream) (assert (equal (apply fn stream args) args))) unless (string= s s2) collect (list i s s2))) nil) gcl27-2.7.0/ansi-tests/format-underscore.lsp000066400000000000000000000146011454061450500207150ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 4 03:36:50 2004 ;;;; Contains: Tests of the ~_ format directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-ppblock-test format._.1 (progn (dotimes (i 2) (write "A ") (pprint-newline :fill)) ;; (write "B ") (pprint-newline :linear) (format t "B ~_") (dotimes (i 3) (write "A ") (pprint-newline :fill))) "A A B A A A " :margin 10) (def-ppblock-test format._.2 (progn (dotimes (i 2) (write "A ") (pprint-newline :fill)) ;; (write "B ") (pprint-newline :linear) (format t "B ~_") (dotimes (i 2) (write "C ") (pprint-newline :fill)) (format t "D ~_") (dotimes (i 3) (write "A ") (pprint-newline :fill))) "A A B C C D A A A " :margin 10) (def-ppblock-test format._.3 (format t "A ~_A ~_A ~_A ~_") "A A A A " :margin 10) (def-ppblock-test format._.4 (format t "A ~_A ~_A ~_A ~_") "A A A A " :margin 10 :miser 10) (def-ppblock-test format._.5 (format t "A ~_A ~_A ~_A ~_A ~_A ~_A ~_A ~_A ~_A ~_") "A A A A A A A A A A " :margin 10 :pretty nil) (def-ppblock-test format._.6 (dotimes (i 4) (format t "A ~_")) "A A A A " :margin 10) (def-ppblock-test format._.7 (format t "A ~_A ~_A ~_A ~_~%A ~_A ~_A ~_A ~_") "A A A A A A A A " :margin 10) (def-ppblock-test format._.8 (progn (pprint-logical-block (*standard-output* nil) (format t "A ~_A ~_A ~_A ~_")) (format t "~_") (pprint-logical-block (*standard-output* nil) (format t "A ~_A ~_A ~_A ~_"))) "A A A A A A A A " :margin 10) (deftest format._.9 (with-output-to-string (s) (with-standard-io-syntax (let ((*print-readably* nil) (*print-escape* nil) (*print-pretty* t) (*print-right-margin* 4) (*print-miser-width* nil)) (format s "A ~_A ~_A ~_A ~_A ~_")))) "A A A A A ") (deftest formatter._.9 (with-standard-io-syntax (let ((*print-readably* nil) (*print-escape* nil) (*print-pretty* t) (*print-right-margin* 4) (*print-miser-width* nil)) (formatter-call-to-string (formatter "A ~_A ~_A ~_A ~_A ~_")))) "A A A A A ") ;;; miser (def-ppblock-test format.@_.1 (format t "A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_") "A A A A A A A A A A " :margin 10) (def-ppblock-test format.@_.2 (format t "A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_") "A A A A A A A A A A " :margin 10 :miser 0) (def-ppblock-test format.@_.3 (format t "A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_") "A A A A A A A A A A " :margin 10 :miser 9) (def-ppblock-test format.@_.4 (format t "A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_") "A A A A A A A A A A " :margin 10 :miser 10) (def-ppblock-test format.@_.5 (format t "A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_") "A A A A A A A A A A " :margin 10 :miser 10 :pretty nil) (def-ppblock-test format.@_.6 (format t "~%A~@_") " A " :margin 20 :miser 20) (def-ppblock-test format.@_.7 (format t "~@_A~%") " A " :margin 20 :miser 20) (def-ppblock-test format.@_.8 (progn (format t "AAAA ~_") (pprint-logical-block (*standard-output* nil) (format t "A ~@_A ~@_A ~@_A ~@_"))) "AAAA A A A A " :margin 10 :miser 8) (def-ppblock-test format.@_.9 (progn (format t "AAAA ~:@_") (pprint-logical-block (*standard-output* nil) (format t "A ~@_A ~@_A ~@_A ~@_"))) "AAAA A A A A " :margin 10 :miser 8) (deftest format.@_.10 (with-output-to-string (s) (with-standard-io-syntax (let ((*print-readably* nil) (*print-escape* nil) (*print-pretty* t) (*print-right-margin* 4) (*print-miser-width* 4)) (format s "A ~@_A ~@_A ~@_A ~@_A ~@_")))) "A A A A A ") (deftest formatter.@_.10 (with-standard-io-syntax (let ((*print-readably* nil) (*print-escape* nil) (*print-pretty* t) (*print-right-margin* 4) (*print-miser-width* 4)) (formatter-call-to-string (formatter "A ~@_A ~@_A ~@_A ~@_A ~@_")))) "A A A A A ") ;;; fill (def-ppblock-test format.\:_.1 (format t "A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_") "A A A A A A A A A A " :margin 10) (def-ppblock-test format.\:_.2 (format t "A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_") "A A A A A A A A A A " :margin 6) (def-ppblock-test format.\:_.3 (format t "A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_") "A A A A A A A A A A " :margin 7) (def-ppblock-test format.\:_.4 (format t "A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_") "A A A A A A A A A A " :margin 10 :miser 9) (def-ppblock-test format.\:_.5 (format t "A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_") "A A A A A A A A A A " :margin 10 :miser 10) (def-ppblock-test format.\:_.6 (format t "~W~W~:_~W~W~:_~W~W~:_~W~W~:_~W~W~:_" '(A B) #\Space '(A B) #\Space '(A B) #\Space '(A B) #\Space '(A B) #\Space) "(A B) (A B) (A B) (A B) (A B) " :margin 12) (deftest format.\:_.7 (with-output-to-string (s) (with-standard-io-syntax (let ((*print-readably* nil) (*print-escape* nil) (*print-right-margin* 4) (*print-pretty* t) (*print-miser-width* nil)) (format s "A ~:_A ~:_A ~:_A ~:_A ~:_")))) "A A A A A ") (deftest formatter.\:_.7 (with-standard-io-syntax (let ((*print-readably* nil) (*print-escape* nil) (*print-right-margin* 4) (*print-pretty* t) (*print-miser-width* nil)) (formatter-call-to-string (formatter "A ~:_A ~:_A ~:_A ~:_A ~:_")))) "A A A A A ") ;;; mandatory (def-ppblock-test format.\:@_.1 (format t "A ~:@_A ~:@_A ~:@_A ~:@_") "A A A A ") (def-ppblock-test format.\:@_.2 (format t "A ~@:_A ~@:_A ~@:_A ~@:_") "A A A A " :margin 10) (def-ppblock-test format.\:@_.3 (format t "A ~@:_A ") "A A " :margin 1) (def-ppblock-test format.\:@_.4 (format t "A ~@:_A ~@:_A ~@:_A ~@:_") "A A A A " :pretty nil) (deftest format.\:@_.5 (with-output-to-string (s) (with-standard-io-syntax (let ((*print-readably* nil) (*print-escape* nil) (*print-pretty* t) (*print-right-margin* 4) (*print-miser-width* nil)) (format s "A ~:@_A ~:@_A ~:@_A ~:@_A ~:@_")))) "A A A A A ") (deftest formatter.\:@_.5 (with-standard-io-syntax (let ((*print-readably* nil) (*print-escape* nil) (*print-pretty* t) (*print-right-margin* 4) (*print-miser-width* nil)) (formatter-call-to-string (formatter "A ~:@_A ~:@_A ~:@_A ~:@_A ~:@_")))) "A A A A A ") gcl27-2.7.0/ansi-tests/format-x.lsp000066400000000000000000000376451454061450500170300ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 1 06:51:34 2004 ;;;; Contains: Tests of ~X format directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest format.x.1 (let ((fn (formatter "~x"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for s1 = (format nil "~X" i) for s2 = (formatter-call-to-string fn i) for j = (let ((*read-base* 16)) (read-from-string s1)) repeat 1000 when (or (/= i j) (not (string= s1 s2)) (find #\. s1) (find #\+ s1) (loop for c across s1 thereis (and (not (eql c #\-)) (not (digit-char-p c 16))))) collect (list i s1 j s2)))) nil) (deftest format.x.2 (let ((fn (formatter "~@X"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for s1 = (format nil "~@x" i) for s2 = (formatter-call-to-string fn i) for j = (let ((*read-base* 16)) (read-from-string s1)) repeat 1000 when (or (/= i j) (not (string= s1 s2)) (find #\. s1) ;; (find #\+ s1) (loop for c across s1 thereis (and (not (find c "-+")) (not (digit-char-p c 16))))) collect (list i s1 j s2)))) nil) (deftest format.x.3 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~x" i) for fmt = (format nil "~~~d~c" mincol (random-from-seq "xX")) for s2 = (format nil fmt i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (list i mincol s1 s2 pos))) nil) (deftest formatter.x.3 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~x" i) for fmt = (format nil "~~~d~c" mincol (random-from-seq "xX")) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn i) for pos = (search s1 s2) repeat 100 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (list i mincol s1 s2 pos))) nil) (deftest format.x.4 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~@X" i) for fmt = (format nil "~~~d@~c" mincol (random-from-seq "xX")) for s2 = (format nil fmt i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (and (>= i 0) (not (eql (elt s1 0) #\+))) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (list i mincol s1 s2 pos))) nil) (deftest formatter.x.4 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~@X" i) for fmt = (format nil "~~~d@~c" mincol (random-from-seq "xX")) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn i) for pos = (search s1 s2) repeat 100 when (or (null pos) (and (>= i 0) (not (eql (elt s1 0) #\+))) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (list i mincol s1 s2 pos))) nil) (deftest format.x.5 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~x" i) for fmt = (format nil "~~~d,'~c~c" mincol padchar (random-from-seq "xX")) for s2 = (format nil fmt i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 pos))) nil) (deftest formatter.x.5 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~x" i) for fmt = (format nil "~~~d,'~c~c" mincol padchar (random-from-seq "xX")) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn i) for pos = (search s1 s2) repeat 100 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 pos))) nil) (deftest format.x.6 (let ((fn (formatter "~V,vx"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~x" i) for s2 = (format nil "~v,vX" mincol padchar i) for s3 = (formatter-call-to-string fn mincol padchar i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (not (string= s2 s3)) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 s3 pos)))) nil) (deftest format.x.7 (let ((fn (formatter "~v,V@X"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~@x" i) for s2 = (format nil "~v,v@x" mincol padchar i) for s3 = (formatter-call-to-string fn mincol padchar i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (not (string= s2 s3)) (and (>= i 0) (not (eql (elt s1 0) #\+))) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 s3 pos)))) nil) ;;; Comma tests (deftest format.x.8 (let ((fn (formatter "~:X"))) (loop for i from -999 to 999 for s1 = (format nil "~x" i) for s2 = (format nil "~:x" i) for s3 = (formatter-call-to-string fn i) unless (and (string= s1 s2) (string= s2 s3)) collect (list i s1 s2 s3))) nil) (deftest format.x.9 (let ((fn (formatter "~:x"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = #\, for s1 = (format nil "~x" i) for s2 = (format nil "~:X" i) for s3 = (formatter-call-to-string fn i) repeat 1000 unless (and (string= s1 (remove commachar s2)) (string= s2 s3) (not (eql (elt s2 0) commachar)) (or (>= i 0) (not (eql (elt s2 1) commachar))) (let ((len (length s2)) (ci+1 4)) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (find (elt s2 i) "0123456789ABCDEF" :test #'char-equal))))) collect (list x i commachar s1 s2 s3)))) nil) (deftest format.x.10 (let ((fn (formatter "~,,V:x"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for s1 = (format nil "~x" i) for s2 = (format nil "~,,v:X" commachar i) for s3 = (formatter-call-to-string fn commachar i) repeat 1000 unless (and (eql (elt s1 0) (elt s2 0)) (string= s2 s3) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 4) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2 s3)))) nil) (deftest format.x.11 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for s1 = (format nil "~x" i) for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "xX")) for s2 = (format nil fmt i) repeat 1000 unless (and (eql (elt s1 0) (elt s2 0)) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 4) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2))) nil) (deftest formatter.x.11 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for s1 = (format nil "~x" i) for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "xX")) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn i) repeat 100 unless (and (eql (elt s1 0) (elt s2 0)) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 4) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2))) nil) (deftest format.x.12 (let ((fn (formatter "~,,v,v:X"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for commaint = (1+ (random 20)) for s1 = (format nil "~x" i) for s2 = (format nil "~,,v,v:X" commachar commaint i) for s3 = (formatter-call-to-string fn commachar commaint i) repeat 1000 unless (and (eql (elt s1 0) (elt s2 0)) (string= s2 s3) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 (1+ commaint)) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2 s3)))) nil) (deftest format.x.13 (let ((fn (formatter "~,,v,V:@x"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for commaint = (1+ (random 20)) for s1 = (format nil "~@x" i) for s2 = (format nil "~,,v,v:@x" commachar commaint i) for s3 = (formatter-call-to-string fn commachar commaint i) repeat 1000 unless (and (eql (elt s1 0) (elt s2 0)) (eql (elt s1 1) (elt s2 1)) (string= s2 s3) (let ((len (length s2)) (ci+1 (1+ commaint)) (j 1)) (loop for i from 2 below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2 s3)))) nil) ;;; NIL arguments (def-format-test format.x.14 "~vx" (nil #x100) "100") (def-format-test format.x.15 "~6,vX" (nil #x100) " 100") (def-format-test format.x.16 "~,,v:x" (nil #x12345) "12,345") (def-format-test format.x.17 "~,,'*,v:x" (nil #x12345) "12*345") ;;; When the argument is not an integer, print as if using ~A and base 10 (deftest format.x.18 (let ((fn (formatter "~x"))) (loop for x in *mini-universe* for s1 = (format nil "~x" x) for s2 = (let ((*print-base* 16)) (format nil "~A" x)) for s3 = (formatter-call-to-string fn x) unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) collect (list x s1 s2 s3))) nil) (deftest format.x.19 (let ((fn (formatter "~:x"))) (loop for x in *mini-universe* for s1 = (format nil "~:x" x) for s2 = (let ((*print-base* 16)) (format nil "~A" x)) for s3 = (formatter-call-to-string fn x) unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) collect (list x s1 s2 s3))) nil) (deftest format.x.20 (let ((fn (formatter "~@x"))) (loop for x in *mini-universe* for s1 = (format nil "~@x" x) for s2 = (let ((*print-base* 16)) (format nil "~A" x)) for s3 = (formatter-call-to-string fn x) unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) collect (list x s1 s2 s3))) nil) (deftest format.x.21 (let ((fn (formatter "~:@x"))) (loop for x in *mini-universe* for s1 = (let ((*print-base* 16)) (format nil "~A" x)) for s2 = (format nil "~@:x" x) for s3 = (formatter-call-to-string fn x) for s4 = (let ((*print-base* 16)) (format nil "~A" x)) unless (or (string/= s1 s4) (integerp x) (and (string= s1 s2) (string= s2 s3))) collect (list x s1 s2 s3))) nil) ;;; Must add tests for non-integers when the parameters ;;; are specified, but it's not clear what the meaning is. ;;; Does mincol apply to the ~A equivalent? What about padchar? ;;; Are comma-char and comma-interval always ignored? ;;; # arguments (deftest format.x.22 (apply #'values (let ((fn (formatter "~#X")) (n #x1b3fe)) (loop for i from 0 to 10 for args = (make-list i) for s = (apply #'format nil "~#x" n args) for s2 = (with-output-to-string (stream) (assert (equal (apply fn stream n args) args))) do (assert (string= s s2)) collect (string-upcase s)))) "1B3FE" "1B3FE" "1B3FE" "1B3FE" "1B3FE" " 1B3FE" " 1B3FE" " 1B3FE" " 1B3FE" " 1B3FE" " 1B3FE") (deftest format.x.23 (apply #'values (let ((fn (formatter "~,,,#:X")) (n #x1234567890)) (loop for i from 0 to 10 for args = (make-list i) for s = (apply #'format nil "~,,,#:x" n args) for s2 = (with-output-to-string (stream) (assert (equal (apply fn stream n args) args))) do (assert (string= s s2)) collect s))) "1,2,3,4,5,6,7,8,9,0" "12,34,56,78,90" "1,234,567,890" "12,3456,7890" "12345,67890" "1234,567890" "123,4567890" "12,34567890" "1,234567890" "1234567890" "1234567890") (deftest format.x.24 (apply #'values (let ((fn (formatter "~,,,#@:X")) (n #x1234567890)) (loop for i from 0 to 10 for args = (make-list i) for s = (apply #'format nil "~,,,#@:X" n args) for s2 = (with-output-to-string (stream) (assert (equal (apply fn stream n args) args))) do (assert (string= s s2)) collect s))) "+1,2,3,4,5,6,7,8,9,0" "+12,34,56,78,90" "+1,234,567,890" "+12,3456,7890" "+12345,67890" "+1234,567890" "+123,4567890" "+12,34567890" "+1,234567890" "+1234567890" "+1234567890") (def-format-test format.x.25 "~+10x" (#x1234) " 1234") (def-format-test format.x.26 "~+10@X" (#x1234) " +1234") (def-format-test format.x.27 "~-1X" (#x1234) "1234") (def-format-test format.x.28 "~-1000000000000000000x" (#x1234) "1234") (def-format-test format.x.29 "~vx" ((1- most-negative-fixnum) #x1234) "1234") ;;; Randomized test (deftest format.x.30 (let ((fn (formatter "~v,v,v,vx"))) (loop for mincol = (and (coin) (random 50)) for padchar = (and (coin) (random-from-seq +standard-chars+)) for commachar = (and (coin) (random-from-seq +standard-chars+)) for commaint = (and (coin) (1+ (random 10))) for k = (ash 1 (+ 2 (random 30))) for x = (- (random (+ k k)) k) for fmt = (concatenate 'string (if mincol (format nil "~~~d," mincol) "~,") (if padchar (format nil "'~c," padchar) ",") (if commachar (format nil "'~c," commachar) ",") (if commaint (format nil "~dx" commaint) "x")) for s1 = (format nil fmt x) for s2 = (format nil "~v,v,v,vx" mincol padchar commachar commaint x) for s3 = (formatter-call-to-string fn mincol padchar commachar commaint x) repeat 2000 unless (and (string= s1 s2) (string= s2 s3)) collect (list mincol padchar commachar commaint fmt x s1 s2 s3))) nil)gcl27-2.7.0/ansi-tests/format.lsp000066400000000000000000000005071454061450500165460ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Feb 23 05:08:17 2004 ;;;; Contains: Tests of FORMAT (in-package :cl-test) (defun def-format-test (name args result) `(deftest ,name (equalt (with-standard-io-syntax (with-output-to-string (s) (format s ,@args))) result) t)) gcl27-2.7.0/ansi-tests/formatter-c.lsp000066400000000000000000000075241454061450500175070ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Dec 5 14:32:46 2004 ;;;; Contains: Tests of FORMATTER on the C directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest formatter.c.1 (let ((fn (formatter "~C"))) (loop for c across +standard-chars+ when (let* (n (ignored (loop for i below (random 5) collect i)) (s (with-output-to-string (stream) (setq n (multiple-value-list (apply fn stream c ignored)))))) (unless (and (string= s (string c)) (equal n (list ignored))) (list s ignored n))) collect it)) nil) (deftest formatter.c.1a (let ((fn (formatter "~c"))) (loop with count = 0 for i from 0 below (min #x10000 char-code-limit) for c = (code-char i) for ignored = (loop for j below (random 10) collect j) when (and c (eql (char-code c) (char-int c)) (let* (n (s (with-output-to-string (stream) (setq n (multiple-value-list (apply fn stream c ignored)))))) (unless (and (string= s (string c)) (equal n (list ignored))) (incf count) (list i c s ignored n)))) collect it when (> count 100) collect "count limit exceeded" and do (loop-finish))) nil) (deftest formatter.c.2 (let ((fn (formatter "~:C"))) (loop for c across +standard-chars+ when (and (graphic-char-p c) (not (eql c #\Space)) (let* (n (ignored (loop for i below (random 5) collect i)) (s (with-output-to-string (stream) (setq n (multiple-value-list (apply fn stream c ignored)))))) (unless (and (string= s (string c)) (equal n (list ignored))) (list s ignored n)))) collect it)) nil) (deftest formatter.c.2a (let ((fn (formatter "~:C"))) (loop with count = 0 for i from 0 below (min #x10000 char-code-limit) for c = (code-char i) for ignored = (loop for j below (random 10) collect j) when (and c (eql (char-code c) (char-int c)) (graphic-char-p c) (not (eql c #\Space)) (let* (n (s (with-output-to-string (stream) (setq n (multiple-value-list (apply fn stream c ignored)))))) (unless (and (string= s (string c)) (equal n (list ignored))) (incf count) (list i c s ignored n)))) collect it when (> count 100) collect "count limit exceeded" and do (loop-finish))) nil) (deftest formatter.c.4 (let ((fn (formatter "~:C")) (n nil)) (loop for c across +standard-chars+ for s = (with-output-to-string (stream) (setq n (multiple-value-list (funcall fn stream c)))) unless (or (graphic-char-p c) (and (string= s (char-name c)) (equal n '(nil)))) collect (list c (char-name c) s))) nil) (deftest formatter.c.4a (let ((fn (formatter "~:C")) (n nil)) (loop for i from 0 below (min #x10000 char-code-limit) for c = (code-char i) for s = (and c (with-output-to-string (stream) (setq n (multiple-value-list (funcall fn stream c 5))))) unless (or (not c) (graphic-char-p c) (and (string= s (char-name c)) (equal n '((5))))) collect (list c (char-name c) s))) nil) (deftest formatter.c.5 (let ((fn (formatter "~@C")) (n nil)) (loop for c across +standard-chars+ for s = (with-output-to-string (stream) (setq n (multiple-value-list (funcall fn stream c 1 2 3)))) for c2 = (read-from-string s) unless (and (eql c c2) (equal n '((1 2 3)))) collect (list c s c2))) nil) (deftest formatter.c.6 (let ((n nil) (fn (formatter "~@:c"))) (loop for c across +standard-chars+ for s1 = (with-output-to-string (stream) (setf n (multiple-value-list (funcall fn stream c 1 2)))) for s2 = (format nil "~:@C" c) unless (and (eql (search s1 s2) 0) (equal n '((1 2)))) collect (list c s1 s2 n))) nil) gcl27-2.7.0/ansi-tests/fresh-line.lsp000066400000000000000000000036001454061450500173070ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 18 20:41:18 2004 ;;;; Contains: Tests of FRESH-LINE (in-package :cl-test) (deftest fresh-line.1 (let (result) (values (with-output-to-string (*standard-output*) (write-char #\a) (setq result (notnot (fresh-line)))) result)) #.(concatenate 'string "a" (string #\Newline)) t) (deftest fresh-line.2 (let (result) (values (with-output-to-string (s) (write-char #\a s) (setq result (notnot (fresh-line s)))) result)) #.(concatenate 'string "a" (string #\Newline)) t) (deftest fresh-line.3 (with-output-to-string (s) (write-char #\x s) (fresh-line s) (fresh-line s) (write-char #\y s)) #.(concatenate 'string "x" (string #\Newline) "y")) (deftest fresh-line.4 (let (result) (values (with-output-to-string (*standard-output*) (setq result (multiple-value-list (fresh-line)))) result)) "" (nil)) (deftest fresh-line.5 (let (result) (values (with-output-to-string (s) (write-char #\Space s) (setq result (list (multiple-value-list (notnot-mv (fresh-line s))) (multiple-value-list (fresh-line s)) (multiple-value-list (fresh-line s))))) result)) " " ((t) (nil) (nil))) (deftest fresh-line.6 (with-output-to-string (os) (let ((*terminal-io* (make-two-way-stream *standard-input* os))) (write-char #\a t) (fresh-line t) (finish-output t))) #.(concatenate 'string (string #\a) (string #\Newline))) (deftest fresh-line.7 (with-output-to-string (*standard-output*) (write-char #\a nil) (terpri nil)) #.(concatenate 'string (string #\a) (string #\Newline))) ;;; Error tests (deftest fresh-line.error.1 (signals-error (with-output-to-string (s) (fresh-line s nil)) program-error) t) gcl27-2.7.0/ansi-tests/fround-aux.lsp000066400000000000000000000010671454061450500173500ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Aug 21 16:08:55 2003 ;;;; Contains: Aux. functions for testing FROUND (in-package :cl-test) (defun fround.1-fn () (loop for n = (- (random 200000) 100000) for d = (1+ (random 10000)) for vals = (multiple-value-list (fround n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 100 unless (and (eql (length vals) 2) (floatp q) (= n n2) (integerp r) (<= (- (/ d 2)) r (/ d 2)) (or (/= (abs r) (/ d 2)) (evenp (floor q)))) collect (list n d q r n2))) gcl27-2.7.0/ansi-tests/fround.lsp000066400000000000000000000070231454061450500165530ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Aug 21 16:07:59 2003 ;;;; Contains: Tests of FROUND (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "fround-aux.lsp") ;;; Error tests (deftest fround.error.1 (signals-error (fround) program-error) t) (deftest fround.error.2 (signals-error (fround 1.0 1 nil) program-error) t) ;;; Non-error tests (deftest fround.1 (fround.1-fn) nil) (deftest fround.10 (loop for x in (remove-if #'zerop *reals*) for (q r) = (multiple-value-list (fround x x)) unless (and (floatp q) (if (floatp x) (eql q (float 1 x)) (= q 1)) (zerop r) (if (floatp x) (eql r (float 0 x)) (= r 0))) collect x) nil) (deftest fround.11 (loop for x in (remove-if-not #'floatp (remove-if #'zerop *reals*)) for (q r) = (multiple-value-list (fround (- x) x)) unless (and (floatp q) (if (floatp x) (eql q (float -1 x)) (= q -1)) (zerop r) (if (floatp x) (eql r (float 0 x)) (= r 0))) collect x) nil) (deftest fround.12 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 0.5s0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (fround x)) unless (and (eql q (coerce i 'short-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest fround.13 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 0.5s0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (fround x)) unless (and (eql q (coerce i 'short-float)) (eql r (- rrad))) collect (list i x q r))) nil) (deftest fround.14 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 0.5f0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (fround x)) unless (and (eql q (coerce i 'single-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest fround.15 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 0.5f0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (fround x)) unless (and (eql q (coerce i 'single-float)) (eql r (- rrad))) collect (list i x q r))) nil) (deftest fround.16 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 0.5d0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (fround x)) unless (and (eql q (coerce i 'double-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest fround.17 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 0.5d0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (fround x)) unless (and (eql q (coerce i 'double-float)) (eql r (- rrad))) collect (list i x q r))) nil) (deftest fround.18 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 0.5l0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (fround x)) unless (and (eql q (coerce i 'long-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest fround.19 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 0.5l0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (fround x)) unless (and (eql q (coerce i 'long-float)) (eql r (- rrad))) collect (list i x q r))) nil) gcl27-2.7.0/ansi-tests/ftruncate-aux.lsp000066400000000000000000000010411454061450500200360ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 20 06:37:01 2003 ;;;; Contains: Aux. functions for testing FTRUNCATE (in-package :cl-test) (defun ftruncate.1-fn () (loop for n = (- (random 200000) 100000) for d = (1+ (random 10000)) for vals = (multiple-value-list (ftruncate n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 100 unless (and (eql (length vals) 2) (floatp q) (= n n2) (integerp r) (if (>= n 0) (< -1 r d) (< -1 (- r) d))) collect (list n d q r n2))) gcl27-2.7.0/ansi-tests/ftruncate.lsp000066400000000000000000000073321454061450500172540ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 20 06:36:35 2003 ;;;; Contains: Tests of FTRUNCATE (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "ftruncate-aux.lsp") ;;; Error tests (deftest ftruncate.error.1 (signals-error (ftruncate) program-error) t) (deftest ftruncate.error.2 (signals-error (ftruncate 1.0 1 nil) program-error) t) ;;; Non-error tests (deftest ftruncate.1 (ftruncate.1-fn) nil) (deftest ftruncate.10 (loop for x in (remove-if #'zerop *reals*) for (q r) = (multiple-value-list (ftruncate x x)) unless (and (floatp q) (if (floatp x) (eql q (float 1 x)) (= q 1)) (zerop r) (if (floatp x) (eql r (float 0 x)) (= r 0))) collect x) nil) (deftest ftruncate.11 (loop for x in (remove-if-not #'floatp (remove-if #'zerop *reals*)) for (q r) = (multiple-value-list (ftruncate (- x) x)) unless (and (floatp q) (if (floatp x) (eql q (float -1 x)) (= q -1)) (zerop r) (if (floatp x) (eql r (float 0 x)) (= r 0))) collect x) nil) (deftest ftruncate.12 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (ftruncate x)) unless (and (eql q (coerce i 'short-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest ftruncate.13 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (ftruncate x)) unless (and (eql q (coerce (1- i) 'short-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest ftruncate.14 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (ftruncate x)) unless (and (eql q (coerce i 'single-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest ftruncate.15 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (ftruncate x)) unless (and (eql q (coerce (1- i) 'single-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest ftruncate.16 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (ftruncate x)) unless (and (eql q (coerce i 'double-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest ftruncate.17 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (ftruncate x)) unless (and (eql q (coerce (1- i) 'double-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest ftruncate.18 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (ftruncate x)) unless (and (eql q (coerce i 'long-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest ftruncate.19 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (ftruncate x)) unless (and (eql q (coerce (1- i) 'long-float)) (eql r rrad)) collect (list i x q r))) nil) ;;; To add: tests that involve adding/subtracting EPSILON constants ;;; (suitably scaled) to floated integers. gcl27-2.7.0/ansi-tests/funcall.lsp000066400000000000000000000042211454061450500166770ustar00rootroot00000000000000;-*- 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 (signals-error (funcall 'quote 1) undefined-function :name quote) t) (deftest funcall.error.2 (signals-error (funcall 'progn 1) undefined-function :name progn) t) ;;; FUNCALL should throw an UNDEFINED-FUNCTION condition when ;;; called on a symbol with a global definition as a macro (deftest funcall.error.3 (signals-error (funcall 'defconstant '(defconstant x 10)) undefined-function :name defconstant) t) (deftest funcall.error.4 (signals-error (funcall) program-error) t) (deftest funcall.error.5 (signals-error (funcall #'cons) program-error) t) (deftest funcall.error.6 (signals-error (funcall #'cons 1) program-error) t) (deftest funcall.error.7 (signals-type-error x 'a (funcall #'car x)) t) gcl27-2.7.0/ansi-tests/function-lambda-expression.lsp000066400000000000000000000021211454061450500225100ustar00rootroot00000000000000;-*- 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) ;;; Verify that it doesn't barf on generic functions (deftest function-lambda-expression.3 (length (multiple-value-list (function-lambda-expression #'meaningless-user-generic-function-for-universe))) 3) (deftest function-lambda-expression.order.1 (let ((i 0)) (function-lambda-expression (progn (incf i) #'cons)) i) 1) (deftest function-lambda-expression.error.1 (signals-error (function-lambda-expression) program-error) t) (deftest function-lambda-expression.error.2 (signals-error (function-lambda-expression #'cons nil) program-error) t) gcl27-2.7.0/ansi-tests/function.lsp000066400000000000000000000115101454061450500170770ustar00rootroot00000000000000;-*- 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) (report-and-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 (check-predicate (typef '(not (and (or number character symbol cons array) function)))) 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) ;;; Tests of FUNCTION type specifiers (deftest function.14 (flet ((%f () nil)) (declare (optimize safety debug)) (let ((f #'%f)) (declare (type (function () null) f)) (funcall f))) nil) (deftest function.15 (flet ((%f (x) (declare (ignore x)) nil)) (declare (ftype (function (nil) nil) %f)) :good) :good) (deftest function.16 (flet ((%f (x) (declare (ignore x)) nil)) (declare (ftype (function (t) null) %f)) (values (%f 'a) (locally (declare (ftype (function (integer) t) %f)) (%f 10)) (%f 'b))) nil nil nil) (deftest function.17 (flet ((%f (&optional x) x)) (declare (ftype (function (&optional integer) t) %f)) (values (%f) (%f 10) (%f) (%f (1+ most-positive-fixnum)))) nil 10 nil #.(1+ most-positive-fixnum)) (deftest function.18 (flet ((%f (&rest x) x)) (declare (ftype (function (&rest symbol) t) %f)) (values (%f) (%f 'a) (%f 'a 'b 'c))) () (a) (a b c)) (deftest function.19 (flet ((%f (&key foo bar) (list foo bar))) (declare (ftype (function (&key (:foo t) (:bar t)) list) %f)) (values (%f) (%f :foo 1) (%f :foo 1 :foo 2) (%f :bar 'a) (%f :bar 'a :bar 'b) (%f :foo 'x :bar 'y) (%f :bar 'x :foo 'y) (%f :bar 'x :foo 'y :bar 'z :foo 'w) )) (nil nil) (1 nil) (1 nil) (nil a) (nil a) (x y) (y x) (y x)) (deftest function.20 (flet ((%f (&key foo) foo)) (declare (ftype (function (&key (:foo t) (:allow-other-keys t)) t) %f)) (values (%f) (%f :foo 'a) (%f :allow-other-keys nil) (%f :allow-other-keys t :foo 'z))) nil a nil z) (deftest function.21 (flet ((%f (&key foo &allow-other-keys) foo)) (declare (ftype (function (&key (:foo integer)) t) %f)) (values (%f) (%f :foo 123))) nil 123) (deftest function.22 (flet ((%f (&key foo &allow-other-keys) foo)) (declare (ftype (function (&key (:foo integer) (:bar t)) t) %f)) (values (%f) (%f :foo 123) (%f :bar 'x) (%f :foo 12 :bar 'y))) nil 123 nil 12) (deftest function.23 (flet ((%f (&key foo &allow-other-keys) foo)) (declare (ftype (function (&key (:foo integer) &allow-other-keys) t) %f)) (values (%f) (%f :foo 123) (%f :bar 'x) (%f :foo 12 :bar 'y))) nil 123 nil 12) (deftest function.24 (flet ((%f (&rest r &key foo bar) (list r foo bar))) (declare (ftype (function (&rest symbol &key (:foo t) (:bar t)) list) %f)) (values (%f) (%f :foo 'a) (%f :bar 'b) (%f :bar 'd :foo 'c))) (nil nil nil) ((:foo a) a nil) ((:bar b) nil b) ((:bar d :foo c) c d)) gcl27-2.7.0/ansi-tests/functionp.lsp000066400000000000000000000040151454061450500172610ustar00rootroot00000000000000;-*- 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) (report-and-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 (check-predicate #'(lambda (x) (not (and (or (numberp x) (characterp x) (symbolp x) (consp x) (typep x 'array)) (functionp x))))) nil) (deftest functionp.11 (flet ((%f () nil)) (functionp '%f)) nil) (deftest functionp.12 (flet ((%f () nil)) (not-mv (functionp #'%f))) nil) ;;; TODO: Add check-type-predicate test? (deftest functionp.order.1 (let ((i 0)) (values (notnot (functionp (progn (incf i) #'cons))) i)) t 1) (deftest functionp.error.1 (signals-error (functionp) program-error) t) (deftest functionp.error.2 (signals-error (functionp #'cons nil) program-error) t) gcl27-2.7.0/ansi-tests/gcd-aux.lsp000066400000000000000000000011061454061450500166020ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Sep 3 06:57:22 2003 ;;;; Contains: Aux. functions for testing GCD (in-package :cl-test) (defun my-gcd (x y) (cond ((< x 0) (my-gcd (- x) y)) ((< y 0) (my-gcd x (- y))) ((<= x y) (my-gcd* x y)) (t (my-gcd* y x)))) (defun my-gcd* (x y) ;;; 0 <= x <= y (loop (when (zerop x) (return y)) (psetq x (mod y x) y x))) (defun my-lcm (x y) (when (< x 0) (setf x (- x))) (when (< y 0) (setf y (- y))) (if (or (= x 0) (= y 0)) 0 (/ (* x y) (my-gcd x y)))) gcl27-2.7.0/ansi-tests/gcd.lsp000066400000000000000000000037261454061450500160210ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Sep 3 06:51:03 2003 ;;;; Contains: Tests of GCD (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "gcd-aux.lsp") ;;; Error tests (deftest gcd.error.1 (check-type-error #'gcd #'integerp) nil) ;;; Non-error tests (deftest gcd.1 (gcd) 0) (deftest gcd.2 (loop for i = (random-fixnum) for a = (abs i) repeat 10000 unless (and (eql a (gcd i)) (eql a (gcd 0 i))) collect i) nil) (deftest gcd.3 (loop for i = (random-from-interval 10000000000000000) for a = (abs i) repeat 10000 unless (and (eql a (gcd i)) (eql a (gcd i 0))) collect i) nil) (deftest gcd.4 (loop for i = (random-fixnum) for j = (random-fixnum) repeat 1000 unless (eql (my-gcd i j) (gcd i j)) collect (list i j)) nil) (deftest gcd.5 (let ((bound (ash 1 200))) (loop for i = (random-from-interval bound) for j = (random-from-interval bound) repeat 1000 unless (eql (my-gcd i j) (gcd i j)) collect (list i j))) nil) (deftest gcd.6 (loop for i = (random-fixnum) for j = (random-fixnum) for k = (random-fixnum) repeat 1000 unless (eql (my-gcd i (my-gcd j k)) (gcd i j k)) collect (list i j k)) nil) (deftest gcd.7 (loop for i = (random-fixnum) for j = (random-fixnum) for k = (random-fixnum) for n = (random-fixnum) repeat 1000 unless (eql (my-gcd (my-gcd i j) (my-gcd k n)) (gcd i j k n)) collect (list i j k)) nil) (deftest gcd.8 (loop for i from 1 to (min 256 (1- call-arguments-limit)) always (eql (apply #'gcd (make-list i :initial-element 1)) 1)) t) (deftest gcd.order.1 (let ((i 0) x y) (values (gcd (progn (setf x (incf i)) 15) (progn (setf y (incf i)) 25)) i x y)) 5 2 1 2) (deftest gcd.order.2 (let ((i 0) x y) (values (gcd (progn (setf x (incf i)) 0) (progn (setf y (incf i)) 10)) i x y)) 10 2 1 2) (deftest gcd.order.3 (let ((i 0)) (values (gcd (progn (incf i) 0)) i)) 0 1) gcl27-2.7.0/ansi-tests/gclload.lsp000066400000000000000000000025261454061450500166660ustar00rootroot00000000000000;;; Uncomment the next line to make MAKE-STRING and MAKE-SEQUENCE ;;; tests require that a missing :initial-element argument defaults ;;; to a single value, rather than leaving the string/sequence filled ;;; with arbitrary legal garbage. ;; (pushnew :ansi-tests-strict-initial-element *features*) #+allegro (setq *enclose-printer-errors* nil) ;;; Remove compiled files (let* ((fn (compile-file-pathname "doit.lsp")) (type (pathname-type fn)) (dir-pathname (make-pathname :name :wild :type type)) (files (directory dir-pathname))) (assert type) (assert (not (string-equal type "lsp"))) (mapc #'delete-file files)) (load "gclload1.lsp") (load "gclload2.lsp") #+allegro (progn (rt:disable-note :nil-vectors-are-strings) (rt:disable-note :standardized-package-nicknames) (rt:disable-note :type-of/strict-builtins) (rt:disable-note :assume-no-simple-streams) (rt:disable-note :assume-no-gray-streams)) ;#+gcl(si::use-fast-links nil) (in-package :cl-test) ;;; These two tests will misbehave if the tests are being ;;; invoked from a file that is being loaded, so remove them (when *load-pathname* (mapc #'regression-test:rem-test '(load-pathname.1 load-truename.1))) ;#+gcl(fpe::break-on-floating-point-exceptions :division-by-zero t :floating-point-overflow t :floating-point-underflow t) (time (regression-test:do-tests)) gcl27-2.7.0/ansi-tests/gclload1.lsp000066400000000000000000000026311454061450500167440ustar00rootroot00000000000000#+:ecl (si::package-lock (find-package "COMMON-LISP") nil) #+:armedbear (require 'pprint) #+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) #+lispworks (make-echo-stream *standard-input* *standard-output*) #+ecl (compile nil '(lambda () nil)) #+ecl (setq c:*suppress-compiler-warnings* t c:*suppress-compiler-notes* t) #+clisp (setq custom::*warn-on-floating-point-contagion* nil) (let (*load-verbose* *load-print* *compile-verbose* *compile-print*) (load "compile-and-load.lsp")) (let (*load-verbose* *load-print* *compile-verbose* *compile-print*) (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) (compile-and-load "ansi-aux-macros.lsp") (handler-bind #-sbcl () #+sbcl ((sb-ext:code-deletion-note #'muffle-warning)) (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) gcl27-2.7.0/ansi-tests/gclload2.lsp000066400000000000000000000026251454061450500167500ustar00rootroot00000000000000;;; 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 objects (load "load-objects.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 "load-hash-tables.lsp") ;;; Tests of packages (load "load-packages.lsp") ;;; Tests of numbers (section 12) (load "load-numbers.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 strings (load "load-strings.lsp") ;;; Tests for character functions (load "load-characters.lsp") ;;; Tests of pathnames (load "load-pathnames.lsp") ;;; Tests of file operations (load "load-files.lsp") ;;; Tests of streams (load "load-streams.lsp") ;;; Tests of the printer (load "load-printer.lsp") ;;; Tests of the reader (load "load-reader.lsp") ;;; Tests of system construction (load "load-system-construction.lsp") ;;; Tests of environment (load "load-environment.lsp") ;;; Miscellaneous tests, mostly tests that failed in random testing ;;; on various implementations (load "load-misc.lsp") gcl27-2.7.0/ansi-tests/gensym.lsp000066400000000000000000000056001454061450500165570ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jun 14 05:43:47 2003 ;;;; Contains: Tests of GENSYM (in-package :cl-test) ;;; 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)) (symbol-name (gensym))) #.(string '#:g1)) ;;; Gensym uses the string argument instead of the default (deftest gensym.4 (let ((*gensym-counter* 1327)) (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)) (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)) (symbol-name (gensym))) #.(string '#:g1234567890123456789012345678901234567890)) ;;; gensym increments Really Big values of *gensym-counter* (deftest gensym.11 (let ((*gensym-counter* 12345678901234567890123456789012345678901234567890)) (gensym) *gensym-counter*) 12345678901234567890123456789012345678901234567891) ;;; Gensym uses an integer argument instead of the counter (deftest gensym.12 (let ((*gensym-counter* 10)) (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)) (gensym 123) *gensym-counter*) 10) ;;; GENSYM counter is a non-negative integer (deftest gensym-counter.1 (and (integerp *gensym-counter*) (>= *gensym-counter* 0) t) t) ;;; 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 (check-type-error #'gensym #'(lambda (x) (typep x '(or string unsigned-byte)))) nil) (deftest gensym.error.7 (signals-error (gensym 10 'foo) program-error) t) (deftest gensym.error.8 (signals-error (locally (gensym t) t) type-error) t) (deftest gensym.error.9 (signals-error (gensym "FOO" nil) program-error) t) gcl27-2.7.0/ansi-tests/gentemp.lsp000066400000000000000000000074151454061450500167220ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jun 22 09:32:09 2003 ;;;; Contains: Tests of GENTEMP (in-package :cl-test) (deftest gentemp.1 (let* ((package-name "GENTEMP-TEST-PACKAGE")) (unwind-protect (let* ((pkg (make-package package-name :use nil)) (gcounter *gensym-counter*) (sym (let ((*package* pkg)) (gentemp))) (sym-name (symbol-name sym))) (values (=t gcounter *gensym-counter*) ;; wasn't changed (eqlt (aref sym-name 0) #\T) (notnot (every #'digit-char-p (subseq sym-name 1))) (eql (symbol-package sym) pkg) ;; Not external (do-external-symbols (s pkg t) (when (eql s sym) (return nil))) )) (delete-package package-name))) t t t t t) (deftest gentemp.2 (let* ((package-name "GENTEMP-TEST-PACKAGE")) (unwind-protect (let* ((pkg (make-package package-name :use nil)) (gcounter *gensym-counter*) (sym (let ((*package* pkg)) (gentemp "X"))) (sym-name (symbol-name sym))) (values (=t gcounter *gensym-counter*) ;; wasn't changed (eqlt (aref sym-name 0) #\X) (notnot (every #'digit-char-p (subseq sym-name 1))) (eql (symbol-package sym) pkg) ;; Not external (do-external-symbols (s pkg t) (when (eql s sym) (return nil))) )) (delete-package package-name))) t t t t t) (deftest gentemp.3 (let* ((package-name "GENTEMP-TEST-PACKAGE")) (unwind-protect (let* ((pkg (make-package package-name :use nil)) (gcounter *gensym-counter*) (sym (gentemp "X" package-name)) (sym-name (symbol-name sym))) (values (=t gcounter *gensym-counter*) ;; wasn't changed (eqlt (aref sym-name 0) #\X) (notnot (every #'digit-char-p (subseq sym-name 1))) (eql (symbol-package sym) pkg) ;; Not external (do-external-symbols (s pkg t) (when (eql s sym) (return nil))) )) (delete-package package-name))) t t t t t) (deftest gentemp.4 (let* ((package-name "GENTEMP-TEST-PACKAGE")) (unwind-protect (let* ((pkg (make-package package-name :use nil)) (gcounter *gensym-counter*) (sym (gentemp "" (make-symbol package-name))) (sym-name (symbol-name sym))) (values (=t gcounter *gensym-counter*) ;; wasn't changed (notnot (every #'digit-char-p sym-name)) (eql (symbol-package sym) pkg) ;; Not external (do-external-symbols (s pkg t) (when (eql s sym) (return nil))) )) (delete-package package-name))) t t t t) (deftest gentemp.5 (let* ((package-name "Z")) (safely-delete-package package-name) (unwind-protect (let* ((pkg (make-package package-name :use nil)) (gcounter *gensym-counter*) (sym (gentemp "Y" #\Z)) (sym-name (symbol-name sym))) (values (=t gcounter *gensym-counter*) ;; wasn't changed (eqlt (aref sym-name 0) #\Y) (notnot (every #'digit-char-p (subseq sym-name 1))) (eql (symbol-package sym) pkg) ;; Not external (do-external-symbols (s pkg t) (when (eql s sym) (return nil))) )) (delete-package package-name))) t t t t t) (deftest gentemp.6 (let* ((package-name "GENTEMP-TEST-PACKAGE")) (unwind-protect (let* ((*package* (make-package package-name :use nil)) (syms (loop repeat 100 collect (gentemp)))) (=t (length syms) (length (remove-duplicates syms)))) (delete-package package-name))) t) ;;; Error tests (deftest gentemp.error.1 (loop for x in *mini-universe* unless (or (stringp x) (eql (eval `(signals-type-error x ',x (gentemp x))) t)) collect x) nil) (deftest gentemp.error.2 (loop for x in *mini-universe* unless (or (typep x 'package) (string-designator-p x) (eql (eval `(signals-type-error x ',x (gentemp "T" x))) t)) collect x) nil) (deftest gentemp.error.3 (signals-error (gentemp "" *package* nil) program-error) t) gcl27-2.7.0/ansi-tests/get-internal-time.lsp000066400000000000000000000032141454061450500206010ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 8 20:28:21 2005 ;;;; Contains: Tests of GET-INTERNAL-REAL-TIME, GET-INTERNAL-RUN-TIME (in-package :cl-test) (deftest get-internal-real-time.1 (notnot-mv (typep (multiple-value-list (get-internal-real-time)) '(cons unsigned-byte null))) t) (deftest get-internal-real-time.2 (funcall (compile nil '(lambda () (let ((prev (get-internal-real-time))) (loop for next = (get-internal-real-time) repeat 100000 do (assert (>= next prev)) do (setf prev next)))))) nil) (deftest get-internal-real-time.error.1 (signals-error (get-internal-real-time nil) program-error) t) (deftest get-internal-real-time.error.2 (signals-error (get-internal-real-time :allow-other-keys t) program-error) t) ;;;;; (deftest get-internal-run-time.1 (notnot-mv (typep (multiple-value-list (get-internal-run-time)) '(cons unsigned-byte null))) t) (deftest get-internal-run-time.2 (funcall (compile nil '(lambda () (let ((prev (get-internal-run-time))) (loop for next = (get-internal-run-time) repeat 100000 do (assert (>= next prev)) do (setf prev next)))))) nil) (deftest get-internal-run-time.error.1 (signals-error (get-internal-run-time nil) program-error) t) (deftest get-internal-run-time.error.2 (signals-error (get-internal-run-time :allow-other-keys t) program-error) t) ;;; (deftest internal-time-units-per-second.1 (notnot-mv (constantp 'internal-time-units-per-second)) t) (deftest internal-time-units-per-second.2 (notnot-mv (typep internal-time-units-per-second '(integer 1))) t) gcl27-2.7.0/ansi-tests/get-macro-character.lsp000066400000000000000000000073071454061450500210730ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 2 15:54:27 2005 ;;;; Contains: Tests of GET-MACRO-CHARACTER (in-package :cl-test) (compile-and-load "reader-aux.lsp") (def-syntax-test get-macro-character.1 (loop for c across "()';\"`,#" collect (let ((vals (multiple-value-list (get-macro-character c)))) (list (=t (length vals) 2) (or (notnot (functionp (car vals))) (and (symbolp (car vals)) (notnot (fboundp (car vals))))) (notnot (cadr vals))))) ((t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t t))) (def-syntax-test get-macro-character.2 (loop for c across (concatenate 'string "abcdefghijklmnopqrstuvwxyz" "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "1234567890!@$%^&*_-+={[}]<>?/~") for (fn non-term-p) = (multiple-value-list (get-macro-character c)) unless (or (null fn) non-term-p) collect (list c fn non-term-p)) nil) (def-syntax-test get-macro-character.3 (loop for rt in (list nil *readtable* (copy-readtable)) collect (loop for c across "()';\"`,#" collect (let ((vals (multiple-value-list (get-macro-character c rt)))) (list (=t (length vals) 2) (or (notnot (functionp (car vals))) (and (symbolp (car vals)) (notnot (fboundp (car vals))))) (notnot (cadr vals)))))) (((t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t t)) ((t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t t)) ((t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t t)))) (def-syntax-test get-macro-character.4 (loop for rt in (list nil *readtable* (copy-readtable)) nconc (loop for c across (concatenate 'string "abcdefghijklmnopqrstuvwxyz" "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "1234567890!@$%^&*_-+={[}]<>?/~") for (fn non-term-p) = (multiple-value-list (get-macro-character c rt)) unless (or (null fn) non-term-p) collect (list rt c fn non-term-p))) nil) ;;; Copying a readtable preserves the reader macros (def-syntax-test get-macro-character.5 (let ((rt (copy-readtable))) (loop for c across +standard-chars+ for (fn1 ntp1) = (multiple-value-list (get-macro-character c)) for (fn2 ntp2) = (multiple-value-list (get-macro-character c rt)) unless (and (or (not (symbolp fn1)) (not (symbolp fn2)) (eql fn1 fn2)) (if ntp1 ntp2 (not ntp2))) collect (list c fn1 ntp1 fn2 ntp2))) nil) (def-syntax-test get-macro-character.6 (let ((rt (copy-readtable))) (loop for i below (min 65536 char-code-limit) for c = (code-char i) for (fn1 ntp1) = (if c (multiple-value-list (get-macro-character c)) '(nil nil)) for (fn2 ntp2) = (if c (multiple-value-list (get-macro-character c rt)) '(nil nil)) unless (and (or (not (symbolp fn1)) (not (symbolp fn2)) (eql fn1 fn2)) (if ntp1 ntp2 (not ntp2))) collect (list c fn1 ntp1 fn2 ntp2))) nil) (def-syntax-test get-macro-character.7 (let ((rt (copy-readtable))) (loop for i = (random (min char-code-limit (ash 1 24))) for c = (code-char i) for (fn1 ntp1) = (if c (multiple-value-list (get-macro-character c)) '(nil nil)) for (fn2 ntp2) = (if c (multiple-value-list (get-macro-character c rt)) '(nil nil)) repeat 10000 unless (and (or (not (symbolp fn1)) (not (symbolp fn2)) (eql fn1 fn2)) (if ntp1 ntp2 (not ntp2))) collect (list c fn1 ntp1 fn2 ntp2))) nil) ;;; Error tests (deftest get-macro-character.error.1 (signals-error (get-macro-character) program-error) t) (deftest get-macro-character.error.2 (signals-error (get-macro-character #\; (copy-readtable) nil) program-error) t) gcl27-2.7.0/ansi-tests/get-output-stream-string.lsp000066400000000000000000000013641454061450500221720ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 14 09:48:46 2004 ;;;; Contains: Tests of GET-OUTPUT-STREAM-STRING (in-package :cl-test) ;; this function is used extensively elsewhere in the test suite (deftest get-output-stream-string.1 (let ((s (make-string-output-stream))) (values (get-output-stream-string s) (write-string "abc" s) (write-string "def" s) (get-output-stream-string s) (get-output-stream-string s))) "" "abc" "def" "abcdef" "") ;;; Error cases (deftest get-output-stream-string.error.1 (signals-error (get-output-stream-string) t) t) (deftest get-output-stream-string.error.2 (signals-error (get-output-stream-string (make-string-output-stream) nil) t) t) gcl27-2.7.0/ansi-tests/get-properties.lsp000066400000000000000000000044601454061450500202310ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:37:00 2003 ;;;; Contains: Tests of GET-PROPERTIES (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) ;;; I removed the next test (noticed by Duane Rettig) because ;;; the non-eqness of numbers may not be necesarily preserved. ;;; The standard says numbers may be copied at any time, and ;;; this might mean eql numbers are copied to a canonical eq ;;; value #| (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 (signals-error (get-properties) program-error) t) (deftest get-properties.error.2 (signals-error (get-properties nil) program-error) t) (deftest get-properties.error.3 (signals-error (get-properties nil nil nil) program-error) t) (deftest get-properties.error.4 (signals-error (get-properties '(a 1 b 2 c 3) '(x . y)) type-error) t) (deftest get-properties.error.5 (signals-error (get-properties '(a 1 b 2 c 3 . d) '(x y)) type-error) t) (deftest get-properties.error.6 (signals-error (get-properties '(a 1 b 2 c . d) '(x y)) type-error) t) gcl27-2.7.0/ansi-tests/get-setf-expansion.lsp000066400000000000000000000026461454061450500210040ustar00rootroot00000000000000;-*- 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 (signals-error (get-setf-expansion) program-error) t) (deftest get-setf-expansion.error.2 (signals-error (get-setf-expansion 'x nil nil) program-error) t) ;;; FIXME ;;; Tests for proper behavior will go here ;;; There are tests in DEFINE-SETF-EXPANDER too ;;; For a function on which the setf expansion is otherwise ;;; undefined, produce a call to #'(setf ). Note: this ;;; form has to be present, since portable code walkers may ;;; grovel over the setf expansion (sorry, clisp). (deftest get-setf-expansion.1 (let* ((fn (gensym)) (vals (multiple-value-list (get-setf-expansion (list fn))))) (values (length vals) (first vals) (second vals) (length (third vals)) (block done (subst-if nil #'(lambda (term) (when (equal term `(function (setf ,fn))) (return-from done :good))) (fourth vals))) (if (equal (fifth vals) (list fn)) :good (fifth vals)))) 5 nil nil 1 :good :good) (deftest get-setf-expansion.2 (let* ((fn (gensym)) (vals (multiple-value-list (get-setf-expansion (list fn) nil)))) (length vals)) 5) (deftest get-setf-expansion.3 (let* ((var (gensym)) (vals (multiple-value-list (get-setf-expansion var)))) (length vals)) 5) gcl27-2.7.0/ansi-tests/get-universal-time.lsp000066400000000000000000000027521454061450500210030ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 8 19:25:41 2005 ;;;; Contains: Tests of GET-UNIVERSAL-TIME, GET-DECODED-TIME (in-package :cl-test) ;;; Note -- this ignores the possibilty that the time cannot ;;; be determined. (deftest get-universal-time.1 (notnot-mv (typep (get-universal-time) 'unsigned-byte)) t) (deftest get-universal-time.2 (let* ((time1 (get-universal-time)) (vals (multiple-value-list (get-decoded-time))) (time2 (get-universal-time))) (when (= time1 time2) (let ((vals2 (multiple-value-list (decode-universal-time time1)))) (assert (= (length vals) 9)) (assert (= (length vals2) 9)) (assert (equal (subseq vals 0 7) (subseq vals2 0 7))) (assert (if (elt vals 7) (elt vals2 7) (not (elt vals2 7)))) (assert (= (elt vals 8) (elt vals2 8))))) (values))) (deftest get-universal-time.3 (let* ((first (get-universal-time)) (prev first)) (loop for time = (get-universal-time) do (assert (>= time prev)) do (setf prev time) until (>= time (+ 5 first)))) nil) ;;; Error tests (deftest get-universal-time.error.1 (signals-error (get-universal-time nil) program-error) t) (deftest get-universal-time.error.2 (signals-error (get-universal-time :allow-other-keys t) program-error) t) (deftest get-decoded-time.error.1 (signals-error (get-decoded-time nil) program-error) t) (deftest get-decoded-time.error.2 (signals-error (get-decoded-time :allow-other-keys t) program-error) t) gcl27-2.7.0/ansi-tests/get.lsp000066400000000000000000000043641454061450500160420ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jul 13 07:01:47 2004 ;;;; Contains: Tests of GET (in-package :cl-test) (deftest get.1 (let ((sym (gensym))) (get sym :foo)) nil) (deftest get.2 (let ((sym (gensym))) (get sym :foo :bar)) :bar) (deftest get.3 (let ((sym (gensym))) (get sym :foo (values :bar nil))) :bar) (deftest get.4 (let ((sym (gensym))) (setf (symbol-plist sym) (list :foo 1 :bar 2 :foo 3)) (values (get sym :foo) (get sym :bar))) 1 2) (deftest get.5 (let ((evaluated nil) (sym (gensym))) (assert (equal (multiple-value-list (setf (get sym :foo) 1)) '(1))) (values (get sym :foo (progn (setf evaluated t) nil)) evaluated)) 1 t) (deftest get.6 (let ((evaluated nil) (sym (gensym))) (assert (equal (multiple-value-list (setf (get sym :foo (progn (setf evaluated t) nil)) 1)) '(1))) (values (get sym :foo) evaluated)) 1 t) ;;; Order of evaluation (deftest get.order.1 (let (a b (i 0) (sym (gensym))) (setf (get sym :foo) t) (values (get (progn (setf a (incf i)) sym) (progn (setf b (incf i)) :foo)) a b i)) t 1 2 2) (deftest get.order.2 (let (a b (i 0) (sym (gensym))) (values (setf (get (progn (setf a (incf i)) sym) (progn (setf b (incf i)) :foo)) t) a b i (get sym :foo) )) t 1 2 2 t) (deftest get.order.3 (let (a b c (i 0) (sym (gensym))) (setf (get sym :foo) t) (values (get (progn (setf a (incf i)) sym) (progn (setf b (incf i)) :foo) (progn (setf c (incf i)) nil)) a b c i)) t 1 2 3 3) (deftest get.order.4 (let (a b c (i 0) (sym (gensym))) (values (setf (get (progn (setf a (incf i)) sym) (progn (setf b (incf i)) :foo) (progn (setf c (incf i)) nil)) t) a b c i (get sym :foo) )) t 1 2 3 3 t) ;;; Error tests (deftest get.error.1 (signals-error (get) program-error) t) (deftest get.error.2 (signals-error (get nil) program-error) t) (deftest get.error.3 (signals-error (get nil nil nil nil) program-error) t) (deftest get.error.4 (check-type-error #'(lambda (x) (get x :foo)) #'symbolp) nil) (deftest get.error.5 (check-type-error #'(lambda (x) (setf (get x :foo) nil)) #'symbolp) nil) gcl27-2.7.0/ansi-tests/getf.lsp000066400000000000000000000107711454061450500162070ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:37:41 2003 ;;;; Contains: Tests of GETF (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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 (values cnt1 ; (eqlt cnt1 1) cnt2 ; (eqlt cnt2 1) cnt3 ; (eqlt cnt3 1) (getf (car p) 'a) (getf (car p) 'b) (getf (car p) 'c) (loop for ptr on (car p) by #'cddr count (not (member (car ptr) '(a b c)))))) 1 1 1 1 2 3 0) (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 (values i x y z w (getf (car p) 'a) (getf (car p) 'b) (getf (car p) 'c) (loop for ptr on (car p) by #'cddr count (not (member (car ptr) '(a b c)))))) 4 1 2 3 4 1 2 3 0) (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))) ;;; Error tests (deftest getf.error.1 (signals-error (getf) program-error) t) (deftest getf.error.2 (signals-error (getf nil) program-error) t) (deftest getf.error.3 (signals-error (getf nil nil nil nil) program-error) t) (deftest getf.error.4 (signals-error (getf '(a . b) 'c) type-error) t) (deftest getf.error.5 (signals-error (getf '(a 10 . b) 'c) type-error) t) gcl27-2.7.0/ansi-tests/gethash.lsp000066400000000000000000000072651454061450500167110ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Nov 28 06:05:21 2003 ;;;; Contains: Tests of GETHASH (in-package :cl-test) ;;; Most testing of GETHASH is in test-hash-table-1 in hash-table-aux.lsp (deftest gethash.1 (gethash 'x (make-hash-table) 'y) y nil) (deftest gethash.2 (gethash nil (make-hash-table) 'a) a nil) (deftest gethash.3 (gethash nil (make-hash-table) 'a) a nil) (deftest gethash.4 (multiple-value-bind (value present) (gethash 'a (let ((table (make-hash-table))) (setf (gethash 'a table) 'b) table)) (values value (notnot present))) b t) (deftest gethash.5 (let ((table (make-hash-table)) (i 0)) (values (setf (gethash 'x table (incf i)) 'y) i (gethash 'x table))) y 1 y) (deftest gethash.order.1 (let ((i 0) x y (table (make-hash-table))) (setf (gethash 'a table) 'b) (values (gethash (progn (setf x (incf i)) 'a) (progn (setf y (incf i)) table)) i x y)) b 2 1 2) (deftest gethash.order.2 (let ((i 0) x y z (table (make-hash-table))) (setf (gethash 'a table) 'b) (values (gethash (progn (setf x (incf i)) 'a) (progn (setf y (incf i)) table) (progn (setf z (incf i)) 'missing)) i x y z)) b 3 1 2 3) (deftest gethash.order.3 (let ((i 0) x y (table (make-hash-table))) (values (setf (gethash (progn (setf x (incf i)) 'a) (progn (setf y (incf i)) table)) 'b) i x y (gethash 'a table))) b 2 1 2 b) (deftest gethash.order.4 (let ((i 0) x y z (table (make-hash-table))) (values (setf (gethash (progn (setf x (incf i)) 'a) (progn (setf y (incf i)) table) (setf z (incf i))) 'b) i x y z (gethash 'a table))) b 3 1 2 3 b) ;;; Tests for 0.0, -0.0 in hash tables (deftest gethash.zero.1 (loop for pz in '(0.0s0 0.0f0 0.0d0 0.0l0) for nz = (- pz) for result = (let ((table (make-hash-table :test 'eq))) (list (setf (gethash pz table) :x) (gethash pz table) (gethash nz table) (setf (gethash nz table) :y) (gethash pz table) (gethash nz table))) unless (or (eql pz nz) (equal result '(:x :x nil :y :x :y))) collect (list pz nz result)) nil) (deftest gethash.zero.2 (loop for pz in '(0.0s0 0.0f0 0.0d0 0.0l0) for nz = (- pz) for result = (let ((table (make-hash-table :test 'eql))) (list (setf (gethash pz table) :x) (gethash pz table) (gethash nz table) (setf (gethash nz table) :y) (gethash pz table) (gethash nz table))) unless (or (eql pz nz) (equal result '(:x :x nil :y :x :y))) collect (list pz nz result)) nil) (deftest gethash.zero.3 (loop for pz in '(0.0s0 0.0f0 0.0d0 0.0l0) for nz = (- pz) for result = (let ((table (make-hash-table :test 'equal))) (list (setf (gethash pz table) :x) (gethash pz table) (gethash nz table) (setf (gethash nz table) :y) (gethash pz table) (gethash nz table))) unless (or (eql pz nz) (equal result '(:x :x nil :y :x :y))) collect (list pz nz result)) nil) (deftest gethash.zero.4 (loop for pz in '(0.0s0 0.0f0 0.0d0 0.0l0) for nz = (- pz) for result = (let ((table (make-hash-table :test 'equalp))) (list (setf (gethash pz table) :x) (gethash pz table) (gethash nz table) (setf (gethash nz table) :y) (gethash pz table) (gethash nz table))) unless (or (eql pz nz) (equal result '(:x :x :x :y :y :y))) collect (list pz nz result)) nil) ;;;; Error tests (deftest gethash.error.1 (signals-error (gethash) program-error) t) (deftest gethash.error.2 (signals-error (gethash 'foo) program-error) t) (deftest gethash.error.3 (signals-error (gethash 'foo (make-hash-table) nil nil) program-error) t) gcl27-2.7.0/ansi-tests/handler-bind.lsp000066400000000000000000000061361454061450500176110ustar00rootroot00000000000000;-*- 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 ((nil #'(lambda (c) (declare (ignore c)) (throw 'done 'bad))) (error #'(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 gcl27-2.7.0/ansi-tests/handler-case.lsp000066400000000000000000000077761454061450500176230ustar00rootroot00000000000000;-*- 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 (error "an error") (error () t)) t) (deftest handler-case.2 (handler-case (error "an error") (warning () nil) (error () t)) t) (deftest handler-case.3 (handler-case (error "an error") (error (c) (and (typep c 'error) t)) (error () 'bad) (condition () 'bad2)) t) (deftest handler-case.4 (handler-case (error "an error") (warning (c) c) (error (c) (and (typep c 'error) t)) (error () 'bad) (condition () 'bad2)) t) (deftest handler-case.5 (handler-case (error "an error") (#.(find-class 'error) (c) (and (typep c 'error) t)) (error () 'bad)) t) (deftest handler-case.6 (handler-case (values) (error () nil))) (deftest handler-case.7 (handler-case 'foo (condition () 'bar)) foo) ;;; (deftest handler-case.8 ;;; (handler-case 'foo (t () 'bar)) ;;; foo) (deftest handler-case.9 (handler-case (values 1 2 3 4 5 6 7 8) (condition () nil)) 1 2 3 4 5 6 7 8) ;;; (deftest handler-case.10 ;;; (handler-case ;;; (error "foo") ;;; (t () 'good)) ;;; good) (deftest handler-case.11 (labels ((%f () (declare (special *c*)) (and (typep *c* 'condition) t)) (%g () (let ((*c* nil)) (declare (special *c*)) (%h))) (%h () (handler-case (error "foo") (error (*c*) (declare (special *c*)) (%f))))) (%g)) t) (deftest handler-case.12 (handler-case (error "foo") (nil () nil) (error (c) (notnot-mv (typep c 'simple-error)))) t) (deftest handler-case.13 (handler-case (error "foo") (error (c) (values)))) (deftest handler-case.14 (handler-case (error "foo") (error (c) (values 1 2 3 4 5 6 7 8))) 1 2 3 4 5 6 7 8) (deftest handler-case.15 (handler-case (handler-case (error "foo") (warning () 'bad)) (error () 'good)) good) (deftest handler-case.16 (handler-case (handler-case (error "foo") (error () 'good)) (error () 'bad)) good) (deftest handler-case.17 (let ((i 0)) (values (handler-case (handler-case (error "foo") (error () (incf i) (error "bar"))) (error () 'good)) i)) good 1) (deftest handler-case.18 (let ((i 0)) (values (handler-case (handler-case (error "foo") (error (c) (incf i) (error c))) (error () 'good)) i)) good 1) (deftest handler-case.19 (handler-case (error "foo") (error (c) ;; Test that declarations can go here (declare (optimize (safety 3))) (declare (type condition c)) (declare (ignore c)) t)) t) (deftest handler-case.20 (handler-case 10 (:no-error (x) (+ x 3))) 13) (deftest handler-case.21 (handler-case (values) (:no-error () 'foo)) foo) (deftest handler-case.22 (handler-case (values 1 2 3 4 5) (:no-error (a b c d e) (list e d c b a))) (5 4 3 2 1)) (deftest handler-case.23 (signals-error (handler-case (values 1 2) (:no-error (x) x)) program-error) t) (deftest handler-case.24 (signals-error (handler-case (values) (:no-error (x) x)) program-error) t) (deftest handler-case.25 (handler-case (handler-case (values) (error () 'bad) (:no-error () (error "foo"))) (error () 'good)) good) (deftest handler-case.26 (handler-case (values 1 'a 1.0) (error () 'bad) (:no-error (a b c) ;; Test that declarations can go here (declare (type integer a)) (declare (type symbol b)) (declare (type number c)) (declare (ignore a c)) b)) a) (deftest handler-case.27 (handler-case (error "foo") (error ())) nil) (deftest handler-case.28 (handler-case (error "foo") (error () (declare (optimize speed)))) nil) ;;; Free declaration scope (deftest handler-case.29 (let ((x :bad)) (declare (special x)) (let ((x :good)) (handler-case nil (:no-error (z &aux (y x)) (declare (special x) (ignore z)) y)))) :good) gcl27-2.7.0/ansi-tests/hash-table-aux.lsp000066400000000000000000000052651454061450500200670ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 4 09:24:24 2003 ;;;; Contains: Aux. functions for testing hash tables (in-package :cl-test) (eval-when (:load-toplevel :compile-toplevel :execute) (compile-and-load "random-aux.lsp")) (defparameter *hash-table-test-iters* 1000) (defun test-hash-table-1 (&rest args) (let ((table (apply #'make-hash-table args)) (test (or (getf args :test) 'eql))) (assert (member test '(eq eql equal equalp))) (assert (hash-table-p table)) (assert (typep table 'hash-table)) ;; Build a hash table using the arguments in ARGS. ;; Perform *hash-table-test-iters* iterations of ;; random hash table operations (let* ((universe-vec (coerce *universe* 'vector)) ;; (universe-size (length universe-vec)) (mapping nil) (count 0)) (loop for i from 0 below *hash-table-test-iters* do (assert (eql (hash-table-count table) count)) do (assert (let ((size (hash-table-size table))) (and (integerp size) (>= size 0)))) do (flet ((%remove-pair (rpair) (decf count) (let ((key (car rpair)) (expected-value (cdr rpair))) (multiple-value-bind (value present-p) (gethash key table) (assert present-p) (assert (eql expected-value value)) (setf mapping (remove rpair mapping :count 1 :test 'eq))) (assert (remhash key table)) (multiple-value-bind (value present-p) (gethash key table) (assert (not present-p)) (assert (null value)) )))) (rcase (1 ;; Insert (let* ((new-elem (random-from-seq universe-vec)) (pair (assoc new-elem mapping :test test))) (cond (pair (multiple-value-bind (value present-p) (gethash new-elem table) (assert present-p) (assert (eql (cdr pair) value)) (setf (cdr pair) i (gethash new-elem table) i))) (t (assert (equal (multiple-value-list (gethash new-elem table)) '(nil nil))) (incf count) (push (cons new-elem i) mapping) (setf (gethash new-elem table) i))))) (1 ;; Delete element in the set (when mapping (%remove-pair (random-from-seq mapping)))) (1 ;; Delete random element from universe (let* ((key (random-from-seq universe-vec)) (pair (assoc key mapping :test test))) (cond (pair (%remove-pair pair)) (t ;; Not present -- check that this is true (assert (equal (multiple-value-list (gethash key table)) '(nil nil))) (assert (not (remhash key table))) (assert (equal (multiple-value-list (gethash key table)) '(nil nil))))) )) )))))) gcl27-2.7.0/ansi-tests/hash-table-count.lsp000066400000000000000000000030011454061450500204040ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Nov 28 05:14:25 2003 ;;;; Contains: Tests of HASH-TABLE-COUNT (in-package :cl-test) (deftest hash-table-count.1 (hash-table-count (make-hash-table)) 0) (deftest hash-table-count.2 (hash-table-count (make-hash-table :test 'eq)) 0) (deftest hash-table-count.3 (hash-table-count (make-hash-table :test 'eql)) 0) (deftest hash-table-count.4 (hash-table-count (make-hash-table :test 'equal)) 0) (deftest hash-table-count.5 (hash-table-count (make-hash-table :test 'equalp)) 0) (deftest hash-table-count.6 (hash-table-count (make-hash-table :test #'eq)) 0) (deftest hash-table-count.7 (hash-table-count (make-hash-table :test #'eql)) 0) (deftest hash-table-count.8 (hash-table-count (make-hash-table :test #'equal)) 0) (deftest hash-table-count.9 (hash-table-count (make-hash-table :test #'equalp)) 0) (deftest hash-table-count.10 (hash-table-count (let ((table (make-hash-table))) (setf (gethash 'x table) 1) table)) 1) (deftest hash-table-count.11 (let ((table (make-hash-table))) (setf (gethash 'x table) 1) (values (hash-table-count table) (progn (remhash 'x table) (hash-table-count table)))) 1 0) ;; This function is mostly tested by calls to test-hash-table-1 (deftest hash-table-count.error.1 (signals-error (hash-table-count) program-error) t) (deftest hash-table-count.error.2 (signals-error (hash-table-count (make-hash-table) nil) program-error) t) gcl27-2.7.0/ansi-tests/hash-table-p.lsp000066400000000000000000000015311454061450500175210ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Sep 16 21:58:37 2003 ;;;; Contains: Tests for HASH-TABLE-P (in-package :cl-test) (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 (check-type-predicate #'hash-table-p 'hash-table) nil) (deftest hash-table-p.3 (let ((i 0)) (values (hash-table-p (incf i)) i)) nil 1) (deftest hash-table-p.4 (hash-table-p t) nil) (deftest hash-table-p.5 (notnot-mv (hash-table-p (make-hash-table))) t) (deftest hash-table-p.error.1 (signals-error (hash-table-p) program-error) t) (deftest hash-table-p.error.2 (signals-error (let ((h (make-hash-table))) (hash-table-p h nil)) program-error) t) gcl27-2.7.0/ansi-tests/hash-table-rehash-size.lsp000066400000000000000000000021111454061450500214770ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Nov 28 05:47:24 2003 ;;;; Contains: Tests for HASH-TABLE-REHASH-SIZE (in-package :cl-test) (deftest hash-table-rehash-size.1 (typep* (hash-table-rehash-size (make-hash-table)) '(or (integer 1 *) (float (1.0) *))) t) (deftest hash-table-rehash-size.2 (loop for test in '(eq eql equal equalp) unless (typep* (hash-table-rehash-size (make-hash-table :test test)) '(or (integer 1 *) (float (1.0) *))) collect test) nil) (deftest hash-table-rehash-size.3 (loop for test in '(eq eql equal equalp) for fn = (symbol-function test) unless (typep* (hash-table-rehash-size (make-hash-table :test fn)) '(or (integer 1 *) (float (1.0) *))) collect test) nil) (deftest hash-table-rehash-size.error.1 (signals-error (hash-table-rehash-size) program-error) t) (deftest hash-table-rehash-size.error.2 (signals-error (hash-table-rehash-size (make-hash-table) nil) program-error) t) (deftest hash-table-rehash-size.error.3 (check-type-error #'hash-table-rehash-size #'hash-table-p) nil) gcl27-2.7.0/ansi-tests/hash-table-rehash-threshold.lsp000066400000000000000000000021011454061450500225200ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Nov 28 05:52:52 2003 ;;;; Contains: Tests of HASH-TABLE-REHASH-THRESHOLD (in-package :cl-test) (deftest hash-table-rehash-threshold.1 (typep* (hash-table-rehash-threshold (make-hash-table)) '(real 0 1)) t) (deftest hash-table-rehash-threshold.2 (loop for test in '(eq eql equal equalp) unless (typep* (hash-table-rehash-threshold (make-hash-table :test test)) '(real 0 1)) collect test) nil) (deftest hash-table-rehash-threshold.3 (loop for test in '(eq eql equal equalp) for fn = (symbol-function test) unless (typep* (hash-table-rehash-threshold (make-hash-table :test fn)) '(real 0 1)) collect test) nil) (deftest hash-table-rehash-threshold.error.1 (signals-error (hash-table-rehash-threshold) program-error) t) (deftest hash-table-rehash-threshold.error.2 (signals-error (hash-table-rehash-threshold (make-hash-table) nil) program-error) t) (deftest hash-table-rehash-threshold.error.3 (check-type-error #'hash-table-rehash-threshold #'hash-table-p) nil) gcl27-2.7.0/ansi-tests/hash-table-size.lsp000066400000000000000000000007041454061450500202350ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Nov 28 05:23:45 2003 ;;;; Contains: Tests for HASH-TABLE-SIZE (in-package :cl-test) (deftest hash-table-size.error.1 (signals-error (hash-table-size) program-error) t) (deftest hash-table-size.error.2 (signals-error (hash-table-size (make-hash-table) nil) program-error) t) (deftest hash-table-size.error.3 (check-type-error #'hash-table-size #'hash-table-p) nil) gcl27-2.7.0/ansi-tests/hash-table-test.lsp000066400000000000000000000020701454061450500202400ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Nov 28 05:56:22 2003 ;;;; Contains: Tests for HASH-TABLE-TEST (in-package :cl-test) (deftest hash-table-test.1 (hash-table-test (make-hash-table)) eql) (deftest hash-table-test.2 (loop for test in '(eq eql equal equalp) unless (eq (hash-table-test (make-hash-table :test test)) test) collect test) nil) (deftest hash-table-test.3 (loop for test in '(eq eql equal equalp) unless (eq (hash-table-test (make-hash-table :test (symbol-function test))) test) collect test) nil) (deftest hash-table-test.4 (loop for test in '(eq eql equal equalp) unless (eq (hash-table-test (make-hash-table :test (eval `(function ,test)))) test) collect test) nil) ;;; Error cases (deftest hash-table-test.error.1 (signals-error (hash-table-test) program-error) t) (deftest hash-table-test.error.2 (signals-error (hash-table-test (make-hash-table) nil) program-error) t) (deftest hash-table-test.error.3 (check-type-error #'hash-table-test #'hash-table-p) nil) gcl27-2.7.0/ansi-tests/hash-table.lsp000066400000000000000000000015231454061450500172650ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/host-namestring.lsp000066400000000000000000000021651454061450500204020ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 12 06:22:40 2004 ;;;; Contains: Tests of HOST-NAMESTRING (in-package :cl-test) (deftest host-namestring.1 (let* ((vals (multiple-value-list (host-namestring "host-namestring.lsp"))) (s (first vals))) (if (and (null (cdr vals)) (or (null s) (stringp s) ;; (equal (host-namestring s) s) )) :good vals)) :good) (deftest host-namestring.2 (do-special-strings (s "host-namestring.lsp" nil) (let ((ns (host-namestring s))) (when ns (assert (stringp ns)) ;; (assert (string= (host-namestring ns) ns)) ))) nil) (deftest host-namestring.3 (let* ((name "host-namestring.lsp") (pn (merge-pathnames (pathname name))) (name2 (with-open-file (s pn :direction :input) (host-namestring s))) (name3 (host-namestring pn))) (or (equalt name2 name3) (list name2 name3))) t) ;;; Error tests (deftest host-namestring.error.1 (signals-error (host-namestring) program-error) t) (deftest host-namestring.error.2 (signals-error (host-namestring "host-namestring.lsp" nil) program-error) t) gcl27-2.7.0/ansi-tests/identity.lsp000066400000000000000000000012421454061450500171040ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 17 23:21:11 2002 ;;;; Contains: Tests for IDENTITY (in-package :cl-test) (deftest identity.1 (check-predicate #'(lambda (x) (eqlt x (check-values (identity x))))) nil) (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 (signals-error (identity) program-error) t) (deftest identity.error.2 (signals-error (identity 'a 'a) program-error) t) gcl27-2.7.0/ansi-tests/if.lsp000066400000000000000000000025251454061450500156560ustar00rootroot00000000000000;-*- 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))) ;;; Macros are expanded in the appropriate environment (deftest if.8 (macrolet ((%m (z) z)) (if (expand-in-current-env (%m t)) :good :bad)) :good) (deftest if.9 (macrolet ((%m (z) z)) (if (expand-in-current-env (%m nil)) :bad)) nil) (deftest if.10 (macrolet ((%m (z) z)) (if (expand-in-current-env (%m t)) :good)) :good) (deftest if.11 (macrolet ((%m (z) z)) (if (expand-in-current-env (%m nil)) :bad :good)) :good) (deftest if.12 (macrolet ((%m (z) z)) (flet ((%f (x y) (if x (expand-in-current-env (%m y))))) (declare (notinline %f)) (values (%f t :good) (%f nil :bad)))) :good nil) (deftest if.13 (macrolet ((%m (z) z)) (flet ((%f (x y z) (if x y (expand-in-current-env (%m z))))) (declare (notinline %f)) (values (%f t :good :bad) (%f nil :bad :good)))) :good :good) (deftest if.order.1 (let ((i 0)) (values (if (= (incf i) 1) 't nil) i)) t 1) gcl27-2.7.0/ansi-tests/ignorable.lsp000066400000000000000000000022171454061450500172200ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 21 08:16:27 2005 ;;;; Contains: Tests of the IGNORABLE declaration (in-package :cl-test) (deftest ignorable.1 (let ((x 'foo)) (declare (ignorable x))) nil) (deftest ignorable.2 (let ((x 'foo)) (declare (ignorable x)) x) foo) (deftest ignorable.3 (flet ((%f () 'foo)) (declare (ignorable (function %f)))) nil) (deftest ignorable.4 (flet ((%f () 'foo)) (declare (ignorable (function %f))) (%f)) foo) ;;; TODO: add a test for (function (setf foo)) (deftest ignorable.5 (flet (((setf %f) (x y) nil)) (declare (ignorable (function (setf %f)))) :good) :good) (deftest ignorable.6 (flet (((setf %f) (x y) (setf (car y) x))) (declare (ignorable (function (setf %f)))) (let ((z (cons 'a 'b))) (values (setf (%f z) 'c) z))) c (c . b)) (deftest ignorable.7 (labels (((setf %f) (x y) nil)) (declare (ignorable (function (setf %f)))) :good) :good) (deftest ignorable.8 (labels (((setf %f) (x y) (setf (car y) x))) (declare (ignorable (function (setf %f)))) (let ((z (cons 'a 'b))) (values (setf (%f z) 'c) z))) c (c . b)) gcl27-2.7.0/ansi-tests/ignore-errors.lsp000066400000000000000000000013231454061450500200500ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 2 20:38:25 2003 ;;;; Contains: Tests of IGNORE-ERRORS (in-package :cl-test) (deftest ignore-errors.1 (ignore-errors) nil) (deftest ignore-errors.2 (ignore-errors 'a) a) (deftest ignore-errors.3 (ignore-errors (values 1 2 3 4 5 6 7 8)) 1 2 3 4 5 6 7 8) (deftest ignore-errors.4 (multiple-value-bind (val cond) (ignore-errors (error "foo")) (and (null val) (typep cond 'simple-error) t)) t) (deftest ignore-errors.5 (handler-case (ignore-errors (signal "foo")) (condition () 'good)) good) (deftest ignore-errors.6 (handler-case (ignore-errors (signal "foo")) (simple-condition () 'good)) good) gcl27-2.7.0/ansi-tests/ignore.lsp000066400000000000000000000013341454061450500165400ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 21 07:59:24 2005 ;;;; Contains: Tests of the IGNORE declarations (in-package :cl-test) (deftest ignore.1 (let ((x 'foo)) (declare (ignore x))) nil) (deftest ignore.2 (let ((x 'foo)) (declare (ignore x)) x) foo) (deftest ignore.3 (flet ((%f () 'foo)) (declare (ignore (function %f)))) nil) (deftest ignore.4 (flet ((%f () 'foo)) (declare (ignore (function %f))) (%f)) foo) (deftest ignore.5 (flet (((setf %f) (x y) (setf (car y) x))) (declare (ignore (function (setf %f)))) :good) :good) (deftest ignore.6 (labels (((setf %f) (x y) (setf (car y) x))) (declare (ignore (function (setf %f)))) :good) :good) gcl27-2.7.0/ansi-tests/imagpart.lsp000066400000000000000000000016631454061450500170660ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 7 07:47:43 2003 ;;;; Contains: Tests of IMAGPART (in-package :cl-test) (deftest imagpart.error.1 (signals-error (imagpart) program-error) t) (deftest imagpart.error.2 (signals-error (imagpart #c(1.0 2.0) nil) program-error) t) (deftest imagpart.error.3 (check-type-error #'imagpart #'numberp) nil) (deftest imagpart.1 (loop for x in *reals* for c = (complex 0 x) for ip = (imagpart c) unless (eql x ip) collect (list x c ip)) nil) (deftest imagpart.2 (loop for x in *reals* for c = (complex 1 x) for ip = (imagpart c) unless (eql x ip) collect (list x c ip)) nil) (deftest imagpart.3 (loop for x in *reals* for c = (complex x x) for ip = (imagpart c) unless (eql x ip) collect (list x c ip)) nil) (deftest imagpart.4 (loop for x in *reals* for ip = (imagpart x) unless (eql (* 0 x) ip) collect (list x ip (* 0 x))) nil) gcl27-2.7.0/ansi-tests/import.lsp000066400000000000000000000204741454061450500165750ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Feb 19 07:06:48 2004 ;;;; Contains: Tests of IMPORT (in-package :cl-test) (compile-and-load "package-aux.lsp") ;;; Create a package name that does not collide with an existing package ;;; name or nickname (defvar *import-package-test-name* (loop for i from 1 for name = (format nil "ITP-~A" i) unless (find-package name) return name)) (deftest import.1 (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let ((pkg (eval `(defpackage ,pkg-name (:use)))) (sym 'foo)) (values (multiple-value-list (import sym pkg)) (eqlt (find-symbol (symbol-name sym) pkg) sym) (eqlt (symbol-package sym) (find-package :cl-test)) (external-symbols-in-package pkg) ))) (t) t t nil) (deftest import.2 (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let ((pkg (eval `(defpackage ,pkg-name (:use)))) (sym 'foo)) (values (multiple-value-list (import (list sym) pkg)) (eqlt (find-symbol (symbol-name sym) pkg) sym) (eqlt (symbol-package sym) (find-package :cl-test)) (external-symbols-in-package pkg) ))) (t) t t nil) (deftest import.3 (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let ((*package* (eval `(defpackage ,pkg-name (:use)))) (sym 'foo)) (values (multiple-value-list (import sym)) (eqlt (find-symbol (symbol-name sym)) sym) (eqlt (symbol-package sym) (find-package :cl-test)) (external-symbols-in-package *package*) ))) (t) t t nil) (deftest import.4 (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let ((pkg (eval `(defpackage ,pkg-name (:use)))) (syms '(foo bar baz))) (values (multiple-value-list (import syms pkg)) (loop for sym in syms always (eqlt (find-symbol (symbol-name sym) pkg) sym)) (loop for sym in syms always (eqlt (symbol-package sym) (find-package :cl-test))) (external-symbols-in-package pkg) ))) (t) t t nil) (deftest import.5 (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let ((pkg (eval `(defpackage ,pkg-name (:use)))) (sym (make-symbol (symbol-name :foo)))) (values (multiple-value-list (import sym pkg)) (eqlt (symbol-package sym) pkg) (eqlt (find-symbol (symbol-name sym) pkg) sym) (external-symbols-in-package pkg) ))) (t) t t nil) (deftest import.6 (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let* ((pkg (eval `(defpackage ,pkg-name (:use)))) (sym (intern (symbol-name :foo) pkg))) (values (multiple-value-list (import sym pkg)) (eqlt (symbol-package sym) pkg) (eqlt (find-symbol (symbol-name sym) pkg) sym) (external-symbols-in-package pkg) ))) (t) t t nil) (deftest import.7 (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let* ((pkg (eval `(defpackage ,pkg-name (:use) (:export #:foo)))) (sym (intern (symbol-name :foo) pkg))) (values (multiple-value-list (import sym pkg)) (eqlt (symbol-package sym) pkg) (eqlt (find-symbol (symbol-name sym) pkg) sym) (length (external-symbols-in-package pkg)) (eqlt (car (external-symbols-in-package pkg)) sym) ))) (t) t t 1 t) (deftest import.8 (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let ((pkg (eval `(defpackage ,pkg-name (:use)))) (sym 'foo)) (values (multiple-value-list (import sym pkg-name)) (eqlt (find-symbol (symbol-name sym) pkg) sym) (eqlt (symbol-package sym) (find-package :cl-test)) (external-symbols-in-package pkg) ))) (t) t t nil) (deftest import.9 (let ((pkg-name "Z")) (safely-delete-package pkg-name) (let ((pkg (eval `(defpackage ,pkg-name (:use)))) (sym 'foo)) (values (multiple-value-list (import sym #\Z)) (eqlt (find-symbol (symbol-name sym) pkg) sym) (eqlt (symbol-package sym) (find-package :cl-test)) (external-symbols-in-package pkg) ))) (t) t t nil) (deftest import.10 (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let ((pkg (eval `(defpackage ,pkg-name (:use)))) (sym 'foo)) (values (let ((pname (make-array (length pkg-name) :element-type 'base-char :initial-contents pkg-name))) (multiple-value-list (import sym pname))) (eqlt (find-symbol (symbol-name sym) pkg) sym) (eqlt (symbol-package sym) (find-package :cl-test)) (external-symbols-in-package pkg) ))) (t) t t nil) (deftest import.11 (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let ((pkg (eval `(defpackage ,pkg-name (:use)))) (sym 'foo)) (values (let ((pname (make-array (+ 3 (length pkg-name)) :element-type 'base-char :fill-pointer (length pkg-name) :initial-contents (concatenate 'string pkg-name "XYZ")))) (multiple-value-list (import sym pname))) (eqlt (find-symbol (symbol-name sym) pkg) sym) (eqlt (symbol-package sym) (find-package :cl-test)) (external-symbols-in-package pkg) ))) (t) t t nil) (deftest import.12 (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let ((pkg (eval `(defpackage ,pkg-name (:use)))) (sym 'foo)) (values (let* ((pname0 (make-array (+ 4 (length pkg-name)) :element-type 'base-char :fill-pointer (length pkg-name) :initial-contents (concatenate 'string " " pkg-name "XY"))) (pname (make-array (length pkg-name) :element-type 'base-char :displaced-to pname0 :displaced-index-offset 2))) (multiple-value-list (import sym pname))) (eqlt (find-symbol (symbol-name sym) pkg) sym) (eqlt (symbol-package sym) (find-package :cl-test)) (external-symbols-in-package pkg) ))) (t) t t nil) ;;; Error tests (deftest import.error.1 (signals-error (import) program-error) t) (deftest import.error.2 (signals-error (import 'nil (find-package :cl-test) nil) program-error) t) (deftest import.error.3 (signals-error (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let* ((pkg (eval `(defpackage ,pkg-name (:use)))) (sym 'foo) (name (symbol-name sym))) (intern name pkg) (import sym pkg))) package-error) t) (deftest import.error.4 (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let* ((pkg (eval `(defpackage ,pkg-name (:use)))) (sym 'foo) (name (symbol-name sym)) (isym (intern name pkg)) (outer-restarts (compute-restarts))) (block done (and (handler-bind ((package-error #'(lambda (c) ;; There should be at least one restart ;; associated with this condition that was ;; not a preexisting restart (let ((my-restarts (remove 'abort (set-difference (compute-restarts c) outer-restarts) :key #'restart-name))) (assert my-restarts) ; (unintern isym pkg) ; (when (find 'continue my-restarts :key #'restart-name) (continue c)) (return-from done :good))))) (import sym pkg)) (eqlt (find-symbol name pkg) sym) (eqlt (symbol-package sym) (find-package "CL-TEST")) :good)))) :good) (deftest import.error.5 (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let* ((pkg (eval `(defpackage ,pkg-name (:use)))) (sym 'foo) (name (symbol-name sym)) (isym (shadow name pkg)) ;; shadow instead of intern (outer-restarts (compute-restarts))) (block done (and (handler-bind ((package-error #'(lambda (c) ;; There should be at least one restart ;; associated with this condition that was ;; not a preexisting restart (let ((my-restarts (remove 'abort (set-difference (compute-restarts c) outer-restarts) :key #'restart-name))) (assert my-restarts) ; (unintern isym pkg) ; (when (find 'continue my-restarts :key #'restart-name) (continue c)) (return-from done :good))))) (import sym pkg)) (eqlt (find-symbol name pkg) sym) (eqlt (symbol-package sym) (find-package "CL-TEST")) :good)))) :good) gcl27-2.7.0/ansi-tests/in-package.lsp000066400000000000000000000054401454061450500172560ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:06:03 1998 ;;;; Contains: Tests of IN-PACKAGE (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; in-package (deftest in-package.1 (let ((*package* *package*)) (safely-delete-package "H") (make-package "H" :use ()) (let ((p2 (in-package "H"))) (and (eqt p2 (find-package "H")) (eqt *package* p2)))) t) (deftest in-package.2 (let ((*package* *package*)) (safely-delete-package "H") (make-package "H" :use ()) (let ((p2 (in-package |H|))) (and (eqt p2 (find-package "H")) (eqt *package* p2)))) t) (deftest in-package.3 (let ((*package* *package*)) (safely-delete-package "H") (make-package "H" :use ()) (let ((p2 (in-package :|H|))) (and (eqt p2 (find-package "H")) (eqt *package* p2)))) t) (deftest in-package.4 (let ((*package* *package*)) (safely-delete-package "H") (make-package "H" :use ()) (let ((p2 (in-package #\H))) (and (eqt p2 (find-package "H")) (eqt *package* p2)))) t) (deftest in-package.5 (let ((*package* *package*)) (safely-delete-package "H") (handler-case (eval '(in-package "H")) (package-error () 'package-error) (error (c) c))) package-error) (def-macro-test in-package.error.1 (in-package :cl-test)) (defmacro def-in-package-test (test-name name-form) `(deftest ,test-name (let ((name ,name-form)) (safely-delete-package name) (prog1 (let* ((p (make-package name :use nil)) (*package* *package*) (p2 (eval `(in-package ,name)))) (list (eqt p p2) (eqt p *package*))) (safely-delete-package name))) (t t))) (def-in-package-test in-package.7 (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) (def-in-package-test in-package.8 (make-array 10 :initial-contents "TEST1ABCDE" :fill-pointer 5 :element-type 'base-char)) (def-in-package-test in-package.9 (make-array 10 :initial-contents "TEST1ABCDE" :fill-pointer 5 :element-type 'character)) (def-in-package-test in-package.10 (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'base-char)) (def-in-package-test in-package.11 (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'character)) (def-in-package-test in-package.12 (let* ((etype 'base-char) (name0 (make-array 10 :element-type etype :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 5))) (def-in-package-test in-package.13 (let* ((etype 'character) (name0 (make-array 10 :element-type etype :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 5)))gcl27-2.7.0/ansi-tests/incf.lsp000066400000000000000000000070731454061450500162020ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Sep 4 20:01:15 2003 ;;;; Contains: Tests of INCF (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (deftest incf.1 (let ((x 12)) (values (incf x) x)) 13 13) (deftest incf.2 (let ((x 3.0s0)) (values (incf x) x)) 4.0s0 4.0s0) (deftest incf.3 (let ((x 19.0f0)) (values (incf x) x)) 20.0f0 20.0f0) (deftest incf.4 (let ((x 813.0d0)) (values (incf x) x)) 814.0d0 814.0d0) (deftest incf.5 (let ((x -17.0l0)) (values (incf x) x)) -16.0l0 -16.0l0) (deftest incf.6 (loop for x from 1 to 5 collect (let ((y x)) (list (incf y) y))) ((2 2) (3 3) (4 4) (5 5) (6 6))) (deftest incf.7 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) collect (let ((y x)) (list (incf y) y))) ((2.0s0 2.0s0) (2.0f0 2.0f0) (2.0d0 2.0d0) (2.0l0 2.0l0))) (deftest incf.8 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0f0) for y = (complex x 0) for z = (incf y) for x1c = (complex (1+ x) 0) unless (and (eql y z) (eql x1c y)) collect (list x y z x1c)) nil) (deftest incf.9 (let ((x most-positive-fixnum)) (values (incf x) x)) #.(1+ most-positive-fixnum) #.(1+ most-positive-fixnum)) (deftest incf.10 (let ((x (1+ most-positive-fixnum))) (values (incf x) x)) #.(+ 2 most-positive-fixnum) #.(+ 2 most-positive-fixnum)) (deftest incf.11 (loop for x in *numbers* unless (let* ((y x) (z (incf y))) (and (eql y (1+ x)) (eql y z))) collect x) nil) ;;; Increment by other than 1 (deftest incf.12 (loop for x in *numbers* unless (let* ((y x) (z (incf y 0))) (and (eql x y) (eql y z))) collect x) nil) (deftest incf.13 (loop for x in *numbers* nconc (loop for r = (random-from-interval 1000000) repeat 100 when (let* ((y x) (z (incf y r))) (and (not (and (eql (+ x r) y) (eql y z))) (list x y r))) collect it)) nil) (deftest incf.14 (let ((x 1)) (values (incf x 0.0s0) x)) 1.0s0 1.0s0) (deftest incf.15 (let ((x 1)) (values (incf x 0.0f0) x)) 1.0f0 1.0f0) (deftest incf.16 (let ((x 2)) (values (incf x 0.0d0) x)) 2.0d0 2.0d0) (deftest incf.17 (let ((x 10)) (values (incf x 0.0l0) x)) 10.0l0 10.0l0) (deftest incf.18 (let ((x 1)) (values (incf x #c(0.0s0 0.0s0)) x)) #c(1.0s0 0.0s0) #c(1.0s0 0.0s0)) (deftest incf.19 (let ((x 1)) (values (incf x #c(0.0f0 2.0f0)) x)) #c(1.0f0 2.0f0) #c(1.0f0 2.0f0)) (deftest incf.20 (let ((x 1)) (values (incf x #c(0.0d0 2.0d0)) x)) #c(1.0d0 2.0d0) #c(1.0d0 2.0d0)) (deftest incf.21 (let ((x 1)) (values (incf x #c(0.0l0 -2.0l0)) x)) #c(1.0l0 -2.0l0) #c(1.0l0 -2.0l0)) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest incf.22 (macrolet ((%m (z) z)) (let ((x 2)) (values (incf (expand-in-current-env (%m x))) x))) 3 3) (deftest incf.23 (macrolet ((%m (z) z)) (let ((x 2)) (values (incf x (expand-in-current-env (%m 4))) x))) 6 6) (deftest incf.order.2 (let ((a (vector 1 2 3 4)) (i 0) x y z) (values (incf (aref (progn (setf x (incf i)) a) (progn (setf y (incf i)) 0)) (progn (setf z (incf i)) 17)) i x y z a)) 18 3 1 2 3 #(18 2 3 4)) (deftest incf.order.3 (let ((a (vector 10 2 3 4)) (i 0) x y) (values (incf (aref (progn (setf x (incf i)) a) (progn (setf y (incf i)) 0))) i x y a)) 11 2 1 2 #(11 2 3 4)) (deftest incf.order.4 (let ((x 0)) (progn "See CLtS 5.1.3" (values (incf x (setf x 1)) x))) 2 2) gcl27-2.7.0/ansi-tests/input-stream-p.lsp000066400000000000000000000015601454061450500201430ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 13 19:39:27 2004 ;;;; Contains: Tests for INPUT-STREAM-P (in-package :cl-test) (deftest input-stream-p.1 (notnot-mv (input-stream-p *standard-input*)) t) (deftest input-stream-p.2 (notnot-mv (input-stream-p *terminal-io*)) t) (deftest input-stream-p.3 (with-open-file (s "input-stream-p.lsp" :direction :input) (notnot-mv (input-stream-p s))) t) (deftest input-stream-p.4 (with-open-file (s "foo.txt" :direction :output :if-exists :supersede) (input-stream-p s)) nil) ;;; Error tests (deftest input-stream-p.error.1 (signals-error (input-stream-p) program-error) t) (deftest input-stream-p.error.2 (signals-error (input-stream-p *standard-input* nil) program-error) t) (deftest input-stream-p.error.3 (check-type-error #'input-stream-p #'streamp) nil) gcl27-2.7.0/ansi-tests/inspect.lsp000066400000000000000000000006601454061450500167230ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 15 12:54:22 2005 ;;;; Contains: Tests of INSPECT (in-package :cl-test) ;;; INSPECT's normal behavior is entirely implementation-dependent, ;;; so it cannot be tested here. Only test simple error cases. (deftest inspect.error.1 (signals-error (inspect) program-error) t) (deftest inspect.error.2 (signals-error (inspect nil nil) program-error) t) gcl27-2.7.0/ansi-tests/integer-length.lsp000066400000000000000000000025671454061450500202020ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 7 10:10:10 2003 ;;;; Contains: Tests for INTEGER-LENGTH (in-package :cl-test) (deftest integer-length.error.1 (signals-error (integer-length) program-error) t) (deftest integer-length.error.2 (signals-error (integer-length 1 1) program-error) t) (deftest integer-length.error.3 (signals-error (integer-length 1 nil) program-error) t) (deftest integer-length.error.4 (check-type-error #'integer-length #'integerp) nil) (deftest integer-length.1 (loop for len from 0 to 100 for i = (1- (ash 1 len)) for vals = (multiple-value-list (integer-length i)) for len2 = (car vals) always (and (= (length vals) 1) (eql len len2))) t) (deftest integer-length.2 (loop for len from 0 to 100 for i = (ash 1 len) for vals = (multiple-value-list (integer-length i)) for len2 = (car vals) always (and (= (length vals) 1) (eql (1+ len) len2))) t) (deftest integer-length.3 (loop for len from 0 to 100 for i = (- (ash 1 len)) for vals = (multiple-value-list (integer-length i)) for len2 = (car vals) always (and (= (length vals) 1) (eql len len2))) t) (deftest integer-length.4 (loop for len from 0 to 100 for i = (- -1 (ash 1 len)) for vals = (multiple-value-list (integer-length i)) for len2 = (car vals) always (and (= (length vals) 1) (eql (1+ len) len2))) t) gcl27-2.7.0/ansi-tests/integerp.lsp000066400000000000000000000012021454061450500170640ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 7 10:18:34 2003 ;;;; Contains: Tests for INTEGERP (in-package :cl-test) (deftest integerp.error.1 (signals-error (integerp) program-error) t) (deftest integerp.error.2 (signals-error (integerp 0 0) program-error) t) (deftest integerp.error.3 (signals-error (integerp nil nil) program-error) t) (deftest integerp.1 (loop for i in *integers* for vals = (multiple-value-list (integerp i)) unless (and (= (length vals) 1) (first vals)) collect (cons i vals)) nil) (deftest integerp.2 (check-type-predicate #'integerp 'integer) nil) gcl27-2.7.0/ansi-tests/interactive-stream-p.lsp000066400000000000000000000013461454061450500213230ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 13 19:47:59 2004 ;;;; Contains: Tests of INTERACTIVE-STREAM-P (in-package :cl-test) (deftest interactive-stream-p.1 (let ((streams (list *debug-io* *error-output* *query-io* *standard-input* *standard-output* *trace-output* *terminal-io*))) (mapc #'interactive-stream-p streams) ;; no error should occur nil) nil) (deftest interactive-stream-p.error.1 (check-type-error #'interactive-stream-p #'streamp) nil) (deftest interactive-stream-p.error.2 (signals-error (interactive-stream-p) program-error) t) (deftest interactive-stream-p.error.3 (signals-error (interactive-stream-p *terminal-io* nil) program-error) t) gcl27-2.7.0/ansi-tests/intern.lsp000066400000000000000000000115051454061450500165550ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 07:59:10 1998 ;;;; Contains: Tests of INTERN (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; intern (deftest intern.1 (progn (safely-delete-package "TEMP1") (let ((p (make-package "TEMP1" :use nil)) (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" :use nil))) (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.3 :notes (:nil-vectors-are-strings) (let ((cl-user-package (find-package "CL-USER"))) (eqt (intern "" cl-user-package) (intern (make-array 0 :element-type nil) cl-user-package))) t) (deftest intern.4 (let ((cl-user-package (find-package "CL-USER"))) (eqt (intern (make-array 5 :element-type 'character :initial-contents "XYZZY") cl-user-package) (intern (make-array 5 :element-type 'base-char :initial-contents "XYZZY") cl-user-package))) t) ;;; String is a specialized sequence type (defmacro def-intern-test (test-name &key (symbol-name "FOO") (package-name "TEMP1")) `(deftest ,test-name (let ((sname ,symbol-name) (pname ,package-name)) (safely-delete-package pname) (let ((p (make-package pname :use nil))) (multiple-value-bind* (sym1 status1) (find-symbol sname pname) (intern sname pname) (multiple-value-bind* (sym2 status2) (find-symbol sname p) (and (null sym1) (null status1) (string= (symbol-name sym2) sname) (eqt (symbol-package sym2) p) (eqt status2 :internal) (progn (delete-package p) t)))))) t)) (def-intern-test intern.5 :symbol-name (make-array 3 :element-type 'base-char :initial-contents "BAR")) (def-intern-test intern.6 :symbol-name (make-array 13 :element-type 'base-char :fill-pointer 3 :initial-contents "BAR1234567890")) (def-intern-test intern.7 :symbol-name (make-array 13 :element-type 'character :fill-pointer 3 :initial-contents "BAR1234567890")) (def-intern-test intern.8 :symbol-name (make-array 3 :element-type 'base-char :adjustable t :initial-contents "BAR")) (def-intern-test intern.9 :symbol-name (make-array 3 :element-type 'character :adjustable t :initial-contents "BAR")) (def-intern-test intern.10 :symbol-name (let* ((etype 'base-char) (name0 (make-array 8 :element-type etype :initial-contents "XBARYYYY"))) (make-array 3 :element-type etype :displaced-to name0 :displaced-index-offset 1))) (def-intern-test intern.11 :symbol-name (let* ((etype 'character) (name0 (make-array 8 :element-type etype :initial-contents "XBARYYYY"))) (make-array 3 :element-type etype :displaced-to name0 :displaced-index-offset 1))) (def-intern-test intern.12 :package-name (make-array 3 :element-type 'base-char :initial-contents "BAR")) (def-intern-test intern.13 :package-name (make-array 13 :element-type 'base-char :fill-pointer 3 :initial-contents "BAR1234567890")) (def-intern-test intern.14 :package-name (make-array 13 :element-type 'character :fill-pointer 3 :initial-contents "BAR1234567890")) (def-intern-test intern.15 :package-name (make-array 3 :element-type 'base-char :adjustable t :initial-contents "BAR")) (def-intern-test intern.16 :package-name (make-array 3 :element-type 'character :adjustable t :initial-contents "BAR")) (def-intern-test intern.17 :package-name (let* ((etype 'base-char) (name0 (make-array 8 :element-type etype :initial-contents "XBARYYYY"))) (make-array 3 :element-type etype :displaced-to name0 :displaced-index-offset 1))) (def-intern-test intern.18 :package-name (let* ((etype 'character) (name0 (make-array 8 :element-type etype :initial-contents "XBARYYYY"))) (make-array 3 :element-type etype :displaced-to name0 :displaced-index-offset 1))) ;;; Error tests (deftest intern.error.1 (signals-error (intern) program-error) t) (deftest intern.error.2 (signals-error (intern "X" "CL" nil) program-error) t) gcl27-2.7.0/ansi-tests/intersection.lsp000066400000000000000000000231071454061450500177650ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:39:19 2003 ;;;; Contains: Tests of INTERSECTION (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) (defharmless intersection.test-and-test-not.1 (intersection '(a b c) '(a c e) :test #'eql :test-not #'eql)) (defharmless intersection.test-and-test-not.2 (intersection '(a b c) '(a c e) :test-not #'eql :test #'eql)) ;;; 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)) (def-fold-test intersection.fold.1 (intersection '(a b c d e f) '(d w a x b y))) ;;; Error tests (deftest intersection.error.1 (signals-error (intersection) program-error) t) (deftest intersection.error.2 (signals-error (intersection nil) program-error) t) (deftest intersection.error.3 (signals-error (intersection nil nil :bad t) program-error) t) (deftest intersection.error.4 (signals-error (intersection nil nil :key) program-error) t) (deftest intersection.error.5 (signals-error (intersection nil nil 1 2) program-error) t) (deftest intersection.error.6 (signals-error (intersection nil nil :bad t :allow-other-keys nil) program-error) t) (deftest intersection.error.7 (signals-error (intersection '(a b c) '(d e f) :test #'identity) program-error) t) (deftest intersection.error.8 (signals-error (intersection '(a b c) '(d e f) :test-not #'identity) program-error) t) (deftest intersection.error.9 (signals-error (intersection '(a b c) '(d e f) :key #'cons) program-error) t) (deftest intersection.error.10 (signals-error (intersection '(a b c) '(d e f) :key #'car) type-error) t) (deftest intersection.error.11 (signals-error (intersection '(a b c) '(d e f . g)) type-error) t) (deftest intersection.error.12 (signals-error (intersection '(a b . c) '(d e f)) type-error) t) (deftest intersection.error.13 (check-type-error #'(lambda (x) (intersection x '(a b c))) #'listp) nil) (deftest intersection.error.14 (check-type-error #'(lambda (x) (intersection '(a b c) x)) #'listp) nil)gcl27-2.7.0/ansi-tests/invoke-debugger.lsp000066400000000000000000000034371454061450500203400ustar00rootroot00000000000000;-*- 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) (deftest invoke-debugger.error.1 (signals-error (block done (let ((*debugger-hook* #'(lambda (&rest args) (declare (ignore args)) (return-from done 'bad)))) (invoke-debugger))) program-error) t) (deftest invoke-debugger.error.2 (signals-error (block done (let ((*debugger-hook* #'(lambda (&rest args) (declare (ignore args)) (return-from done 'bad)))) (invoke-debugger (make-condition 'simple-error) nil))) program-error) t) ;;; If the debugger hook function expects the wrong number ;;; of arguments, a program-error should be thrown in safe code ;;; This error is thrown 'prior to entry to the standard debugger'. (deftest invoke-debugger.error.3 (signals-error (let ((*debugger-hook* #'(lambda () nil))) (invoke-debugger (make-condition 'simple-error))) program-error) t) (deftest invoke-debugger.error.4 (signals-error (let ((*debugger-hook* #'(lambda (c) c))) (invoke-debugger (make-condition 'simple-error))) program-error) t) (deftest invoke-debugger.error.5 (signals-error (let ((*debugger-hook* #'(lambda (c hook x) (list c hook x)))) (invoke-debugger (make-condition 'simple-error))) program-error) t) gcl27-2.7.0/ansi-tests/isqrt.lsp000066400000000000000000000023571454061450500164250ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 6 15:40:09 2003 ;;;; Contains: Tests of ISQRT (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest isqrt.error.1 (signals-error (isqrt) program-error) t) (deftest isqrt.error.2 (signals-error (isqrt 0 0) program-error) t) (deftest isqrt.error.3 (signals-error (isqrt 0 nil) program-error) t) (deftest isqrt.error.4 (signals-error (isqrt 0 0 0) program-error) t) (deftest isqrt.error.5 (loop for x in *mini-universe* unless (or (and (integerp x) (>= x 0)) (eval `(signals-type-error x ',x (isqrt x)))) collect x) nil) ;;; Non-error tests (deftest isqrt.1 (loop for i from 0 to 10000 for i2 = (* i i) for s = (isqrt i2) unless (eql s i) collect i) nil) (deftest isqrt.2 (loop for i = (random-from-interval most-positive-fixnum 0) for s = (isqrt i) repeat 1000 unless (and (integerp s) (>= s 0) (<= (* s s) i) (> (* (1+ s) (1+ s)) i)) collect (list i s)) nil) (deftest isqrt.3 (loop for i = (random-from-interval 1000000000000000 0) for s = (isqrt i) repeat 1000 unless (and (integerp s) (>= s 0) (<= (* s s) i) (> (* (1+ s) (1+ s)) i)) collect (list i s)) nil) gcl27-2.7.0/ansi-tests/iteration.lsp000066400000000000000000000203761454061450500172620ustar00rootroot00000000000000;-*- 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)) gcl27-2.7.0/ansi-tests/keyword.lsp000066400000000000000000000074601454061450500167470ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Feb 22 06:53:55 2004 ;;;; Contains: Tests of the KEYWORD package (in-package :cl-test) ;; Check that each keyword satisfies keywordp (deftest keyword.1 (do-symbols (s "KEYWORD" t) (unless (keywordp s) (return (list s nil)))) t) ;; Check that symbols that are interned in the KEYWORD ;; package, but do not have KEYWORD as their home package, ;; are in fact keywords. ;; ;; This came up on the #lisp irc channel ;;; ;;; The following two tests are improper, since (see the page for SYMBOL) ;;; "The consequences are undefined if an attempt is made to alter the home ;;; package of a symbol external in the COMMON-LISP package or the KEYWORD package." ;;; ;;; They could be rewritten to search for a name that is not interned in KEYWORD. ;;; #| (deftest keyword.4 (let ((name "SYMBOL-NAME-FOR-KEYWORD.4") (kwp (find-package "KEYWORD"))) (let ((s (find-symbol name kwp))) (when s (unintern s kwp)) ;; Now, create a symbol with this name ;; and import it into the keyword package (setq s (make-symbol name)) (import s kwp) ;; Check that it's a keyword (values (eqlt (symbol-package s) kwp) (eqlt (find-symbol name kwp) s) (nth-value 1 (find-symbol name kwp)) (notnot (typep s 'keyword)) (if (boundp s) (eqlt s (symbol-value s)) :not-bound) (notnot (constantp s))))) t t :external t t t) (deftest keyword.5 (let* ((name "SYMBOL-NAME-FOR-KEYWORD.5") (pkg-name "PACKAGE-FOR-KEYWORD.5") (kwp (find-package "KEYWORD"))) (safely-delete-package pkg-name) (let* ((pkg (make-package pkg-name :use nil)) (s (find-symbol name kwp))) (when s (unintern s kwp)) ;; Now, create a symbol with this name ;; and import it into the keyword package (setq s (intern name pkg)) (import s kwp) ;; Check that it's a keyword (values (eqlt (symbol-package s) pkg) (eqlt (find-symbol name kwp) s) (nth-value 1 (find-symbol name kwp)) (notnot (typep s 'keyword)) (if (boundp s) (eqlt s (symbol-value s)) :not-bound) (notnot (constantp s))))) t t :external t t t) (deftest keyword.6 (let* ((name "SYMBOL-NAME-FOR-KEYWORD.6") (pkg-name "PACKAGE-FOR-KEYWORD.6") (kwp (find-package "KEYWORD"))) (safely-delete-package pkg-name) (let* ((pkg (make-package pkg-name :use nil)) (s (find-symbol name kwp)) s2) (when s (unintern s kwp)) ;; Recreate a symbol with this name in the keyword package ;; shadowing-import will displace this symbol (setq s2 (intern name kwp)) ;; Now, create a symbol with this name ;; and shadowing-import it into the keyword package (setq s (intern name pkg)) (shadowing-import s kwp) ;; Check that it's a keyword (values (eqt s s2) (symbol-package s2) (eqlt (symbol-package s) pkg) (eqlt (find-symbol name kwp) s) (nth-value 1 (find-symbol name kwp)) (notnot (typep s 'keyword)) (if (boundp s) (eqlt s (symbol-value s)) :not-bound) (notnot (constantp s))))) nil nil t t :external t t t) |# ;;; Note that the case of a symbol inherited into KEYWORD cannot arise ;;; standardly from user actions, since USE-PACKAGE disallows KEYWORD ;;; as the package designated by its second argument. ;; 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) (cond ((not (boundp s)) (return (list s "NOT-BOUND"))) ((not (eqt s (eval s))) (return (list s (eval s)))))) t) gcl27-2.7.0/ansi-tests/keywordp.lsp000066400000000000000000000024661454061450500171300ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jun 14 05:46:51 2003 ;;;; Contains: Tests of KEYWORDP (in-package :cl-test) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 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.13 (let ((kwp (find-package "KEYWORD")) (bad nil)) (do-symbols (s "KEYWORD" bad) (when (and (not (eq (symbol-package s) kwp)) (keywordp s)) (push s bad)))) nil) (deftest keywordp.order.1 (let ((i 0)) (values (keywordp (progn (incf i) nil)) i)) nil 1) (deftest keywordp.error.1 (signals-error (keywordp) program-error) t) (deftest keywordp.error.2 (signals-error (keywordp :x :x) program-error) t) gcl27-2.7.0/ansi-tests/labels.lsp000066400000000000000000000212311454061450500165150ustar00rootroot00000000000000;-*- 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 :good))) nil)) (%f) :bad)) :good) ;;; Keyword parameter initializers are not in the blocked defined ;;; by the local function declaration (deftest labels.4a (block %f (labels ((%f (&key (x (return-from %f :good))) nil)) (%f) :bad)) :good) (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) :bad)) 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) ;;; 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) ;;; Scope of defined function names includes &OPTIONAL parameters (deftest labels.7c (labels ((%f (x &optional (b (%g x))) b) (%g (y) (+ y y))) (%f 10)) 20) ;;; Scope of defined function names includes &KEY parameters (deftest labels.7d (labels ((%f (x &key (b (%g x))) b) (%g (y) (+ y y))) (%f 10)) 20) ;;; 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 (signals-error (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :c 4)) program-error) t) ;;; Odd # of keyword args should throw a program-error in safe code ;;; (section 3.5.1.6) (deftest labels.13 (signals-error (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :a)) program-error) t) ;;; Too few arguments (section 3.5.1.2) (deftest labels.14 (signals-error (labels ((%f (a) a)) (%f)) program-error) t) ;;; Too many arguments (section 3.5.1.3) (deftest labels.15 (signals-error (labels ((%f (a) a)) (%f 1 2)) program-error) t) ;;; Invalid keyword argument (section 3.5.1.5) (deftest labels.16 (signals-error (labels ((%f (&key a) a)) (%f '(foo))) program-error) t) ;;; 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)) ;;; 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 (1- lambda-parameters-limit) 1024)) (vars (loop repeat n collect (gensym)))) (eval `(eqlt ,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 = `(ignore-errors (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 = `(ignore-errors (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 = `(ignore-errors (labels (((setf ,s) (&rest args) (declare (ignore args)) 'a)) (setf (,s) 10))) unless (eq (eval form) 'a) collect s) nil) ;;; Check that LABELS does not have a tagbody (deftest labels.27 (block done (tagbody (labels ((%f () (go 10) 10 (return-from done 'bad))) (%f)) 10 (return-from done 'good))) good) ;;; Check that nil keyword arguments do not enable the default values (deftest labels.28 (labels ((%f (&key (a 'wrong)) a)) (%f :a nil)) nil) (deftest labels.29 (labels ((%f (&key (a 'wrong a-p)) (list a (not a-p)))) (%f :a nil)) (nil nil)) (deftest labels.30 (labels ((%f (&key ((:a b) 'wrong)) b)) (%f :a nil)) nil) (deftest labels.31 (labels ((%f (&key ((:a b) 'wrong present?)) (list b (not present?)))) (%f :a nil)) (nil nil)) (deftest labels.32 (labels ((%f (&key) 'good)) (%f :allow-other-keys nil)) good) (deftest labels.33 (labels ((%f (&key) 'good)) (%f :allow-other-keys t)) good) (deftest labels.34 (labels ((%f (&key) 'good)) (%f :allow-other-keys t :a 1 :b 2)) good) (deftest labels.35 (labels ((%f (&key &allow-other-keys) 'good)) (%f :a 1 :b 2)) good) ;;; NIL as a disallowed keyword argument (deftest labels.36 (signals-error (labels ((%f (&key) :bad)) (%f nil nil)) program-error) t) ;;; Identity of function objects ;;; Since (FUNCTION ) returns *the* functional value, it ;;; should be the case that different invocations of this form ;;; in the same lexical environment return the same value. (deftest labels.37 (labels ((f () 'foo)) (eqt #'f #'f)) t) (deftest labels.38 (labels ((f () 'foo)) (destructuring-bind (x y) (loop repeat 2 collect #'f) (eqlt x y))) t) (deftest labels.39 (labels ((f () #'f)) (eqlt (f) #'f)) t) (deftest labels.40 (let ((x (labels ((f () #'f)) #'f))) (eqlt x (funcall x))) t) ;;; Test that free declarations do not affect argument forms (deftest labels.41 (let ((x :bad)) (declare (special x)) (let ((x :good)) (labels ((%f (&optional (y x)) (declare (special x)) y)) (%f)))) :good) (deftest labels.42 (let ((x :bad)) (declare (special x)) (let ((x :good)) (labels ((%f (&key (y x)) (declare (special x)) y)) (%f)))) :good) (deftest labels.43 (let ((x :bad)) (declare (special x)) (let ((x :good)) (labels () (declare (special x))) x)) :good) (deftest labels.44 (let ((x :bad)) (declare (special x)) (let ((x :good)) (labels ((%f () (declare (special x))))) x)) :good) (deftest labels.45 (let ((x :bad)) (declare (special x)) (let ((x :good)) (labels ((%f () (declare (special x)))) x))) :good) (deftest labels.46 (let ((x :bad)) (declare (special x)) (let ((x :good)) (labels ((%f (&aux (y x)) (declare (special x)) y)) (%f)))) :good) (deftest labels.47 (let ((x :bad)) (declare (special x)) (let ((x :good)) (labels ((%f () x)) (declare (special x)) (%f)))) :good) ;;; Macros are expanded in the appropriate environment (deftest labels.48 (macrolet ((%m (z) z)) (labels () (expand-in-current-env (%m :good)))) :good) (deftest labels.49 (macrolet ((%m (z) z)) (labels ((%f () (expand-in-current-env (%m :good)))) (%f))) :good) gcl27-2.7.0/ansi-tests/lambda-list-keywords.lsp000066400000000000000000000020551454061450500213140ustar00rootroot00000000000000;-*- 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) (and (symbolp sym) (let ((name (symbol-name sym))) (and (> (length name) 0) (eql (aref name 0) #\&))))) lambda-list-keywords) nil) gcl27-2.7.0/ansi-tests/lambda-parameters-limit.lsp000066400000000000000000000005671454061450500217610ustar00rootroot00000000000000;-*- 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 gcl27-2.7.0/ansi-tests/lambda.lsp000066400000000000000000000173731454061450500165070ustar00rootroot00000000000000;-*- 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) (ignorable x))) 'z) nil) (deftest lambda.11 ((lambda (x &optional y z) (list x y z)) 1 2) (1 2 nil)) (deftest lambda.12 ((lambda (&optional (x 'a) (y 'b) (z 'c)) (list x y z)) 1 nil) (1 nil c)) (deftest lambda.13 ((lambda (&optional (x 'a x-p) (y 'b y-p) (z 'c z-p)) (list* x y z (mapcar #'notnot (list x-p y-p z-p)))) 1 nil) (1 nil c t t nil)) (deftest lambda.14 (let ((x 1)) ((lambda (&optional (x (1+ x))) x))) 2) (deftest lambda.15 ((lambda (y &optional (x (1+ y))) (list y x)) 10) (10 11)) (deftest lambda.16 ((lambda (y &optional (x (1+ y))) (list y x)) 10 14) (10 14)) (deftest lambda.17 ((lambda (&rest x) x) 1 2 3) (1 2 3)) (deftest lambda.18 (let ((b 10)) ((lambda (&optional (a b) (b (1+ a))) (list a b)) 3 7)) (3 7)) (deftest lambda.19 (let ((b 10)) ((lambda (&optional (a b) (b (1+ a))) (list a b)) 3)) (3 4)) (deftest lambda.20 (let ((b 10)) ((lambda (&optional (a b) (b (1+ a))) (list a b)))) (10 11)) (deftest lambda.21 (flet ((%f () (locally (declare (special *x*)) (incf *x*)))) ((lambda (*x*) (declare (special *x*)) (%f) *x*) 10)) 11) (deftest lambda.22 (flet ((%f () (locally (declare (special *x*)) (1+ *x*)))) ((lambda (*x*) (declare (special *x*)) (%f)) 15)) 16) (deftest lambda.23 ((lambda (&key a) a)) nil) (deftest lambda.24 ((lambda (&key a b c) (list a b c))) (nil nil nil)) (deftest lambda.25 ((lambda (&key (a 1) (b 2) (c 3)) (list a b c))) (1 2 3)) (deftest lambda.26 ((lambda (&key))) nil) (deftest lambda.27 ((lambda (&key) 'good) :allow-other-keys nil) good) (deftest lambda.28 ((lambda (&key) 'good) :allow-other-keys t :foo t) good) (deftest lambda.29 ((lambda (&key) 'good) :allow-other-keys t :allow-other-keys nil :foo t) good) (deftest lambda.30 ((lambda (&key x) x) :allow-other-keys t :x 10 :allow-other-keys nil :foo t) 10) (deftest lambda.31 ((lambda (&rest x &key) x)) nil) (deftest lambda.32 ((lambda (&rest x &key) x) :allow-other-keys nil) (:allow-other-keys nil)) (deftest lambda.33 ((lambda (&rest x &key) x) :w 5 :allow-other-keys t :x 10) (:w 5 :allow-other-keys t :x 10)) (deftest lambda.34 ((lambda (&key (a 1 a-p) (b 2 b-p) (c 3 c-p)) (list a (notnot a-p) b (notnot b-p) c (notnot c-p))) :c 5 :a 0) (0 t 2 nil 5 t)) (deftest lambda.35 ((lambda (&key (a 1 a-p) (b 2 b-p) (c 3 c-p)) (list a (notnot a-p) b (notnot b-p) c (notnot c-p))) :c 5 :a nil :a 17 :c 100) (nil t 2 nil 5 t)) (deftest lambda.36 ((lambda (&key (a 1 a-p) (b 2 b-p) (c 3 c-p)) (list a (notnot a-p) b (notnot b-p) c (notnot c-p))) :c 5 :a 0 :allow-other-keys t 'b 100) (0 t 2 nil 5 t)) (deftest lambda.37 (let ((b 1)) ((lambda (&key (a b) b) (list a b)) :b 'x)) (1 x)) (deftest lambda.38 (let ((b 1)) ((lambda (&key (a b) b) (list a b)) :b 'x :a nil)) (nil x)) (deftest lambda.39 (let ((a-p :bad)) (declare (ignorable a-p)) ((lambda (&key (a nil a-p) (b a-p)) (list a (notnot a-p) (notnot b))))) (nil nil nil)) (deftest lambda.40 (let ((a-p :bad)) (declare (ignorable a-p)) ((lambda (&key (a nil a-p) (b a-p)) (list a (notnot a-p) (notnot b))) :a 1)) (1 t t)) (deftest lambda.41 (let ((a-p :bad)) (declare (ignorable a-p)) ((lambda (&key (a nil a-p) (b a-p)) (list a (notnot a-p) (notnot b))) :a nil)) (nil t t)) (deftest lambda.42 ((lambda (&key a b &allow-other-keys) (list a b)) :a 1 :b 2) (1 2)) (deftest lambda.43 ((lambda (&key a b &allow-other-keys) (list a b)) :b 2 :a 1) (1 2)) (deftest lambda.44 ((lambda (&key a b &allow-other-keys) (list a b)) :z 10 :b 2 :b nil :a 1 :a 2 'x 100) (1 2)) (deftest lambda.45 ((lambda (&key a b &allow-other-keys) (list a b)) :allow-other-keys nil :z 10 :b 2 :b nil :a 1 :a 2 'x 100) (1 2)) (deftest lambda.46 ((lambda (&key a b allow-other-keys) (list allow-other-keys a b)) :allow-other-keys nil :a 1 :b 2) (nil 1 2)) (deftest lambda.47 ((lambda (&key a b allow-other-keys) (list allow-other-keys a b)) :c 10 :allow-other-keys t :a 1 :b 2 :d 20) (t 1 2)) (deftest lambda.48 ((lambda (&key a b allow-other-keys &allow-other-keys) (list allow-other-keys a b)) :d 40 :allow-other-keys nil :a 1 :b 2 :c 20) (nil 1 2)) (deftest lambda.49 ((lambda (&key a b allow-other-keys &allow-other-keys) (list allow-other-keys a b)) :d 40 :a 1 :b 2 :c 20) (nil 1 2)) (deftest lambda.50 ((lambda (&key a b ((:allow-other-keys aok))) (list aok a b)) :d 40 :a 1 :allow-other-keys t :b 2 :c 20) (t 1 2)) (deftest lambda.51 ((lambda (&key &allow-other-keys)) :a 1 :b 2 :c 3) nil) ;;; Free declaration scope (deftest lambda.52 (let ((x :bad)) (declare (special x)) (let ((x :good)) ((lambda (&optional (y x)) (declare (special x)) y)))) :good) (deftest lambda.53 (let ((x :bad)) (declare (special x)) (let ((x :good)) ((lambda (&key (y x)) (declare (special x)) y)))) :good) (deftest lambda.54 (let ((x :bad)) (declare (special x)) (let ((x :good)) ((lambda (&aux (y x)) (declare (special x)) y)))) :good) (deftest lambda.55 (let* ((doc "LMB55") (fn (eval `#'(lambda () ,doc nil))) (cfn (compile nil fn))) (values (or (documentation fn t) doc) (or (documentation cfn t) doc))) "LMB55" "LMB55") (deftest lambda.56 (let* ((doc "LMB56") (fn (eval `#'(lambda () ,doc nil))) (cfn (compile nil fn))) (values (or (documentation fn 'function) doc) (or (documentation cfn 'function) doc))) "LMB56" "LMB56") ;;; Uninterned symbols as lambda variables (deftest lambda.57 ((lambda (#1=#:foo) #1#) 17) 17) (deftest lambda.58 ((lambda (&rest #1=#:foo) #1#) 'a 'b 'c) (a b c)) (deftest lambda.59 ((lambda (&optional #1=#:foo) #1#)) nil) (deftest lambda.60 ((lambda (&optional (#1=#:foo t)) #1#)) t) (deftest lambda.61 ((lambda (&optional (#1=#:foo t)) #1#) 'bar) bar) (deftest lambda.62 ((lambda (&key #1=#:foo) #1#) :foo 12) 12) ;;; Test that declarations for aux variables are handled properly (deftest lambda.63 (let ((y :bad1)) (declare (ignore y)) (let ((y :bad2)) (declare (special y)) (flet ((%f () y)) ((lambda (x &aux (y :good)) (declare (special y) (ignore x)) (%f)) nil)))) :good) (deftest lambda.64 (let ((x :bad)) (declare (special x)) (flet ((%f () x)) ((lambda (x &aux (y (%f))) (declare (type t y) (special x)) y) :good))) :good) ;;; 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) ;;; Error tests (deftest lambda.error.1 (signals-error (funcall (macro-function 'lambda)) program-error) t) (deftest lambda.error.2 (signals-error (funcall (macro-function 'lambda) '(lambda ())) program-error) t) (deftest lambda.error.3 (signals-error (funcall (macro-function 'lambda) '(lambda ()) nil nil) program-error) t) gcl27-2.7.0/ansi-tests/last.lsp000066400000000000000000000040251454061450500162200ustar00rootroot00000000000000;-*- 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) (compile-and-load "cons-aux.lsp") (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.11 (let ((x '(a b c))) (eqt (last x (1+ most-positive-fixnum)) x)) t) (deftest last.12 (let ((x '(a b c . d))) (eqt (last x (1+ most-positive-fixnum)) x)) t) (deftest last.13 (let ((x '(a b c . d))) (eqt (last x most-positive-fixnum) x)) t) (deftest last.14 (let ((x '(a b c . d))) (eqt (last x (1- most-positive-fixnum)) x)) t) (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 (signals-error (last (list 'a 'b 'c) -1) type-error) t) (deftest last.error.2 (signals-error (last (list 'a 'b 'c) 'a) type-error) t) (deftest last.error.3 (signals-error (last (list 'a 'b 'c) 10.0) type-error) t) (deftest last.error.4 (signals-error (last (list 'a 'b 'c) -10.0) type-error) t) (deftest last.error.5 (signals-error (last (list 'a 'b 'c) #\w) type-error) t) (deftest last.error.6 (signals-error (last) program-error) t) (deftest last.error.7 (signals-error (last '(a b c) 2 nil) program-error) t) (deftest last.error.8 (signals-error (locally (last (list 'a 'b 'c) 'a) t) type-error) t) gcl27-2.7.0/ansi-tests/lcm.lsp000066400000000000000000000040731454061450500160330ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Sep 4 22:03:21 2003 ;;;; Contains: Tests of LCM (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "gcd-aux.lsp") (deftest lcm.error.1 (check-type-error #'lcm #'integerp) nil) (deftest lcm.1 (lcm) 1) (deftest lcm.2 (loop for i = (random-fixnum) for a = (abs i) repeat 1000 unless (and (eql a (lcm i)) (eql a (lcm 1 i))) collect i) nil) (deftest lcm.3 (loop for i = (random-from-interval 10000000000000000) for a = (abs i) repeat 1000 unless (and (eql a (lcm i)) (eql a (lcm i 1))) collect i) nil) (deftest lcm.4 (loop for i = (random-fixnum) for j = (random-fixnum) repeat 1000 unless (eql (my-lcm i j) (lcm i j)) collect (list i j)) nil) (deftest lcm.5 (let ((bound (ash 1 200))) (loop for i = (random-from-interval bound) for j = (random-from-interval bound) repeat 1000 unless (eql (my-lcm i j) (lcm i j)) collect (list i j))) nil) (deftest lcm.6 (loop for i = (random-fixnum) for j = (random-fixnum) for k = (random-fixnum) repeat 1000 unless (eql (my-lcm i (my-lcm j k)) (lcm i j k)) collect (list i j k)) nil) (deftest lcm.7 (loop for i = (random-fixnum) for j = (random-fixnum) for k = (random-fixnum) for n = (random-fixnum) repeat 1000 unless (eql (my-lcm (my-lcm i j) (my-lcm k n)) (lcm i j k n)) collect (list i j k n)) nil) (deftest lcm.8 (loop for i from 1 to (min 256 (1- call-arguments-limit)) always (eql (apply #'lcm (make-list i :initial-element 1)) 1)) t) (deftest lcm.9 (lcm 0 0) 0) (deftest lcm.10 (lcm 1 0 0) 0) (deftest lcm.11 (lcm 0 1 0) 0) (deftest lcm.12 (lcm 0 0 1) 0) (deftest lcm.order.1 (let ((i 0) x y) (values (lcm (progn (setf x (incf i)) 15) (progn (setf y (incf i)) 25)) i x y)) 75 2 1 2) (deftest lcm.order.2 (let ((i 0) x y) (values (lcm (progn (setf x (incf i)) 0) (progn (setf y (incf i)) 10)) i x y)) 0 2 1 2) (deftest lcm.order.3 (let ((i 0)) (values (lcm (progn (incf i) 0)) i)) 0 1) gcl27-2.7.0/ansi-tests/ldb.lsp000066400000000000000000000037101454061450500160160ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Sep 11 20:45:17 2003 ;;;; Contains: Tests of LDB (in-package :cl-test) ;;; Error tests (deftest ldb.error.1 (signals-error (ldb) program-error) t) (deftest ldb.error.2 (signals-error (ldb (byte 1 1)) program-error) t) (deftest ldb.error.3 (signals-error (ldb (byte 1 1) -1 0) program-error) t) ;;; Non-error tests (deftest ldb.1 (loop for x = (random-fixnum) for pos = (random 30) for size = (random 30) repeat 10000 unless (eql (ldb (byte size pos) x) (logand (1- (ash 1 size)) (ash x (- pos)))) collect (list x pos size)) nil) (deftest ldb.2 (let ((bound (ash 1 300))) (loop for x = (random-from-interval bound) for pos = (random 300) for size = (random 300) repeat 1000 unless (eql (ldb (byte size pos) x) (logand (1- (ash 1 size)) (ash x (- pos)))) collect (list x pos size))) nil) (deftest ldb.3 (loop for i of-type fixnum from -1000 to 1000 always (eql (ldb (byte 0 0) i) 0)) t) (deftest ldb.order.1 (let ((i 0) a b c d) (values (ldb (progn (setf a (incf i)) (byte (progn (setf b (incf i)) 3) (progn (setf c (incf i)) 1))) (progn (setf d (incf i)) -1)) i a b c d)) 7 4 1 2 3 4) ;;; ldb on places (deftest ldb.place.1 (let ((x 0)) (values (setf (ldb (byte 4 1) x) -1) x)) -1 30) (deftest ldb.place.2 (loop for pos from 0 to 100 always (loop for size from 0 to 100 always (let ((x 0)) (and (eql (setf (ldb (byte size pos) x) -1) -1) (eql x (ash (1- (ash 1 size)) pos)))))) t) (deftest ldb.place.order.1 (let ((i 0) a b c d e f (x (copy-seq #(63)))) (values (setf (ldb (progn (setf a (incf i)) (byte (progn (setf b (incf i)) 3) (progn (setf c (incf i)) 1))) (aref (progn (setf d (incf i)) x) (progn (setf e (incf i)) 0))) (progn (setf f (incf i)) 0)) x i a b c d e f)) 0 #(49) 6 1 2 3 4 5 6) gcl27-2.7.0/ansi-tests/ldiff.lsp000066400000000000000000000076651454061450500163560ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:46:56 2003 ;;;; Contains: Tests of LDIFF (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) (def-fold-test ldiff.fold.1 (ldiff '(a b c) 'x)) (def-fold-test ldiff.fold.2 (let ((x '(a b c))) (ldiff x (cddr x)))) ;; Error checking (deftest ldiff.error.1 (signals-type-error x 10 (ldiff x 'a)) t) ;; Single atoms are not dotted lists, so the next ;; case should be a type-error (deftest ldiff.error.2 (signals-type-error x 'a (ldiff x 'a)) t) (deftest ldiff.error.3 (signals-type-error x (make-array '(10) :initial-element 'a) (ldiff x '(a))) t) (deftest ldiff.error.4 (signals-type-error x 1.23 (ldiff x t)) t) (deftest ldiff.error.5 (signals-type-error x #\w (ldiff x 'a)) t) (deftest ldiff.error.6 (signals-error (ldiff) program-error) t) (deftest ldiff.error.7 (signals-error (ldiff nil) program-error) t) (deftest ldiff.error.8 (signals-error (ldiff nil nil nil) program-error) t) ;; 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) |# gcl27-2.7.0/ansi-tests/length.lsp000066400000000000000000000074741454061450500165510ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Aug 20 23:25:29 2002 ;;;; Contains: Test cases for LENGTH (in-package :cl-test) (deftest length.list.1 (length nil) 0) (deftest length.list.2 (length '(a b c d e)) 5) (deftest length.list.3 (length (make-list 200000)) 200000) (defun length.list-4-body () (let ((x ())) (loop for i from 0 to 999 do (progn (unless (eql (length x) i) (return nil)) (push i x)) finally (return t)))) (deftest length.list-4 (length.list-4-body) t) (deftest length.vector.1 (length #()) 0) (deftest length.vector.2 (length #(a)) 1) (deftest length.vector.3 (length #(a b)) 2) (deftest length.vector.4 (length #(a b c)) 3) (deftest length.nonsimple-vector.1 (length (make-array 10 :fill-pointer t :adjustable t)) 10) (deftest length.nonsimple-vector.2 (let ((a (make-array 10 :fill-pointer t :adjustable t))) (setf (fill-pointer a) 5) (length a)) 5) `(deftest length.bit-vector.1 (length #*) 0) (deftest length.bit-vector.2 (length #*1) 1) (deftest length.bit-vector.3 (length #*0) 1) (deftest length.bit-vector.4 (length #*010101) 6) (deftest length.bit-vector.5 (let ((i 0)) (flet ((%f () (incf i) (make-array 5 :element-type 'bit :initial-contents '(0 0 1 1 0)))) (values (length (the (simple-bit-vector 5) (%f))) i))) 5 1) (deftest length.string.1 (length "") 0) (deftest length.string.2 (length "a") 1) (deftest length.string.3 (length "abcdefghijklm") 13) (deftest length.string.4 (length "\") 1) (deftest length.string.5 (let ((i 0)) (flet ((%f () (incf i) (make-string 5 :initial-element #\a))) (values (length (the (simple-string 5) (%f))) i))) 5 1) (deftest length.string.6 (let ((i 0)) (flet ((%f () (incf i) (make-array 5 :element-type 'base-char :initial-element #\a))) (values (length (the (simple-base-string 5) (%f))) i))) 5 1) (deftest length.string.7 (do-special-strings (s "12345" nil) (assert (= (length s) 5))) nil) (deftest length.string.8 (do-special-strings (s "" nil) (assert (= (length s) 0))) nil) ;;; Error cases (deftest length.error.1 (check-type-error #'length #'(lambda (x) (typep x 'sequence))) nil) (deftest length.error.6 (signals-error (length) program-error) t) (deftest length.error.7 (signals-error (length nil nil) program-error) t) (deftest length.error.8 (signals-error (locally (length 'a) t) type-error) t) ;;; Length on vectors created with make-array (deftest length.array.1 (length (make-array '(20))) 20) (deftest length.array.2 (length (make-array '(100001))) 100001) (deftest length.array.3 (length (make-array '(0))) 0) (deftest length.array.4 (let ((x (make-array '(100) :fill-pointer 10))) (length x)) 10) (deftest length.array.5 (let ((x (make-array '(100) :fill-pointer 10))) (setf (fill-pointer x) 20) (length x)) 20) ;;; Unusual vectors (deftest length.array.6 (loop for i from 1 to 40 for etype = `(unsigned-byte ,i) for vec = (make-array 7 :element-type etype :initial-element 0) for len = (length vec) unless (eql len 7) collect (list i vec len)) nil) (deftest length.array.7 (loop for i from 1 to 40 for etype = `(signed-byte ,i) for vec = (make-array 13 :element-type etype :initial-element 0) for len = (length vec) unless (eql len 13) collect (list i vec len)) nil) (deftest length.array.8 (loop for etype in '(short-float single-float double-float long-float rational) for vec = (make-array 5 :element-type etype :initial-element (coerce 0 etype)) for len = (length vec) unless (eql len 5) collect (list etype vec len)) nil) (deftest length.array.9 (do-special-integer-vectors (v #(0 1 1 0 0 1) nil) (assert (eql (length v) 6))) nil) gcl27-2.7.0/ansi-tests/let.lsp000066400000000000000000000064661454061450500160540ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 12 09:24:36 2002 ;;;; Contains: Tests for LET, LET* (in-package :cl-test) ;;; LET and LET* are also heavily exercised in the many other tests. ;;; NOTE! Some of these tests bind a variable with the same name ;;; more than once. This apparently has underdetermined semantics that ;;; varies in different Lisps. (deftest let.1 (let ((x 0)) x) 0) (deftest let.2 (let ((x 0) (y 1)) (values x y)) 0 1) (deftest let.3 (let ((x 0) (y 1)) (declare (special x y)) (values x y)) 0 1) (deftest let.4 (let ((x 0)) (let ((x 1)) x)) 1) (deftest let.5 (let ((x 0)) (let ((#:x 1)) x)) 0) (deftest let.6 (let ((x 0)) (declare (special x)) (let ((x 1)) (values x (locally (declare (special x)) x)))) 1 0) (deftest let.7 (let ((x '(a b c))) (declare (dynamic-extent x)) x) (a b c)) ;;;(deftest let.8 ;;; (let ((x 0) (x 1)) x) ;;; 1) (deftest let.9 (let (x y z) (values x y z)) nil nil nil) ;;; (deftest let.10 ;;; (let ((x 1) x) x) ;;; nil) (deftest let.11 (let ((x 1)) (list x (let (x) (declare (special x)) x) x)) (1 nil 1)) ;;; (deftest let.12 ;;; (let ((x 0)) ;;; (values ;;; (let ((x 20) ;;; (x (1+ x))) ;;; x) ;;; x)) ;;; 1 0) ;;; (deftest let.13 ;;; (flet ((%f () (declare (special x)) ;;; (if (boundp 'x) x 10))) ;;; (let ((x 1) ;;; (x (1+ (%f)))) ;;; (declare (special x)) ;;; x)) ;;; 11) ;;; Tests of large number of LET variables (deftest let.14 (let* ((n 100) (vars (mapcar #'gensym (make-list n :initial-element "G"))) (expr `(let ,(let ((i 0)) (mapcar #'(lambda (v) (list v (incf i))) vars)) ,(let ((sumexpr 0)) (dolist (v vars) (setq sumexpr `(+ ,v ,sumexpr))) sumexpr))) (val (eval expr))) (or (eqlt val (/ (* n (1+ n)) 2)) (list val))) t) ;;; Test that all non-variables exported from COMMON-LISP can be bound ;;; in LET forms. (deftest let.15 (loop for s in *cl-non-variable-constant-symbols* for form = `(ignore-errors (let ((,s 17)) ,s)) unless (eql (eval form) 17) collect s) nil) ;;; Check that LET does not have a tagbody (deftest let.16 (block done (tagbody (let () (go 10) 10 (return-from done 'bad)) 10 (return-from done 'good))) good) ;;; Check that free declarations do not apply to the init forms (deftest let.17 (let ((x :bad)) (declare (special x)) (let ((x :good)) ;; lexical binding (let ((y x)) (declare (special x)) ;; free declaration y))) :good) (deftest let.17a (funcall (compile nil '(lambda () (let ((x :bad)) (declare (special x)) (let ((x :good)) ;; lexical binding (let ((y x)) (declare (special x)) ;; free declaration y)))))) :good) (deftest let.18 (let ((foo 'special)) (declare (special foo)) (let ((foo 'lexical)) (locally (declare (special foo))) foo)) lexical) (deftest let.19 (loop for k in lambda-list-keywords unless (eql (eval `(let ((,k :foo)) ,k)) :foo) collect k) nil) ;;; Macros are expanded in the appropriate environment (deftest let.20 (macrolet ((%m (z) z)) (let () (expand-in-current-env (%m :good)))) :good) (deftest let.21 (macrolet ((%m (z) z)) (let ((x (expand-in-current-env (%m 1)))) (+ x x x))) 3) gcl27-2.7.0/ansi-tests/letstar.lsp000066400000000000000000000066661454061450500167500ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Jun 24 20:53:36 2005 ;;;; Contains: Tests for LET* (in-package :cl-test) (deftest let*.1 (let* ((x 0)) x) 0) (deftest let*.2 (let* ((x 0) (y 1)) (values x y)) 0 1) (deftest let*.3 (let* ((x 0) (y 1)) (declare (special x y)) (values x y)) 0 1) (deftest let*.4 (let* ((x 0)) (let* ((x 1)) x)) 1) (deftest let*.5 (let* ((x 0)) (let* ((#:x 1)) x)) 0) (deftest let*.6 (let* ((x 0)) (declare (special x)) (let* ((x 1)) (values x (locally (declare (special x)) x)))) 1 0) (deftest let*.7 (let* ((x '(a b c))) (declare (dynamic-extent x)) x) (a b c)) (deftest let*.8 (let* ((x 0) (x 1)) x) 1) (deftest let*.9 (let* (x y z) (values x y z)) nil nil nil) (deftest let*.10 (let* ((x 1) x) x) nil) (deftest let*.11 (let* ((x 1)) (list x (let* (x x x) (declare (special x)) x) x)) (1 nil 1)) (deftest let*.12 (let* ((x 1) (y (1+ x)) (x (1+ y)) (z (+ x y))) (values x y z)) 3 2 5) ;;; (deftest let*.13 ;;; (flet ((%f () (declare (special x)) x)) ;;; (let* ((x 1) ;;; (x (1+ (%f)))) ;;; (declare (special x)) ;;; x)) ;;; 2) ;;; Tests of large number of LET* variables (deftest let*.14 (let* ((n 100) (vars (mapcar #'gensym (make-list n :initial-element "G"))) (expr `(let* ,(let ((i 0)) (mapcar #'(lambda (v) (list v (incf i))) vars)) ,(let ((sumexpr 0)) (dolist (v vars) (setq sumexpr `(+ ,v ,sumexpr))) sumexpr))) (val (eval expr))) (or (eqlt val (/ (* n (1+ n)) 2)) (list val))) t) ;;; Test that all non-variables exported from COMMON-LISP can be bound ;;; in LET* forms. (deftest let*.15 (loop for s in *cl-non-variable-constant-symbols* for form = `(ignore-errors (let* ((,s 17)) ,s)) unless (eql (eval form) 17) collect s) nil) ;;; Check that LET* does not have a tagbody (deftest let*.16 (block done (tagbody (let () (go 10) 10 (return-from done 'bad)) 10 (return-from done 'good))) good) ;;; Check that free declarations do not apply to the init forms (deftest let*.17 (let ((x :bad)) (declare (special x)) (let ((x :good)) ;; lexical binding (let* ((y x)) (declare (special x)) ;; free declaration y))) :good) (deftest let*.17a (funcall (compile nil '(lambda () (let ((x :bad)) (declare (special x)) (let ((x :good)) ;; lexical binding (let* ((y x)) (declare (special x)) ;; free declaration y)))))) :good) (deftest let*.18 (let ((x :bad1) (z :bad2)) (declare (special x z)) (let ((x :good) (z :good)) ;; lexical bindings (let* ((y x) (w z)) (declare (special x)) ;; free declaration (values y w)))) :good :good) (deftest let*.19 (let ((foo 'special)) (declare (special foo)) (let* ((foo 'lexical)) (locally (declare (special foo))) foo)) lexical) (deftest let*.20 (loop for k in lambda-list-keywords unless (eql (eval `(let* ((,k :foo)) ,k)) :foo) collect k) nil) ;;; Macros are expanded in the appropriate environment (deftest let*.21 (macrolet ((%m (z) z)) (let* () (expand-in-current-env (%m :good)))) :good) (deftest let*.22 (macrolet ((%m (z) z)) (let* ((x (expand-in-current-env (%m 1)))) (+ x x x))) 3) (deftest let*.23 (macrolet ((%m (z) z)) (let* ((x (expand-in-current-env (%m 1))) (y (expand-in-current-env (%m 2)))) (+ x y))) 3) gcl27-2.7.0/ansi-tests/list-all-packages.lsp000066400000000000000000000022421454061450500205510ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 21 17:47:37 2004 ;;;; Contains: Tests of LIST-ALL-PACKAGES (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 (progn (set-up-packages) (notnot (subsetp (list (find-package "CL") (find-package "CL-USER") (find-package "KEYWORD") (find-package "A") (find-package "REGRESSION-TEST") (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 (signals-error (list-all-packages nil) program-error) t) gcl27-2.7.0/ansi-tests/list-length.lsp000066400000000000000000000030461454061450500175110ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:03:01 2003 ;;;; Contains: Tests of LIST-LENGTH (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) (deftest list-length.4 (list-length (copy-tree '(a b c))) 3) ;; 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 (eval `(signals-type-error x ',x (list-length x))))) 0) (deftest list-length.error.2 (signals-error (list-length) program-error) t) (deftest list-length.error.3 (signals-error (list-length nil nil) program-error) t) (deftest list-length.error.4 (signals-error (list-length 'a) type-error) t) (deftest list-length.error.5 (signals-error (locally (list-length 'a) t) type-error) t) (deftest list-length-symbol (signals-error (list-length 'a) type-error) t) (deftest list-length-dotted-list (signals-error (list-length (copy-tree '(a b c d . e))) type-error) t) gcl27-2.7.0/ansi-tests/list.lsp000066400000000000000000000031001454061450500162210ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:56:04 2003 ;;;; Contains: Tests of LIST, LIST* (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) (def-fold-test list.fold.1 (list 'a)) (def-fold-test list.fold.2 (list 'a 'b)) (def-fold-test list.fold.3 (list 'a 'b 'c 'd 'e 'f)) ;;; LIST* tests (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)) (def-fold-test list*.fold.1 (list* 'a 'b)) (def-fold-test list*.fold.2 (list* 'a 'b 'c)) (def-fold-test list*.fold.3 (list* 'a 'b 'c 'd 'e 'f)) gcl27-2.7.0/ansi-tests/listen.lsp000066400000000000000000000027641454061450500165630ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 27 21:16:39 2004 ;;;; Contains: Tests of LISTEN (in-package :cl-test) (deftest listen.1 (with-input-from-string (s "") (listen s)) nil) (deftest listen.2 (with-input-from-string (s "x") (notnot-mv (listen s))) t) (deftest listen.3 (with-input-from-string (*standard-input* "") (listen)) nil) (deftest listen.4 (with-input-from-string (*standard-input* "A") (notnot-mv (listen))) t) ;;; (deftest listen.5 ;;; (when (interactive-stream-p *standard-input*) ;;; (clear-input) (listen)) ;;; nil) (deftest listen.6 (with-input-from-string (s "x") (values (read-char s) (listen s) (unread-char #\x s) (notnot (listen s)) (read-char s))) #\x nil nil t #\x) (deftest listen.7 (with-open-file (s "listen.lsp") (values (notnot (listen s)) (handler-case (locally (declare (optimize safety)) (loop (read-char s))) (end-of-file () (listen s))))) t nil) (deftest listen.8 (with-input-from-string (is "abc") (let ((*terminal-io* (make-two-way-stream is (make-broadcast-stream)))) (notnot-mv (listen t)))) t) (deftest listen.9 (with-input-from-string (*standard-input* "345") (notnot-mv (listen nil))) t) ;;; Error tests (deftest listen.error.1 :notes (:assume-no-simple-streams) (signals-error (listen *standard-input* nil) program-error) t) (deftest listen.error.2 (signals-error (listen *standard-input* nil nil) program-error) t) gcl27-2.7.0/ansi-tests/listp.lsp000066400000000000000000000015361454061450500164140ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:03:37 2003 ;;;; Contains: Tests of LISTP (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) nil) (deftest listp.order.1 (let ((i 0)) (values (listp (incf i)) i)) nil 1) (deftest listp.error.1 (signals-error (listp) program-error) t) (deftest listp.error.2 (signals-error (listp nil nil) program-error) t) gcl27-2.7.0/ansi-tests/load-arrays.lsp000066400000000000000000000023001454061450500174650ustar00rootroot00000000000000;;; Tests on arrays (compile-and-load "array-aux.lsp") (load "aref.lsp") (load "array.lsp") (load "array-t.lsp") (load "array-as-class.lsp") (load "simple-array.lsp") (load "simple-array-t.lsp") (load "bit-vector.lsp") (load "simple-bit-vector.lsp") (load "make-array.lsp") (load "adjust-array.lsp") (load "adjustable-array-p.lsp") (load "array-displacement.lsp") (load "array-dimension.lsp") (load "array-dimensions.lsp") (load "array-element-type.lsp") (load "array-in-bounds-p.lsp") (load "array-misc.lsp") (load "array-rank.lsp") (load "array-row-major-index.lsp") (load "array-total-size.lsp") (load "arrayp.lsp") (load "fill-pointer.lsp") (load "row-major-aref.lsp") (load "simple-vector-p.lsp") (load "svref.lsp") (load "upgraded-array-element-type.lsp") (load "vector.lsp") (load "vector-pop.lsp") (load "vector-push.lsp") (load "vector-push-extend.lsp") (load "vectorp.lsp") (load "bit.lsp") (load "sbit.lsp") (load "bit-and.lsp") (load "bit-andc1.lsp") (load "bit-andc2.lsp") (load "bit-eqv.lsp") (load "bit-ior.lsp") (load "bit-nand.lsp") (load "bit-nor.lsp") (load "bit-orc1.lsp") (load "bit-orc2.lsp") (load "bit-xor.lsp") (load "bit-not.lsp") (load "bit-vector-p.lsp") (load "simple-bit-vector-p.lsp") gcl27-2.7.0/ansi-tests/load-characters.lsp000066400000000000000000000004001454061450500203020ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jun 23 20:12:44 2005 ;;;; Contains: Load character tests (in-package :cl-test) (compile-and-load "char-aux.lsp") (load "character.lsp") (load "char-compare.lsp") (load "name-char.lsp") gcl27-2.7.0/ansi-tests/load-conditions.lsp000066400000000000000000000012651454061450500203460ustar00rootroot00000000000000;;; Tests of conditions (compile-and-load "types-aux.lsp") (compile-and-load "define-condition-aux.lsp") (load "condition.lsp") (load "cell-error-name.lsp") (load "assert.lsp") (load "error.lsp") (load "cerror.lsp") (load "check-type.lsp") (load "warn.lsp") (load "invoke-debugger.lsp") (load "handler-bind.lsp") (load "handler-case.lsp") (load "ignore-errors.lsp") (load "define-condition.lsp") (load "compute-restarts.lsp") (load "restart-bind.lsp") (load "restart-case.lsp") (load "with-condition-restarts.lsp") (load "with-simple-restart.lsp") (load "abort.lsp") (load "muffle-warning.lsp") (load "continue.lsp") (load "store-value.lsp") (load "use-value.lsp") (load "make-condition.lsp") gcl27-2.7.0/ansi-tests/load-cons.lsp000066400000000000000000000031621454061450500171350ustar00rootroot00000000000000;;; Tests of conses ;;; (compile-and-load "cons-aux.lsp") (load "cons.lsp") (load "consp.lsp") (load "atom.lsp") (load "cxr.lsp") (load "rplaca.lsp") (load "rplacd.lsp") (load "copy-tree.lsp") (load "sublis.lsp") (load "nsublis.lsp") (load "subst.lsp") (load "subst-if.lsp") (load "subst-if-not.lsp") (load "nsubst.lsp") (load "nsubst-if.lsp") (load "nsubst-if-not.lsp") (load "tree-equal.lsp") (load "copy-list.lsp") (load "list.lsp") (load "list-length.lsp") (load "listp.lsp") (load "make-list.lsp") (load "push.lsp") (load "pop.lsp") (load "pushnew.lsp") (load "adjoin.lsp") (load "nth.lsp") (load "endp.lsp") (load "nconc.lsp") (load "append.lsp") (load "revappend.lsp") (load "nreconc.lsp") (load "butlast.lsp") (load "nbutlast.lsp") (load "last.lsp") (load "ldiff.lsp") (load "tailp.lsp") (load "nthcdr.lsp") (load "rest.lsp") (load "member.lsp") (load "member-if.lsp") (load "member-if-not.lsp") (load "mapc.lsp") (load "mapcar.lsp") (load "mapcan.lsp") (load "mapl.lsp") (load "maplist.lsp") (load "mapcon.lsp") (load "acons.lsp") (load "assoc.lsp") (load "assoc-if.lsp") (load "assoc-if-not.lsp") (load "rassoc.lsp") (load "rassoc-if.lsp") (load "rassoc-if-not.lsp") (load "copy-alist.lsp") (load "pairlis.lsp") (load "get-properties.lsp") (load "getf.lsp") (load "remf.lsp") (load "intersection.lsp") (load "nintersection.lsp") (load "union.lsp") (load "nunion.lsp") (load "set-difference.lsp") (load "nset-difference.lsp") (load "set-exclusive-or.lsp") (load "nset-exclusive-or.lsp") (load "subsetp.lsp") ;;; Misc. stuff that should be moved elsewhere (load "cons-test-01.lsp") (load "cons-test-03.lsp") (load "cons-test-05.lsp") gcl27-2.7.0/ansi-tests/load-data-and-control-flow.lsp000066400000000000000000000034441454061450500222720ustar00rootroot00000000000000;;; Tests of data and control flow (load "data-and-control-flow.lsp") (load "places.lsp") (load "psetq.lsp") (load "psetf.lsp") (load "shiftf.lsp") (load "rotatef.lsp") (load "return.lsp") (load "return-from.lsp") (load "defsetf.lsp") (load "define-setf-expander.lsp") (load "and.lsp") (load "apply.lsp") (load "block.lsp") (load "call-arguments-limit.lsp") (load "case.lsp") (load "catch.lsp") (load "ccase.lsp") (load "compiled-function-p.lsp") (load "complement.lsp") (load "cond.lsp") (load "constantly.lsp") (load "ctypecase.lsp") (load "defconstant.lsp") (load "define-modify-macro.lsp") (load "defparameter.lsp") (load "defun.lsp") (load "defvar.lsp") (load "destructuring-bind.lsp") (load "ecase.lsp") (load "eql.lsp") (load "equal.lsp") (load "equalp.lsp") (load "etypecase.lsp") (load "every.lsp") (load "fboundp.lsp") (load "fdefinition.lsp") (load "flet.lsp") (load "fmakunbound.lsp") (load "funcall.lsp") (load "function-lambda-expression.lsp") (load "function.lsp") (load "functionp.lsp") (load "get-setf-expansion.lsp") (load "identity.lsp") (load "if.lsp") (load "labels.lsp") (load "lambda-list-keywords.lsp") (load "lambda-parameters-limit.lsp") (load "let.lsp") (load "letstar.lsp") (load "macrolet.lsp") (load "multiple-value-bind.lsp") (load "multiple-value-call.lsp") ;; include multiple-value-list (load "multiple-value-prog1.lsp") (load "multiple-value-setq.lsp") (load "multiple-value-list.lsp") (load "nil.lsp") (load "not-and-null.lsp") (load "notany.lsp") (load "notevery.lsp") (load "nth-value.lsp") (load "or.lsp") (load "prog.lsp") (load "prog1.lsp") (load "prog2.lsp") (load "progn.lsp") (load "progv.lsp") (load "some.lsp") (load "t.lsp") (load "tagbody.lsp") (load "typecase.lsp") (load "unless.lsp") (load "unwind-protect.lsp") (load "values-list.lsp") (load "values.lsp") (load "when.lsp") gcl27-2.7.0/ansi-tests/load-environment.lsp000066400000000000000000000011641454061450500205370ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Dec 12 19:43:17 2004 ;;;; Contains: Load environment tests (section 25) (load "apropos.lsp") (load "apropos-list.lsp") (load "describe.lsp") (load "disassemble.lsp") (load "environment-functions.lsp") (load "room.lsp") (load "time.lsp") (load "trace.lsp") ;; and untrace (load "user-homedir-pathname.lsp") (load "decode-universal-time.lsp") (load "encode-universal-time.lsp") (load "get-universal-time.lsp") (load "sleep.lsp") (load "get-internal-time.lsp") (load "documentation.lsp") #-lispworks (load "inspect.lsp") (load "dribble.lsp") (load "ed.lsp") gcl27-2.7.0/ansi-tests/load-eval-and-compile.lsp000066400000000000000000000012011454061450500213000ustar00rootroot00000000000000;;; Tests of evaluation and compilation (load "eval.lsp") (load "eval-and-compile.lsp") (load "compile.lsp") (load "compiler-macros.lsp") (load "constantp.lsp") (load "lambda.lsp") (load "eval-when.lsp") (load "define-compiler-macro.lsp") (load "define-symbol-macro.lsp") (load "defmacro.lsp") (load "the.lsp") (load "symbol-macrolet.lsp") (load "proclaim.lsp") (load "declaim.lsp") (load "locally.lsp") (load "ignore.lsp") (load "ignorable.lsp") (load "dynamic-extent.lsp") (load "optimize.lsp") (load "special.lsp") (load "macroexpand.lsp") (load "macroexpand-1.lsp") (load "declaration.lsp") (load "type.lsp") (load "macro-function.lsp") gcl27-2.7.0/ansi-tests/load-files.lsp000066400000000000000000000006161454061450500172760ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jan 1 11:59:35 2004 ;;;; Contains: Load tests of section 20, 'Files' (in-package :cl-test) (load "directory.lsp") (load "probe-file.lsp") (load "ensure-directories-exist.lsp") (load "truename.lsp") (load "file-author.lsp") (load "file-write-date.lsp") (load "rename-file.lsp") (load "delete-file.lsp") (load "file-error.lsp") gcl27-2.7.0/ansi-tests/load-format.lsp000066400000000000000000000017431454061450500174660ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Aug 2 21:47:02 2004 ;;;; Contains: Load format-related tests (in-package :cl-test) ;;; Format tests ;;; 22.3.1 (load "format-c.lsp") (load "formatter-c.lsp") (load "format-percent.lsp") (load "format-ampersand.lsp") (load "format-page.lsp") (load "format-tilde.lsp") ;;; 22.3.2 (load "format-r.lsp") (load "format-d.lsp") (load "format-b.lsp") (load "format-o.lsp") (load "format-x.lsp") ;;; 22.3.3 (load "format-f.lsp") ;;; 22.3.4 (load "format-a.lsp") (load "format-s.lsp") ;;; 22.3.5 (load "format-underscore.lsp") (load "format-logical-block.lsp") (load "format-i.lsp") (load "format-slash.lsp") ;;; 22.3.6 (load "format-t.lsp") (load "format-justify.lsp") ;;; 22.3.7 (load "format-goto.lsp") (load "format-conditional.lsp") (load "format-brace.lsp") (load "format-question.lsp") ;;; 22.3.8 (load "format-paren.lsp") (load "format-p.lsp") ;;; 22.3.9 (load "format-circumflex.lsp") (load "format-newline.lsp") gcl27-2.7.0/ansi-tests/load-hash-tables.lsp000066400000000000000000000006531454061450500203700ustar00rootroot00000000000000(compile-and-load "hash-table-aux.lsp") (load "hash-table.lsp") (load "make-hash-table.lsp") (load "hash-table-p.lsp") (load "hash-table-count.lsp") (load "hash-table-size.lsp") (load "hash-table-rehash-size.lsp") (load "hash-table-rehash-threshold.lsp") (load "hash-table-test.lsp") (load "gethash.lsp") (load "remhash.lsp") (load "clrhash.lsp") (load "maphash.lsp") (load "with-hash-table-iterator.lsp") (load "sxhash.lsp") gcl27-2.7.0/ansi-tests/load-iteration.lsp000066400000000000000000000007401454061450500201700ustar00rootroot00000000000000;;; Tests of iteration forms ;;(load "iteration.lsp") (load "do.lsp") (load "dostar.lsp") (load "dolist.lsp") (load "dotimes.lsp") (load "loop.lsp") (load "loop1.lsp") (load "loop2.lsp") (load "loop3.lsp") (load "loop4.lsp") (load "loop5.lsp") (load "loop6.lsp") (load "loop7.lsp") (load "loop8.lsp") (load "loop9.lsp") (load "loop10.lsp") (load "loop11.lsp") (load "loop12.lsp") (load "loop13.lsp") (load "loop14.lsp") (load "loop15.lsp") (load "loop16.lsp") (load "loop17.lsp") gcl27-2.7.0/ansi-tests/load-logical-pathname-translations.lsp000066400000000000000000000016371454061450500241240ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Dec 31 09:31:33 2003 ;;;; Contains: Tests (such as they are) for LOAD-LOGICAL-PATHNAME-TRANSLATIONS (in-package :cl-test) ;;; The function LOAD-LOGICAL-PATHNAME-TRANSLATIONS is almost entirely ;;; untestable, since the basic behavior is implementation defined. (deftest load-logical-pathname-translations.1 (load-logical-pathname-translations "CLTESTROOT") nil) ;;; Error cases (deftest load-logical-pathname-translations.error.1 (handler-case (progn (load-logical-pathname-translations "THEREHADBETTERNOTBEAHOSTCALLEDTHIS") nil) (error () :good)) :good) (deftest load-logical-pathname-translations.error.2 (signals-error (load-logical-pathname-translations) program-error) t) (deftest load-logical-pathname-translations.error.3 (signals-error (load-logical-pathname-translations "CLTESTROOT" nil) program-error) t) gcl27-2.7.0/ansi-tests/load-misc.lsp000066400000000000000000000005131454061450500171230ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jun 23 20:14:32 2005 ;;;; Contains: Load misc. tests ;;; Miscellaneous tests, mostly tests that failed in random testing ;;; on various implementations (load "misc.lsp") ;;; Misc. tests dealing with type propagation in CMUCL (load "misc-cmucl-type-prop.lsp") gcl27-2.7.0/ansi-tests/load-numbers.lsp000066400000000000000000000042211454061450500176430ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Apr 7 07:16:44 2003 ;;;; Contains: Forms to load files containing tests of number concepts (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "random-aux.lsp") (load "number-comparison.lsp") (load "max.lsp") (load "min.lsp") (load "minusp.lsp") (load "plusp.lsp") (load "zerop.lsp") (load "floor.lsp") (load "ffloor.lsp") (load "ceiling.lsp") (load "fceiling.lsp") (load "truncate.lsp") (load "ftruncate.lsp") (load "round.lsp") (load "fround.lsp") ;;; transcendental functions go here (load "sin.lsp") (load "cos.lsp") (load "tan.lsp") (load "asin.lsp") (load "acos.lsp") (load "atan.lsp") (load "sinh.lsp") (load "cosh.lsp") (load "tanh.lsp") (load "asinh.lsp") (load "acosh.lsp") (load "atanh.lsp") (load "times.lsp") (load "plus.lsp") (load "minus.lsp") (load "divide.lsp") (load "oneplus.lsp") (load "oneminus.lsp") (load "abs.lsp") (load "exp.lsp") (load "expt.lsp") (load "gcd.lsp") (load "incf.lsp") (load "decf.lsp") (load "lcm.lsp") (load "log.lsp") (load "signum.lsp") (load "sqrt.lsp") (load "isqrt.lsp") (load "random.lsp") (load "random-state-p.lsp") (load "make-random-state.lsp") (load "numberp.lsp") (load "cis.lsp") (load "complex.lsp") (load "complexp.lsp") (load "conjugate.lsp") (load "phase.lsp") (load "realpart.lsp") (load "imagpart.lsp") (load "realp.lsp") (load "numerator-denominator.lsp") (load "rationalp.lsp") (load "ash.lsp") (load "integer-length.lsp") (load "integerp.lsp") (load "parse-integer.lsp") (load "boole.lsp") (load "logand.lsp") (load "logandc1.lsp") (load "logandc2.lsp") (load "logeqv.lsp") (load "logior.lsp") (load "lognand.lsp") (load "lognor.lsp") (load "logorc1.lsp") (load "logorc2.lsp") (load "lognot.lsp") (load "logxor.lsp") (load "logbitp.lsp") (load "logcount.lsp") (load "logtest.lsp") (load "byte.lsp") (load "deposit-field.lsp") (load "dpb.lsp") (load "ldb.lsp") (load "mask-field.lsp") (load "float.lsp") (load "floatp.lsp") (load "rational.lsp") (load "rationalize.lsp") (load "evenp.lsp") (load "oddp.lsp") (load "epsilons.lsp") (load "real.lsp") (load "upgraded-complex-part-type.lsp") (load "arithmetic-error.lsp") gcl27-2.7.0/ansi-tests/load-objects.lsp000066400000000000000000000035261454061450500176300ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Mar 24 03:39:09 2003 ;;;; Contains: Loader for CLOS-related test files (compile-and-load "defclass-aux.lsp") (load "defclass.lsp") (load "defclass-01.lsp") (load "defclass-02.lsp") (load "defclass-03.lsp") (load "defclass-errors.lsp") (load "defclass-forward-reference.lsp") (load "ensure-generic-function.lsp") (load "allocate-instance.lsp") (load "reinitialize-instance.lsp") (load "shared-initialize.lsp") (load "change-class.lsp") (load "update-instance-for-different-class.lsp") (load "slot-boundp.lsp") (load "slot-exists-p.lsp") (load "slot-makunbound.lsp") (load "slot-missing.lsp") (load "slot-unbound.lsp") (load "slot-value.lsp") (load "method-qualifiers.lsp") (load "no-applicable-method.lsp") (load "no-next-method.lsp") (load "remove-method.lsp") (load "make-instance.lsp") (load "make-instances-obsolete.lsp") (load "make-load-form.lsp") (load "make-load-form-saving-slots.lsp") (load "with-accessors.lsp") (load "with-slots.lsp") (load "defgeneric.lsp") (load "defgeneric-method-combination-aux.lsp") (load "defgeneric-method-combination-plus.lsp") (load "defgeneric-method-combination-append.lsp") (load "defgeneric-method-combination-nconc.lsp") (load "defgeneric-method-combination-list.lsp") (load "defgeneric-method-combination-max.lsp") (load "defgeneric-method-combination-min.lsp") (load "defgeneric-method-combination-and.lsp") (load "defgeneric-method-combination-or.lsp") (load "defgeneric-method-combination-progn.lsp") ;; (load "defgeneric-method-combination-standard.lsp") (load "find-class.lsp") (load "next-method-p.lsp") (load "call-next-method.lsp") (load "compute-applicable-methods.lsp") (load "define-method-combination.lsp") (load "find-method.lsp") (load "add-method.lsp") (load "class-name.lsp") (load "class-of.lsp") (load "unbound-slot.lsp") (load "defmethod.lsp") gcl27-2.7.0/ansi-tests/load-packages.lsp000066400000000000000000000017731454061450500177570ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Oct 6 00:32:56 2002 ;;;; Contains: Loader for files containing package tests (compile-and-load "packages-00.lsp") (load "find-symbol.lsp") (load "find-all-symbols.lsp") (load "find-package.lsp") (load "list-all-packages.lsp") (load "package-name.lsp") (load "package-nicknames.lsp") (load "intern.lsp") (load "export.lsp") (load "rename-package.lsp") (load "shadow.lsp") (load "shadowing-import.lsp") (load "delete-package.lsp") (load "make-package.lsp") (load "with-package-iterator.lsp") (load "unexport.lsp") (load "unintern.lsp") (load "in-package.lsp") (load "unuse-package.lsp") (load "use-package.lsp") (load "defpackage.lsp") (load "do-symbols.lsp") (load "do-external-symbols.lsp") (load "do-all-symbols.lsp") (load "packagep.lsp") (load "package-error.lsp") (load "package-error-package.lsp") (load "keyword.lsp") (load "package-shadowing-symbols.lsp") (load "package-use-list.lsp") (load "package-used-by-list.lsp") (load "import.lsp") gcl27-2.7.0/ansi-tests/load-pathnames.lsp000066400000000000000000000016201454061450500201500ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Nov 29 04:33:05 2003 ;;;; Contains: Load tests for pathnames and logical pathnames (in-package :cl-test) (compile-and-load "pathnames-aux.lsp") (load "pathnames.lsp") (load "pathname.lsp") (load "pathnamep.lsp") (load "make-pathname.lsp") (load "pathname-host.lsp") (load "pathname-device.lsp") (load "pathname-directory.lsp") (load "pathname-name.lsp") (load "pathname-type.lsp") (load "pathname-version.lsp") (load "load-logical-pathname-translations.lsp") (load "logical-pathname.lsp") (load "logical-pathname-translations.lsp") (load "translate-logical-pathname.lsp") (load "namestring.lsp") (load "file-namestring.lsp") (load "directory-namestring.lsp") (load "host-namestring.lsp") (load "enough-namestring.lsp") (load "wild-pathname-p.lsp") (load "merge-pathnames.lsp") (load "pathname-match-p.lsp") (load "parse-namestring.lsp")gcl27-2.7.0/ansi-tests/load-printer.lsp000066400000000000000000000023431454061450500176560ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Feb 23 04:40:33 2004 ;;;; Contains: File to load tests of the lisp printer (in-package :cl-test) (compile-and-load "printer-aux.lsp") (load "copy-pprint-dispatch.lsp") (load "print-integers.lsp") (load "print-ratios.lsp") (load "print-floats.lsp") (load "print-complex.lsp") (load "print-characters.lsp") (load "print-symbols.lsp") (load "print-strings.lsp") (load "print-cons.lsp") (load "print-backquote.lsp") (load "print-bit-vector.lsp") (load "print-vector.lsp") (load "print-array.lsp") (load "print-random-state.lsp") (load "print-pathname.lsp") (load "print-structure.lsp") (load "printer-control-vars.lsp") (load "pprint-dispatch.lsp") (load "pprint-fill.lsp") (load "pprint-linear.lsp") (load "pprint-tabular.lsp") (load "pprint-indent.lsp") (load "pprint-logical-block.lsp") (load "pprint-exit-if-list-exhausted.lsp") (load "pprint-newline.lsp") (load "pprint-tab.lsp") (load "print-unreadable-object.lsp") (load "write.lsp") (load "print.lsp") (load "pprint.lsp") (load "prin1.lsp") (load "princ.lsp") (load "write-to-string.lsp") (load "prin1-to-string.lsp") (load "princ-to-string.lsp") (load "print-level.lsp") (load "print-length.lsp") (load "load-format.lsp") gcl27-2.7.0/ansi-tests/load-reader.lsp000066400000000000000000000011671454061450500174400ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Feb 23 05:20:41 2004 ;;;; Contains: Load tests of the reader (in-package :cl-test) (load "reader-test.lsp") (load "with-standard-io-syntax.lsp") (load "copy-readtable.lsp") (load "read.lsp") (load "read-preserving-whitespace.lsp") (load "read-delimited-list.lsp") (load "read-from-string.lsp") (load "readtable-case.lsp") (load "readtablep.lsp") (load "get-macro-character.lsp") (load "set-macro-character.lsp") (load "read-suppress.lsp") (load "set-syntax-from-char.lsp") (load "dispatch-macro-characters.lsp") (load "syntax.lsp") (load "syntax-tokens.lsp") gcl27-2.7.0/ansi-tests/load-sequences.lsp000066400000000000000000000017351454061450500201720ustar00rootroot00000000000000;;; Tests of sequences (load "copy-seq.lsp") (load "elt.lsp") (load "fill.lsp") (load "fill-strings.lsp") (load "make-sequence.lsp") (load "map.lsp") (load "map-into.lsp") (load "reduce.lsp") (load "count.lsp") (load "count-if.lsp") (load "count-if-not.lsp") (load "reverse.lsp") (load "nreverse.lsp") (load "sort.lsp") (load "stable-sort.lsp") (load "length.lsp") (load "find.lsp") (load "find-if.lsp") (load "find-if-not.lsp") (load "position.lsp") (load "position-if.lsp") (load "position-if-not.lsp") (load "search-list.lsp") (load "search-vector.lsp") (load "search-bitvector.lsp") (load "search-string.lsp") (load "mismatch.lsp") (load "replace.lsp") (load "subseq.lsp") (load "substitute.lsp") (load "substitute-if.lsp") (load "substitute-if-not.lsp") (load "nsubstitute.lsp") (load "nsubstitute-if.lsp") (load "nsubstitute-if-not.lsp") (load "concatenate.lsp") (load "merge.lsp") (load "remove.lsp") ;; also related funs (load "remove-duplicates.lsp") ;; also delete-duplicates gcl27-2.7.0/ansi-tests/load-streams.lsp000066400000000000000000000031721454061450500176520ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 13 19:38:10 2004 ;;;; Contains: Load files containing tests for section 21 (streams) (in-package :cl-test) (load "input-stream-p.lsp") (load "output-stream-p.lsp") (load "interactive-stream-p.lsp") (load "open-stream-p.lsp") (load "stream-element-type.lsp") (load "streamp.lsp") (load "read-byte.lsp") (load "peek-char.lsp") (load "read-char.lsp") (load "read-char-no-hang.lsp") (load "terpri.lsp") (load "fresh-line.lsp") (load "unread-char.lsp") (load "write-char.lsp") (load "read-line.lsp") (load "write-string.lsp") (load "write-line.lsp") (load "read-sequence.lsp") (load "write-sequence.lsp") (load "file-length.lsp") (load "file-position.lsp") (load "file-string-length.lsp") (load "open.lsp") (load "stream-external-format.lsp") (load "with-open-file.lsp") (load "with-open-stream.lsp") (load "listen.lsp") (load "clear-input.lsp") (load "finish-output.lsp") (load "force-output.lsp") (load "clear-output.lsp") (load "make-synonym-stream.lsp") (load "synonym-stream-symbol.lsp") (load "make-broadcast-stream.lsp") (load "broadcast-stream-streams.lsp") (load "make-two-way-stream.lsp") (load "two-way-stream-input-stream.lsp") (load "two-way-stream-output-stream.lsp") (load "echo-stream-input-stream.lsp") (load "echo-stream-output-stream.lsp") (load "make-echo-stream.lsp") (load "concatenated-stream-streams.lsp") (load "make-concatenated-stream.lsp") (load "get-output-stream-string.lsp") (load "make-string-input-stream.lsp") (load "make-string-output-stream.lsp") (load "with-input-from-string.lsp") (load "with-output-to-string.lsp") (load "stream-error-stream.lsp") gcl27-2.7.0/ansi-tests/load-strings.lsp000066400000000000000000000011251454061450500176610ustar00rootroot00000000000000;;; Tests of strings (load "char-schar.lsp") (load "string.lsp") (load "base-string.lsp") (load "simple-string.lsp") (load "simple-base-string.lsp") (load "simple-string-p.lsp") (load "stringp.lsp") (load "string-upcase.lsp") (load "string-downcase.lsp") (load "string-capitalize.lsp") (load "nstring-upcase.lsp") (load "nstring-downcase.lsp") (load "nstring-capitalize.lsp") (load "string-trim.lsp") (load "string-left-trim.lsp") (load "string-right-trim.lsp") ;;; Tests of string comparison functions (compile-and-load "string-aux.lsp") (load "string-comparisons.lsp") (load "make-string.lsp")gcl27-2.7.0/ansi-tests/load-structures.lsp000066400000000000000000000002361454061450500204150ustar00rootroot00000000000000;;; Tests of structures (load "structure-00.lsp") (load "structures-01.lsp") (load "structures-02.lsp") (load "structures-03.lsp") (load "structures-04.lsp")gcl27-2.7.0/ansi-tests/load-symbols.lsp000066400000000000000000000007171454061450500176660ustar00rootroot00000000000000;;; Tests of symbols (compile-and-load "cl-symbols-aux.lsp") ;; (load "cl-symbol-names.lsp") ;; moved to gclload1.lsp (load "cl-symbols.lsp") (load "symbolp.lsp") (load "keywordp.lsp") (load "make-symbol.lsp") (load "copy-symbol.lsp") (load "gensym.lsp") (load "gentemp.lsp") (load "symbol-function.lsp") (load "symbol-name.lsp") (load "boundp.lsp") (load "special-operator-p.lsp") (load "makunbound.lsp") (load "set.lsp") (load "remprop.lsp") (load "get.lsp") gcl27-2.7.0/ansi-tests/load-system-construction.lsp000066400000000000000000000004531454061450500222470ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Dec 12 19:44:29 2004 ;;;; Contains: Load tests for system construction (section 24) (in-package :cl-test) (load "compile-file.lsp") (load "load.lsp") (load "with-compilation-unit.lsp") (load "features.lsp") (load "modules.lsp") gcl27-2.7.0/ansi-tests/load-test-file-2.lsp000066400000000000000000000003031454061450500202200ustar00rootroot00000000000000(in-package :cl-test) (declaim (special *load-test-var.1* *load-test-var.2*)) (eval-when (:load-toplevel) (setq *load-test-var.1* *load-pathname*) (setq *load-test-var.2* *load-truename*)) gcl27-2.7.0/ansi-tests/load-test-file.lsp000066400000000000000000000002041454061450500200610ustar00rootroot00000000000000(in-package :cl-test) (defun load-file-test-fun.1 () '#.*load-pathname*) (defun load-file-test-fun.2 () '#.*load-truename*) gcl27-2.7.0/ansi-tests/load-types-and-class.lsp000066400000000000000000000010721454061450500212000ustar00rootroot00000000000000;;; Tests of types and classes (load "types-and-class.lsp") (load "types-and-class-2.lsp") (load "coerce.lsp") (load "subtypep.lsp") (load "subtypep-integer.lsp") (load "subtypep-float.lsp") (load "subtypep-rational.lsp") (load "subtypep-real.lsp") #-lispworks (load "subtypep-cons.lsp") (load "subtypep-member.lsp") (load "subtypep-eql.lsp") (load "subtypep-array.lsp") (load "subtypep-function.lsp") (load "subtypep-complex.lsp") (load "deftype.lsp") (load "standard-generic-function.lsp") (load "type-of.lsp") (load "typep.lsp") (load "class-precedence-lists.lsp") gcl27-2.7.0/ansi-tests/load.lsp000066400000000000000000000143411454061450500161760ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Apr 12 21:51:49 2005 ;;;; Contains: Tests of LOAD (in-package :cl-test) (defun load-file-test (file funname &rest args &key if-does-not-exist (print nil print-p) (verbose nil verbose-p) (*load-print* nil) (*load-verbose* nil) external-format) (declare (ignorable external-format if-does-not-exist print print-p verbose verbose-p)) (fmakunbound funname) (let* ((str (make-array '(0) :element-type 'character :adjustable t :fill-pointer 0)) (vals (multiple-value-list (with-output-to-string (*standard-output* str) (apply #'load file :allow-other-keys t args)))) (print? (if print-p print *load-print*)) (verbose? (if verbose-p verbose *load-verbose*))) (values (let ((v1 (car vals)) (v2 (or (and verbose-p (not verbose)) (and (not verbose-p) (not *load-verbose*)) (position #\; str))) (v3 (or (and print-p (not print)) (and (not print-p) (not *load-print*)) (> (length str) 0))) (v4 (if (or print? verbose?) (> (length str) 0) t))) (if (and (= (length vals) 1) v1 v2 v3 v4) t (list vals v2 v3 v4 str))) (funcall funname)))) (deftest load.1 (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1) t nil) (deftest load.2 (load-file-test #p"compile-file-test-file.lsp" 'compile-file-test-fun.1) t nil) (deftest load.3 (with-input-from-string (s "(in-package :cl-test) (defun load-file-test-fun.2 () 'good)") (load-file-test s 'load-file-test-fun.2)) t good) (deftest load.4 (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :external-format :default) t nil) (deftest load.5 (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :verbose t) t nil) (deftest load.6 (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :*load-verbose* t) t nil) (deftest load.7 (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :*load-verbose* t :verbose nil) t nil) (deftest load.8 (with-input-from-string (s "(in-package :cl-test) (defun load-file-test-fun.2 () 'good)") (load-file-test s 'load-file-test-fun.2 :verbose t)) t good) (deftest load.9 (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :print t) t nil) (deftest load.10 (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :*load-print* t) t nil) (deftest load.11 (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :*load-print* t :print nil) t nil) (deftest load.12 (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :*load-print* nil :print t) t nil) (deftest load.13 (with-input-from-string (s "(in-package :cl-test) (defun load-file-test-fun.2 () 'good)") (load-file-test s 'load-file-test-fun.2 :print t)) t good) (deftest load.14 (load "nonexistent-file.lsp" :if-does-not-exist nil) nil) (defpackage LOAD-TEST-PACKAGE (:use "COMMON-LISP")) (deftest load.15 (let ((*package* (find-package "LOAD-TEST-PACKAGE"))) (with-input-from-string (s "(defun f () 'good)") (load-file-test s 'load-test-package::f))) t load-test-package::good) (deftest load.15a (let ((*package* (find-package "CL-TEST"))) (values (with-input-from-string (s "(eval-when (:load-toplevel :execute) (setq *package* (find-package \"LOAD-TEST-PACKAGE\"))) (defun f () 'good)") (multiple-value-list (load-file-test s 'load-test-package::f))) (read-from-string "GOOD"))) (t load-test-package::good) good) (deftest load.16 (let ((*readtable* (copy-readtable nil))) (set-macro-character #\! (get-macro-character #\')) (with-input-from-string (s "(in-package :cl-test) (defun load-file-test-fun.3 () !good)") (load-file-test s 'load-file-test-fun.3))) t good) (deftest load.16a (let ((*readtable* *readtable*) (*package* (find-package "CL-TEST"))) (values (with-input-from-string (s "(in-package :cl-test) (eval-when (:load-toplevel :execute) (setq *readtable* (copy-readtable nil)) (set-macro-character #\\! (get-macro-character #\\'))) (defun load-file-test-fun.3 () !good)") (multiple-value-list (load-file-test s 'load-file-test-fun.3))) (read-from-string "!FOO"))) (t good) !FOO) (deftest load.17 (let ((file #p"load-test-file.lsp")) (fmakunbound 'load-file-test-fun.1) (fmakunbound 'load-file-test-fun.2) (values (notnot (load file)) (let ((p1 (pathname (merge-pathnames file))) (p2 (funcall 'load-file-test-fun.1))) (equalpt-or-report p1 p2)) (let ((p1 (truename file)) (p2 (funcall 'load-file-test-fun.2))) (equalpt-or-report p1 p2)))) t t t) ;;; Test that the load pathname/truename variables are bound ;;; properly when loading compiled files (deftest load.18 (let* ((file "load-test-file-2.lsp") (target (enough-namestring (compile-file-pathname file)))) (declare (special *load-test-var.1* *load-test-var.2*)) (compile-file file) (makunbound '*load-test-var.1*) (makunbound '*load-test-var.2*) (load target) (values (let ((p1 (pathname (merge-pathnames target))) (p2 *load-test-var.1*)) (equalpt-or-report p1 p2)) (let ((p1 (truename target)) (p2 *load-test-var.2*)) (equalpt-or-report p1 p2)))) t t) (deftest load.19 (let ((file (logical-pathname "CLTEST:LDTEST.LSP")) (fn 'load-test-fun-3) (*package* (find-package "CL-TEST"))) (with-open-file (s file :direction :output :if-exists :supersede :if-does-not-exist :create) (format s "(in-package :cl-test) (defun ~a () :foo)" fn)) (fmakunbound fn) (values (notnot (load file)) (funcall fn))) t :foo) ;;; Defaults of the load variables (deftest load-pathname.1 *load-pathname* nil) (deftest load-truename.1 *load-truename* nil) (deftest load-print.1 *load-print* nil) ;;; Error tests (deftest load.error.1 (signals-error (load "nonexistent-file.lsp") file-error) t) (deftest load.error.2 (signals-error (load) program-error) t) (deftest load.error.3 (signals-error (load "compile-file-test-file.lsp" :bad-key-arg t) program-error) t) gcl27-2.7.0/ansi-tests/locally.lsp000066400000000000000000000014131454061450500167120ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 8 06:02:47 2005 ;;;; Contains: Tests of LOCALLY (in-package :cl-test) (deftest locally.1 (locally) nil) (deftest locally.2 (locally (values))) (deftest locally.3 (locally (values 1 2 3 4)) 1 2 3 4) (deftest locally.4 (locally (declare) t) t) (deftest locally.5 (locally (declare) (declare) (declare) t) t) (deftest locally.6 (let ((x 'a)) (declare (special x)) (let ((x 'b)) (values x (locally (declare (special x)) x) x))) b a b) (deftest locally.7 (locally (declare)) nil) ;;; Macros are expanded in the appropriate environment (deftest locally.8 (macrolet ((%m (z) z)) (locally (expand-in-current-env (%m :good)))) :good) gcl27-2.7.0/ansi-tests/log.lsp000066400000000000000000000055531454061450500160450ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Feb 11 19:53:33 2004 ;;;; Contains: Tests of LOG (in-package :cl-test) (deftest log.1 (let ((result (log 1))) (or (eqlt result 0) (eqlt result 0.0))) t) (deftest log.2 (mapcar #'log '(1.0s0 1.0f0 1.0d0 1.0l0)) (0.0s0 0.0f0 0.0d0 0.0l0)) (deftest log.3 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x = (+ (random (coerce 1 type)) (/ 1 1000)) for rlist = (multiple-value-list (log x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y type)) collect (list x rlist))) nil) (deftest log.4 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x = (1+ (random (coerce 1000000 type))) for rlist = (multiple-value-list (log x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y type)) collect (list x rlist))) nil) (deftest log.5 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 type) nconc (loop for x = (- (random (coerce 1 type))) for rlist = (and (/= x zero) (multiple-value-list (log x))) for y = (car rlist) repeat 1000 unless (or (= x zero) (and (null (cdr rlist)) (typep y `(complex ,type)))) collect (list x rlist))) nil) (deftest log.6 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 type) nconc (loop for x = (- (random (coerce 1000000 type))) for rlist = (and (/= x zero) (multiple-value-list (log x))) for y = (car rlist) repeat 1000 unless (or (= x zero) (and (null (cdr rlist)) (typep y `(complex ,type)))) collect (list x rlist))) nil) (deftest log.7 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 type) nconc (loop for x1 = (- (random (coerce 2000 type)) 1000) for x2 = (1+ (random (coerce 1000 type))) for rlist = (and (/= x1 zero) (multiple-value-list (log (complex x1 x2)))) for y = (car rlist) repeat 1000 unless (or (= x1 zero) (and (null (cdr rlist)) (typep y `(complex ,type)))) collect (list x1 x2 rlist))) nil) (deftest log.8 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 type) nconc (loop for x1 = (- (random (coerce 2000 type)) 1000) for x2 = (- -1 (random (coerce 1000 type))) for rlist = (and (/= x1 zero) (multiple-value-list (log (complex x1 x2)))) for y = (car rlist) repeat 1000 unless (or (= x1 zero) (and (null (cdr rlist)) (typep y `(complex ,type)))) collect (list x1 x2 rlist))) nil) ;;; FIXME ;;; Add tests for two-arg calls ;;; FIXME ;;; More accuracy tests here ;;; Error tests (deftest log.error.1 (signals-error (log) program-error) t) (deftest log.error.2 (signals-error (log 1.0 2.0 3.0) program-error) t) gcl27-2.7.0/ansi-tests/logand.lsp000066400000000000000000000041051454061450500165200ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Sep 8 21:23:22 2003 ;;;; Contains: Tests of LOGAND (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest logand.error.1 (check-type-error #'logand #'integerp) nil) (deftest logand.error.2 (check-type-error #'(lambda (x) (logand 0 x)) #'integerp) nil) (deftest logand.error.3 (check-type-error #'(lambda (x) (logand x 1)) #'integerp) nil) ;;; Non-error tests (deftest logand.1 (logand) -1) (deftest logand.2 (logand 1231) 1231) (deftest logand.3 (logand -198) -198) (deftest logand.4 (loop for x in *integers* always (eql x (logand x))) t) (deftest logand.5 (loop for x in *integers* always (eql 0 (logand x (lognot x)))) t) (deftest logand.6 (loop for x = (random-fixnum) for xc = (lognot x) repeat 1000 unless (eql 0 (logand x xc)) collect x) nil) (deftest logand.7 (loop for x = (random-from-interval (ash 1 (random 200))) for y = (random-from-interval (ash 1 (random 200))) for z = (logand x y) repeat 1000 unless (and (if (and (< x 0) (< y 0)) (< z 0) (>= z 0)) (loop for i from 1 to 210 always (if (and (logbitp i x) (logbitp i y)) (logbitp i z) (not (logbitp i z))))) collect (list x y z)) nil) (deftest logand.8 (loop for i from 1 to (min 256 (1- call-arguments-limit)) for args = (nconc (make-list (1- i) :initial-element -1) (list 183)) always (eql (apply #'logand args) 183)) t) (deftest logand.9 (loop for i from -1 to 0 always (loop for j from -1 to 0 always (locally (declare (type (integer -1 0) i j)) (eql (logand i j) (if (or (zerop i) (zerop j)) 0 -1))))) t) (deftest logand.order.1 (let ((i 0) a b) (values (logand (progn (setf a (incf i)) #b11011) (progn (setf b (incf i)) #b10110)) i a b)) #b10010 2 1 2) (deftest logand.order.2 (let ((i 0) a b c) (values (logand (progn (setf a (incf i)) #b11011) (progn (setf b (incf i)) #b10110) (progn (setf c (incf i)) #b110101)) i a b c)) #b10000 3 1 2 3) gcl27-2.7.0/ansi-tests/logandc1.lsp000066400000000000000000000032541454061450500167500ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Sep 8 21:47:22 2003 ;;;; Contains: Tests of LOGANDC1 (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest logandc1.error.1 (check-type-error #'(lambda (x) (logandc1 x 0)) #'integerp) nil) (deftest logandc1.error.2 (check-type-error #'(lambda (x) (logandc1 0 x)) #'integerp) nil) (deftest logandc1.error.3 (signals-error (logandc1) program-error) t) (deftest logandc1.error.4 (signals-error (logandc1 0) program-error) t) (deftest logandc1.error.5 (signals-error (logandc1 1 2 3) program-error) t) ;;; Non-error tests (deftest logandc1.1 (logandc1 0 0) 0) (deftest logandc1.2 (logandc1 0 -1) -1) (deftest logandc1.3 (logandc1 0 123) 123) (deftest logandc1.4 (loop for x in *integers* always (and (eql x (logandc1 0 x)) (eql 0 (logandc1 x x)) (eql x (logandc1 (lognot x) x)) (eql (lognot x) (logandc1 x (lognot x))))) t) (deftest logandc1.5 (loop for x = (random-fixnum) for xc = (lognot x) repeat 1000 unless (eql x (logandc1 xc x)) collect x) nil) (deftest logandc1.6 (loop for x = (random-from-interval (ash 1 (random 200))) for y = (random-from-interval (ash 1 (random 200))) for z = (logandc1 x y) repeat 1000 unless (and (if (and (>= x 0) (< y 0)) (< z 0) (>= z 0)) (loop for i from 1 to 210 always (if (and (not (logbitp i x)) (logbitp i y)) (logbitp i z) (not (logbitp i z))))) collect (list x y z)) nil) (deftest logandc1.order.1 (let ((i 0) a b) (values (logandc1 (progn (setf a (incf i)) 0) (progn (setf b (incf i)) -1)) i a b)) -1 2 1 2) gcl27-2.7.0/ansi-tests/logandc2.lsp000066400000000000000000000033321454061450500167460ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Sep 9 05:52:31 2003 ;;;; Contains: Tests of LOGANDC2 (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest logandc2.error.1 (check-type-error #'(lambda (x) (logandc2 x 0)) #'integerp) nil) (deftest logandc2.error.2 (check-type-error #'(lambda (x) (logandc2 0 x)) #'integerp) nil) (deftest logandc2.error.3 (signals-error (logandc2) program-error) t) (deftest logandc2.error.4 (signals-error (logandc2 0) program-error) t) (deftest logandc2.error.5 (signals-error (logandc2 1 2 3) program-error) t) ;;; Non-error tests (deftest logandc2.1 (logandc2 0 0) 0) (deftest logandc2.2 (logandc2 -1 0) -1) (deftest logandc2.3 (logandc2 (1+ most-positive-fixnum) 0) #.(1+ most-positive-fixnum)) (deftest logandc2.4 (loop for x in *integers* always (and (eql x (logandc2 x 0)) (eql 0 (logandc2 x x)) (eql x (logandc2 x (lognot x))) (eql (lognot x) (logandc2 (lognot x) x)))) t) (deftest logandc2.5 (loop for x = (random-fixnum) for xc = (lognot x) repeat 1000 unless (eql x (logandc2 x xc)) collect x) nil) (deftest logandc2.6 (loop for x = (random-from-interval (ash 1 (random 200))) for y = (random-from-interval (ash 1 (random 200))) for z = (logandc2 x y) repeat 1000 unless (and (if (and (< x 0) (>= y 0)) (< z 0) (>= z 0)) (loop for i from 1 to 210 always (if (and (not (logbitp i y)) (logbitp i x)) (logbitp i z) (not (logbitp i z))))) collect (list x y z)) nil) (deftest logandc2.order.1 (let ((i 0) a b) (values (logandc2 (progn (setf a (incf i)) -1) (progn (setf b (incf i)) 0)) i a b)) -1 2 1 2) gcl27-2.7.0/ansi-tests/logbitp.lsp000066400000000000000000000033111454061450500167120ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Sep 9 07:02:00 2003 ;;;; Contains: Tests of LOGBITP (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest logbitp.error.1 (signals-error (logbitp) program-error) t) (deftest logbitp.error.2 (signals-error (logbitp 0) program-error) t) (deftest logbitp.error.3 (signals-error (logbitp 0 0 0) program-error) t) (deftest logbitp.error.4 (check-type-error #'(lambda (x) (logbitp x 0)) (typef 'unsigned-byte)) nil) (deftest logbitp.error.5 (check-type-error #'(lambda (x) (logbitp 0 x)) #'integerp) nil) ;;; Non-error tests (deftest logbitp.1 (loop for x in *integers* unless (if (logbitp 0 x) (oddp x) (evenp x)) collect x) nil) (deftest logbitp.2 (loop for len from 0 to 300 for i = (ash 1 len) always (and (logbitp len i) (loop for j from 0 to 300 always (or (eql j len) (not (logbitp j i)))))) t) (deftest logbitp.3 (logbitp most-positive-fixnum 0) nil) (deftest logbitp.4 (notnot-mv (logbitp most-positive-fixnum -1)) t) (deftest logbitp.5 (logbitp (1+ most-positive-fixnum) 0) nil) (deftest logbitp.6 (notnot-mv (logbitp (1+ most-positive-fixnum) -1)) t) (deftest logbitp.7 (loop for len = (random 100) for i = (random-from-interval (ash 1 len)) for k = (random (1+ len)) repeat 1000 unless (if (ldb-test (byte 1 k) i) (logbitp k i) (not (logbitp k i))) collect (list i k)) nil) (deftest logbitp.8 (loop for k from 1 to 1000 always (logbitp k -1)) t) (deftest logbitp.order.1 (let ((i 0) a b) (values (logbitp (progn (setf a (incf i)) 2) (progn (setf b (incf i)) #b111010)) i a b)) nil 2 1 2) gcl27-2.7.0/ansi-tests/logcount.lsp000066400000000000000000000022111454061450500171020ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Sep 11 23:12:56 2003 ;;;; Contains: Tests of LOGCOUNT (in-package :cl-test) ;;; Error tests (deftest logcount.error.1 (signals-error (logcount) program-error) t) (deftest logcount.error.2 (signals-error (logcount 0 nil) program-error) t) (deftest logcount.error.3 (check-type-error #'logcount #'integerp) nil) ;;; Non-error tests (deftest logcount.1 (logcount 0) 0) (deftest logcount.2 (logcount 1) 1) (deftest logcount.3 (logcount 2) 1) (deftest logcount.4 (logcount 3) 2) (deftest logcount.5 (logcount -1) 0) (deftest logcount.6 (loop for x = (random-fixnum) repeat 100 always (eql (logcount x) (logcount (lognot x)))) t) (deftest logcount.7 (let ((bound (ash 1 300))) (loop for x = (random-from-interval bound) repeat 100 always (eql (logcount x) (logcount (lognot x))))) t) (deftest logcount.8 (loop for y = (random (1+ most-positive-fixnum)) repeat 100 unless (let ((cnt 0) (x y)) (loop while (> x 0) do (when (oddp x) (incf cnt)) (setf x (ash x -1))) (eql cnt (logcount y))) collect y) nil) gcl27-2.7.0/ansi-tests/logeqv.lsp000066400000000000000000000036231454061450500165550ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Sep 9 05:55:23 2003 ;;;; Contains: Tests of LOGEQV (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest logeqv.error.1 (check-type-error #'logeqv #'integerp) nil) (deftest logeqv.error.2 (check-type-error #'(lambda (x) (logeqv 0 x)) #'integerp) nil) ;;; Non-error tests (deftest logeqv.1 (logeqv) -1) (deftest logeqv.2 (logeqv 1231) 1231) (deftest logeqv.3 (logeqv -198) -198) (deftest logeqv.4 (loop for x in *integers* always (eql x (logeqv x))) t) (deftest logeqv.5 (loop for x in *integers* always (eql 0 (logeqv x (lognot x)))) t) (deftest logeqv.6 (loop for x = (random-fixnum) for xc = (lognot x) repeat 1000 unless (eql 0 (logeqv x xc)) collect x) nil) (deftest logeqv.7 (loop for x = (random-from-interval (ash 1 (random 200))) for y = (random-from-interval (ash 1 (random 200))) for z = (logeqv x y) repeat 1000 unless (and (if (or (and (< x 0) (< y 0)) (and (>= x 0) (>= y 0))) (< z 0) (>= z 0)) (loop for i from 1 to 210 always (if (or (and (logbitp i x) (logbitp i y)) (and (not (logbitp i x)) (not (logbitp i y)))) (logbitp i z) (not (logbitp i z))))) collect (list x y z)) nil) (deftest logeqv.8 (loop for i from 1 to (min 256 (1- call-arguments-limit)) for args = (nconc (make-list (1- i) :initial-element -1) (list 7131)) always (eql (apply #'logeqv args) 7131)) t) (deftest logeqv.order.1 (let ((i 0) a b) (values (logeqv (progn (setf a (incf i)) #b11011) (progn (setf b (incf i)) (lognot #b10110))) i a b)) #b1101 2 1 2) (deftest logeqv.order.2 (let ((i 0) a b c) (values (logeqv (progn (setf a (incf i)) #b11011) (progn (setf b (incf i)) #b10110) (progn (setf c (incf i)) #b110101)) i a b c)) #b111000 3 1 2 3) gcl27-2.7.0/ansi-tests/logical-pathname-translations.lsp000066400000000000000000000002511454061450500231760ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Dec 31 09:46:08 2003 ;;;; Contains: Tests of LOGICAL-PATHNAME-TRANSLATIONS (in-package :cl-test) gcl27-2.7.0/ansi-tests/logical-pathname.lsp000066400000000000000000000045331454061450500204660ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Dec 30 19:05:01 2003 ;;;; Contains: Tests of LOGICAL-PATHNAME (in-package :cl-test) (deftest logical-pathname.1 (loop for x in *logical-pathnames* always (eql x (logical-pathname x))) t) (deftest logical-pathname.2 (notnot-mv (typep (logical-pathname "CLTEST:FOO") 'logical-pathname)) t) (deftest logical-pathname.3 (let ((name "CLTEST:TEMP.DAT.NEWEST")) (with-open-file (s (logical-pathname name) :direction :output :if-exists :supersede :if-does-not-exist :create) (or (equalt (logical-pathname s) (logical-pathname name)) (list (logical-pathname s) (logical-pathname name))))) t) ;;; Error tests (deftest logical-pathname.error.1 (check-type-error #'logical-pathname (typef '(or string stream logical-pathname))) nil) (deftest logical-pathname.error.2 ;; Doesn't specify a host (signals-error (logical-pathname "FOO.TXT") type-error) t) (deftest logical-pathname.error.3 (signals-error (with-open-file (s #p"logical-pathname.lsp" :direction :input) (logical-pathname s)) type-error) t) (deftest logical-pathname.error.4 (signals-error (with-open-stream (is (make-concatenated-stream)) (with-open-stream (os (make-broadcast-stream)) (with-open-stream (s (make-two-way-stream is os)) (logical-pathname s)))) type-error) t) (deftest logical-pathname.error.5 (signals-error (with-open-stream (is (make-concatenated-stream)) (with-open-stream (os (make-broadcast-stream)) (with-open-stream (s (make-echo-stream is os)) (logical-pathname s)))) type-error) t) (deftest logical-pathname.error.6 (signals-error (with-open-stream (s (make-broadcast-stream)) (logical-pathname s)) type-error) t) (deftest logical-pathname.error.7 (signals-error (with-open-stream (s (make-concatenated-stream)) (logical-pathname s)) type-error) t) (deftest logical-pathname.error.8 (signals-error (with-open-stream (s (make-string-input-stream "foo")) (logical-pathname s)) type-error) t) (deftest logical-pathname.error.9 (signals-error (with-output-to-string (s) (logical-pathname s)) type-error) t) (deftest logical-pathname.error.10 (handler-case (progn (eval '(locally (declare (optimize safety)) (logical-pathname "CLROOT:%"))) t) (type-error () t)) t) gcl27-2.7.0/ansi-tests/logior.lsp000066400000000000000000000034361454061450500165550ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Sep 9 06:08:21 2003 ;;;; Contains: Tests of LOGIOR (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest logior.error.1 (check-type-error #'logior #'integerp) nil) (deftest logior.error.2 (check-type-error #'(lambda (x) (logior 0 x)) #'integerp) nil) ;;; Non-error tests (deftest logior.1 (logior) 0) (deftest logior.2 (logior 1231) 1231) (deftest logior.3 (logior -198) -198) (deftest logior.4 (loop for x in *integers* always (eql x (logior x))) t) (deftest logior.5 (loop for x in *integers* always (eql -1 (logior x (lognot x)))) t) (deftest logior.6 (loop for x = (random-fixnum) for xc = (lognot x) repeat 1000 unless (eql -1 (logior x xc)) collect x) nil) (deftest logior.7 (loop for x = (random-from-interval (ash 1 (random 200))) for y = (random-from-interval (ash 1 (random 200))) for z = (logior x y) repeat 1000 unless (and (if (or (< x 0) (< y 0)) (< z 0) (>= z 0)) (loop for i from 1 to 210 always (if (or (logbitp i x) (logbitp i y)) (logbitp i z) (not (logbitp i z))))) collect (list x y z)) nil) (deftest logior.8 (loop for i from 1 to (min 256 (1- call-arguments-limit)) for args = (nconc (make-list (1- i) :initial-element 0) (list -21231)) always (eql (apply #'logior args) -21231)) t) (deftest logior.order.1 (let ((i 0) a b) (values (logior (progn (setf a (incf i)) #b11010) (progn (setf b (incf i)) #b10110)) i a b)) #b11110 2 1 2) (deftest logior.order.2 (let ((i 0) a b c) (values (logior (progn (setf a (incf i)) #b10011) (progn (setf b (incf i)) #b10110) (progn (setf c (incf i)) #b110101)) i a b c)) #b110111 3 1 2 3) gcl27-2.7.0/ansi-tests/lognand.lsp000066400000000000000000000032341454061450500167000ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Sep 9 06:11:12 2003 ;;;; Contains: Tests of LOGNAND (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest lognand.error.1 (check-type-error #'(lambda (x) (lognand x 0)) #'integerp) nil) (deftest lognand.error.2 (check-type-error #'(lambda (x) (lognand 0 x)) #'integerp) nil) (deftest lognand.error.3 (signals-error (lognand) program-error) t) (deftest lognand.error.4 (signals-error (lognand 0) program-error) t) (deftest lognand.error.5 (signals-error (lognand 1 2 3) program-error) t) ;;; Non-error tests (deftest lognand.1 (lognand 0 0) -1) (deftest lognand.2 (lognand 0 -1) -1) (deftest lognand.3 (lognand -1 123) -124) (deftest lognand.4 (loop for x in *integers* always (and (eql -1 (lognand 0 x)) (eql (lognot x) (lognand x x)) (eql -1 (lognand (lognot x) x)) (eql -1 (lognand x (lognot x))))) t) (deftest lognand.5 (loop for x = (random-fixnum) for xc = (lognot x) repeat 1000 unless (eql -1 (lognand xc x)) collect x) nil) (deftest lognand.6 (loop for x = (random-from-interval (ash 1 (random 200))) for y = (random-from-interval (ash 1 (random 200))) for z = (lognand x y) repeat 1000 unless (and (if (or (>= x 0) (>= y 0)) (< z 0) (>= z 0)) (loop for i from 1 to 210 always (if (not (and (logbitp i x) (logbitp i y))) (logbitp i z) (not (logbitp i z))))) collect (list x y z)) nil) (deftest lognand.order.1 (let ((i 0) a b) (values (lognand (progn (setf a (incf i)) -2) (progn (setf b (incf i)) -3)) i a b)) 3 2 1 2) gcl27-2.7.0/ansi-tests/lognor.lsp000066400000000000000000000032001454061450500165470ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Sep 9 06:14:35 2003 ;;;; Contains: Tests of LOGNOR (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest lognor.error.1 (check-type-error #'(lambda (x) (lognor x 0)) #'integerp) nil) (deftest lognor.error.2 (check-type-error #'(lambda (x) (lognor 0 x)) #'integerp) nil) (deftest lognor.error.3 (signals-error (lognor) program-error) t) (deftest lognor.error.4 (signals-error (lognor 0) program-error) t) (deftest lognor.error.5 (signals-error (lognor 1 2 3) program-error) t) ;;; Non-error tests (deftest lognor.1 (lognor 0 0) -1) (deftest lognor.2 (lognor 0 -1) 0) (deftest lognor.3 (lognor -1 123) 0) (deftest lognor.4 (loop for x in *integers* always (and (eql (lognot x) (lognor 0 x)) (eql (lognot x) (lognor x x)) (eql 0 (lognor (lognot x) x)) (eql 0 (lognor x (lognot x))))) t) (deftest lognor.5 (loop for x = (random-fixnum) for xc = (lognot x) repeat 1000 unless (eql 0 (lognor xc x)) collect x) nil) (deftest lognor.6 (loop for x = (random-from-interval (ash 1 (random 200))) for y = (random-from-interval (ash 1 (random 200))) for z = (lognor x y) repeat 1000 unless (and (if (and (>= x 0) (>= y 0)) (< z 0) (>= z 0)) (loop for i from 1 to 210 always (if (not (or (logbitp i x) (logbitp i y))) (logbitp i z) (not (logbitp i z))))) collect (list x y z)) nil) (deftest lognor.order.1 (let ((i 0) a b) (values (lognor (progn (setf a (incf i)) -2) (progn (setf b (incf i)) -3)) i a b)) 0 2 1 2) gcl27-2.7.0/ansi-tests/lognot.lsp000066400000000000000000000015361454061450500165630ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Sep 9 06:16:20 2003 ;;;; Contains: Tests of LOGNOT (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest lognot.error.1 (check-type-error #'lognot #'integerp) nil) (deftest lognot.error.2 (signals-error (lognot) program-error) t) (deftest lognot.error.3 (signals-error (lognot 0 0) program-error) t) ;;; Non-error tests (deftest lognot.1 (lognot 0) -1) (deftest lognot.2 (lognot -1) 0) (deftest lognot.3 (lognot 123) -124) (deftest lognot.4 (loop for x = (random-from-interval (ash 1 (random 200))) for z = (lognot x) repeat 1000 unless (and (if (>= x 0) (< z 0) (>= z 0)) (loop for i from 1 to 210 always (if (not (logbitp i x)) (logbitp i z) (not (logbitp i z))))) collect (list x z)) nil) gcl27-2.7.0/ansi-tests/logorc1.lsp000066400000000000000000000033311454061450500166220ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Sep 9 06:23:43 2003 ;;;; Contains: Tests of LOGORC1 (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest logorc1.error.1 (check-type-error #'(lambda (x) (logorc1 x 0)) #'integerp) nil) (deftest logorc1.error.2 (check-type-error #'(lambda (x) (logorc1 0 x)) #'integerp) nil) (deftest logorc1.error.3 (signals-error (logorc1) program-error) t) (deftest logorc1.error.4 (signals-error (logorc1 0) program-error) t) (deftest logorc1.error.5 (signals-error (logorc1 1 2 3) program-error) t) ;;; Non-error tests (deftest logorc1.1 (logorc1 0 0) -1) (deftest logorc1.2 (logorc1 0 -1) -1) (deftest logorc1.2a (logorc1 -1 0) 0) (deftest logorc1.3 (logorc1 123 0) -124) (deftest logorc1.4 (loop for x in *integers* always (and (eql -1 (logorc1 0 x)) (eql x (logorc1 -1 x)) (eql -1 (logorc1 x x)) (eql x (logorc1 (lognot x) x)) (eql (lognot x) (logorc1 x (lognot x))))) t) (deftest logorc1.5 (loop for x = (random-fixnum) for xc = (lognot x) repeat 1000 unless (eql x (logorc1 xc x)) collect x) nil) (deftest logorc1.6 (loop for x = (random-from-interval (ash 1 (random 200))) for y = (random-from-interval (ash 1 (random 200))) for z = (logorc1 x y) repeat 1000 unless (and (if (or (>= x 0) (< y 0)) (< z 0) (>= z 0)) (loop for i from 1 to 210 always (if (or (not (logbitp i x)) (logbitp i y)) (logbitp i z) (not (logbitp i z))))) collect (list x y z)) nil) (deftest logorc1.order.1 (let ((i 0) a b) (values (logorc1 (progn (setf a (incf i)) -3) (progn (setf b (incf i)) 17)) i a b)) 19 2 1 2) gcl27-2.7.0/ansi-tests/logorc2.lsp000066400000000000000000000033321454061450500166240ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Sep 9 06:27:45 2003 ;;;; Contains: Tests of LOGORC2 (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest logorc2.error.1 (check-type-error #'(lambda (x) (logorc2 x 0)) #'integerp) nil) (deftest logorc2.error.2 (check-type-error #'(lambda (x) (logorc2 0 x)) #'integerp) nil) (deftest logorc2.error.3 (signals-error (logorc2) program-error) t) (deftest logorc2.error.4 (signals-error (logorc2 0) program-error) t) (deftest logorc2.error.5 (signals-error (logorc2 1 2 3) program-error) t) ;;; Non-error tests (deftest logorc2.1 (logorc2 0 0) -1) (deftest logorc2.2 (logorc2 -1 0) -1) (deftest logorc2.2a (logorc2 0 -1) 0) (deftest logorc2.3 (logorc2 0 123) -124) (deftest logorc2.4 (loop for x in *integers* always (and (eql -1 (logorc2 x 0)) (eql x (logorc2 x -1)) (eql -1 (logorc2 x x)) (eql x (logorc2 x (lognot x))) (eql (lognot x) (logorc2 (lognot x) x)))) t) (deftest logorc2.5 (loop for x = (random-fixnum) for xc = (lognot x) repeat 1000 unless (eql x (logorc2 x xc)) collect x) nil) (deftest logorc2.6 (loop for x = (random-from-interval (ash 1 (random 200))) for y = (random-from-interval (ash 1 (random 200))) for z = (logorc2 x y) repeat 1000 unless (and (if (or (< x 0) (>= y 0)) (< z 0) (>= z 0)) (loop for i from 1 to 210 always (if (or (not (logbitp i y)) (logbitp i x)) (logbitp i z) (not (logbitp i z))))) collect (list x y z)) nil) (deftest logorc2.order.1 (let ((i 0) a b) (values (logorc2 (progn (setf a (incf i)) 27) (progn (setf b (incf i)) -1)) i a b)) 27 2 1 2) gcl27-2.7.0/ansi-tests/logtest.lsp000066400000000000000000000017111454061450500167350ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Sep 11 23:22:46 2003 ;;;; Contains: Tests for LOGTEST (in-package :cl-test) ;;; Error tests (deftest logtest.error.1 (signals-error (logtest) program-error) t) (deftest logtest.error.2 (signals-error (logtest 0) program-error) t) (deftest logtest.error.3 (signals-error (logtest 0 0 nil) program-error) t) (deftest logtest.error.4 (check-type-error #'(lambda (x) (logtest x -1)) #'integerp) nil) (deftest logtest.error.5 (check-type-error #'(lambda (x) (logtest -1 x)) #'integerp) nil) ;;; Non-error tests (deftest logtest.1 (loop for x = (logand (random-fixnum) (random-fixnum)) for y = (logand (random-fixnum) (random-fixnum)) repeat 10000 unless (if (logtest x y) (not (zerop (logand x y))) (zerop (logand x y))) collect (list x y)) nil) (deftest logtest.2 (logtest 1 2) nil) (deftest logtest.3 (notnot-mv (logtest 8 (logior 8 4))) t) gcl27-2.7.0/ansi-tests/logxor.lsp000066400000000000000000000037121454061450500165710ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Sep 9 06:30:57 2003 ;;;; Contains: Tests of LOGXOR (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest logxor.error.1 (check-type-error #'logxor #'integerp) nil) (deftest logxor.error.2 (check-type-error #'(lambda (x) (logxor 0 x)) #'integerp) nil) ;;; Non-error tests (deftest logxor.1 (logxor) 0) (deftest logxor.2 (logxor 1231) 1231) (deftest logxor.3 (logxor -198) -198) (deftest logxor.4 (loop for x in *integers* always (eql x (logxor x))) t) (deftest logxor.5 (loop for x in *integers* always (and (eql -1 (logxor x (lognot x))) (eql 0 (logxor x x)) (eql x (logxor x x x)))) t) (deftest logxor.6 (loop for x = (random-fixnum) for xc = (lognot x) repeat 1000 unless (eql -1 (logxor x xc)) collect x) nil) (deftest logxor.7 (loop for x = (random-from-interval (ash 1 (random 200))) for y = (random-from-interval (ash 1 (random 200))) for z = (logxor x y) repeat 1000 unless (and (if (or (and (< x 0) (>= y 0)) (and (>= x 0) (< y 0))) (< z 0) (>= z 0)) (loop for i from 1 to 210 always (if (or (and (logbitp i x) (not (logbitp i y))) (and (not (logbitp i x)) (logbitp i y))) (logbitp i z) (not (logbitp i z))))) collect (list x y z)) nil) (deftest logxor.8 (loop for i from 1 to (min 256 (1- call-arguments-limit)) for args = (nconc (make-list (1- i) :initial-element 0) (list 7131)) always (eql (apply #'logxor args) 7131)) t) (deftest logxor.order.1 (let ((i 0) a b) (values (logxor (progn (setf a (incf i)) #b11011) (progn (setf b (incf i)) #b10110)) i a b)) #b1101 2 1 2) (deftest logxor.order.2 (let ((i 0) a b c) (values (logxor (progn (setf a (incf i)) #b11011) (progn (setf b (incf i)) #b10110) (progn (setf c (incf i)) #b110101)) i a b c)) #b111000 3 1 2 3) gcl27-2.7.0/ansi-tests/loop.lsp000066400000000000000000000030621454061450500162260ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 25 18:48:59 2002 ;;;; Contains: Tests of LOOP (in-package :cl-test) ;;; Simple loops (deftest sloop.1 (loop (return 'a)) a) (deftest sloop.2 (loop (return (values)))) (deftest sloop.3 (loop (return (values 'a 'b 'c 'd))) a b c d) (deftest sloop.4 (block nil (loop (return 'a)) 'b) b) (deftest sloop.5 (let ((i 0) (x nil)) (loop (when (>= 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)) ;;; Loop errors (def-macro-test loop.error.1 (loop)) (deftest loop-finish.error.1 (block done (loop for i from 1 to 10 do (macrolet ((%m (&environment env) (let ((mfn (macro-function 'loop-finish env))) (cond ((not mfn) '(return-from done :fail1)) ((not (eval `(signals-error (funcall ,mfn) program-error))) '(return-from done :fail2)) ((not (eval `(signals-error (funcall ,mfn '(loop-finish)) program-error))) '(return-from done :fail3)) ((not (eval `(signals-error (funcall ,mfn '(loop-finish) nil nil) program-error))) '(return-from done :fail4)) (t '(return-from done :good)))))) (%m)))) :good) gcl27-2.7.0/ansi-tests/loop1.lsp000066400000000000000000000173611454061450500163160ustar00rootroot00000000000000;-*- 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) |# ;;; The arithmetic loop form says the types are numbers, not ;;; reals, so arguably they should work on complexes (which are ;;; numbers.) Comparing these for termination could be problematic, ;;; but a clause without termination should work just fine. (deftest loop.1.44 (loop for i from 1 to 5 for c from #c(0 1) collect c) (#c(0 1) #c(1 1) #c(2 1) #c(3 1) #c(4 1))) (deftest loop.1.45 (loop for i from 1 to 5 for c from #c(0 1) by 2 collect c) (#c(0 1) #c(2 1) #c(4 1) #c(6 1) #c(8 1))) (deftest loop.1.46 (loop for i from 1 to 5 for c downfrom #c(5 1) collect c) (#c(5 1) #c(4 1) #c(3 1) #c(2 1) #c(1 1))) (deftest loop.1.47 (loop for i from 1 to 5 for c downfrom #c(10 1) by 2 collect c) (#c(10 1) #c(8 1) #c(6 1) #c(4 1) #c(2 1))) (deftest loop.1.48 (loop for i from 1 to 5 for c upfrom #c(0 1) collect c) (#c(0 1) #c(1 1) #c(2 1) #c(3 1) #c(4 1))) (deftest loop.1.49 (loop for i from 1 to 5 for c upfrom #c(0 1) by 2 collect c) (#c(0 1) #c(2 1) #c(4 1) #c(6 1) #c(8 1))) ;;; The variable in the loop for-as-arithmetic clause ;;; can be a d-var-spec, so 'NIL' should mean don't bind anything (deftest loop.1.50 (let ((i 0)) (loop for nil from 10 to 15 collect (incf i))) (1 2 3 4 5 6)) (deftest loop.1.51 (let ((i 0)) (loop for nil from 10 below 15 collect (incf i))) (1 2 3 4 5)) (deftest loop.1.52 (loop for nil from 10 to 0 collect 'a) nil) (deftest loop.1.53 (let ((i 0)) (loop for nil from 0 to 10 by 2 collect (incf i))) (1 2 3 4 5 6)) (deftest loop.1.54 (let ((i 0)) (loop for nil from 1 to 4 for nil from 1 to 10 collect (incf i))) (1 2 3 4)) (deftest loop.1.55 (let ((i 0)) (loop for nil from 5 downto 0 collect (incf i))) (1 2 3 4 5 6)) (deftest loop.1.56 (let ((i 0)) (loop for nil from 5 above 0 collect (incf i))) (1 2 3 4 5)) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.1.57 (macrolet ((%m (z) z)) (loop for i from (expand-in-current-env (%m 1)) to 5 collect i)) (1 2 3 4 5)) (deftest loop.1.58 (macrolet ((%m (z) z)) (loop for i from 1 to (expand-in-current-env (%m 5)) collect i)) (1 2 3 4 5)) (deftest loop.1.59 (macrolet ((%m (z) z)) (loop for i from 1 to 5 by (expand-in-current-env (%m 2)) collect i)) (1 3 5)) (deftest loop.1.60 (macrolet ((%m (z) z)) (loop for i downfrom (expand-in-current-env (%m 10)) to 3 collect i)) (10 9 8 7 6 5 4 3)) (deftest loop.1.61 (macrolet ((%m (z) z)) (loop for i downfrom 10 to (expand-in-current-env (%m 3)) collect i)) (10 9 8 7 6 5 4 3)) (deftest loop.1.62 (macrolet ((%m (z) z)) (loop for i from (expand-in-current-env (%m 10)) downto 3 collect i)) (10 9 8 7 6 5 4 3)) (deftest loop.1.63 (macrolet ((%m (z) z)) (loop for i from 10 downto (expand-in-current-env (%m 3)) collect i)) (10 9 8 7 6 5 4 3)) (deftest loop.1.64 (macrolet ((%m (z) z)) (loop for i from (expand-in-current-env (%m 1)) below 5 collect i)) (1 2 3 4)) (deftest loop.1.65 (macrolet ((%m (z) z)) (loop for i from 1 below (expand-in-current-env (%m 5)) collect i)) (1 2 3 4)) gcl27-2.7.0/ansi-tests/loop10.lsp000066400000000000000000000255641454061450500164020ustar00rootroot00000000000000;-*- 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 (signals-error (loop with foo = 10 for x in '(a b c) count x into foo finally (return foo)) program-error) t) (deftest loop.10.10 (signals-error (loop with foo = 10 for x in '(a b c) counting x into foo finally (return foo)) program-error) t) (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 (signals-error (loop with foo = 100 for i from 1 to 10 maximize i into foo finally (return foo)) program-error) t) (deftest loop.10.38 (signals-error (loop with foo = 100 for i from 1 to 10 maximizing i into foo finally (return foo)) program-error) t) (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 (signals-error (loop with foo = 100 for i from 1 to 10 minimize i into foo finally (return foo)) program-error) t) (deftest loop.10.58 (signals-error (loop with foo = 100 for i from 1 to 10 minimizing i into foo finally (return foo)) program-error) t) (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 (signals-error (loop with foo = 100 for i from 1 to 4 sum i into foo finally (return foo)) program-error) t) (deftest loop.10.86 (signals-error (loop with foo = 100 for i from 1 to 4 summing i into foo finally (return foo)) program-error) t) (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) (deftest loop.10.94 (loop for i in nil sum i of-type integer) 0) (deftest loop.10.95 (loop for i in nil sum i of-type fixnum) 0) (deftest loop.10.96 (loop for i in nil sum i of-type bit) 0) (deftest loop.10.97 (loop for i in nil sum i of-type (integer 0 100)) 0) (deftest loop.10.98 (loop for i in nil sum i of-type (integer -100 0)) 0) (deftest loop.10.99 (loop for i in nil sum i of-type (integer -100 100)) 0) (deftest loop.10.100 (loop for i in nil sum i of-type (and integer (real -100.0 100.0))) 0) (deftest loop.10.101 (loop for i in nil sum i of-type short-float) 0.0s0) (deftest loop.10.102 (loop for i in nil sum i of-type single-float) 0.0f0) (deftest loop.10.103 (loop for i in nil sum i of-type double-float) 0.0d0) (deftest loop.10.104 (loop for i in nil sum i of-type long-float) 0.0l0) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.10.105 (macrolet ((%m (z) z)) (loop for x from 1 to 10 count (expand-in-current-env (%m (< x 5))))) 4) (deftest loop.10.106 (macrolet ((%m (z) z)) (loop for x from 1 to 10 counting (expand-in-current-env (%m t)))) 10) (deftest loop.10.107 (macrolet ((%m (z) z)) (loop for x in '(1 4 10 5 7 9) maximize (expand-in-current-env (%m x)))) 10) (deftest loop.10.108 (macrolet ((%m (z) z)) (loop for x in '(1 4 10 5 7 9) maximizing (expand-in-current-env (%m 17)))) 17) (deftest loop.10.109 (macrolet ((%m (z) z)) (loop for x in '(5 4 10 1 7 9) minimize (expand-in-current-env (%m x)))) 1) (deftest loop.10.110 (macrolet ((%m (z) z)) (loop for x in '(5 4 10 1 7 9) minimizing (expand-in-current-env (%m 3)))) 3) (deftest loop.10.111 (macrolet ((%m (z) z)) (loop for x in '(1 4 10 5 7 9) sum (expand-in-current-env (%m x)))) 36) (deftest loop.10.112 (macrolet ((%m (z) z)) (loop for x in '(1 4 10 5 7 9) summing (expand-in-current-env (%m 2)))) 12) gcl27-2.7.0/ansi-tests/loop11.lsp000066400000000000000000000075741454061450500164040ustar00rootroot00000000000000;-*- 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)) ;;; Enough implementors have complained about this test that ;;; I'm removing it. The standard is self-contradictory ;;; on whether REPEAT can occur later in a LOOP form. ;;; (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) ;;; More tests of a bug that showed up in c.l.l (deftest loop.11.29 (loop for i in '(4 8 9 A 13) when (eq i 'a) return :good while (< i 12) collect i) :good) (deftest loop.11.30 (loop for i in '(4 8 9 A 13) unless (numberp i) return :good while (< i 12) collect i) :good) (deftest loop.11.31 (loop for i in '(4 8 9 A 13) when (eq i 'a) return :good until (> i 12) collect i) :good) (deftest loop.11.32 (loop for i in '(4 8 9 A 13) unless (numberp i) return :good until (> i 12) collect i) :good) (deftest loop.11.33 (loop for i in '(4 8 9 A 13) if (not (numberp i)) return :good end while (< i 12) collect i) :good) (deftest loop.11.34 (loop for i in '(4 8 9 A 13) if (not (numberp i)) return :good end until (> i 12) collect i) :good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.11.35 (macrolet ((%m (z) z)) (loop repeat (expand-in-current-env (%m 5)) collect 'x)) (x x x x x)) gcl27-2.7.0/ansi-tests/loop12.lsp000066400000000000000000000106401454061450500163710ustar00rootroot00000000000000;-*- 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 (signals-error (loop for i from 1 to 10 collect i always (< i 20)) program-error) t) (deftest loop.12.error.50a (signals-error (loop for i from 1 to 10 always (< i 20) collect i) program-error) t) (deftest loop.12.error.51 (signals-error (loop for i from 1 to 10 collect i never (> i 20)) program-error) t) (deftest loop.12.error.51a (signals-error (loop for i from 1 to 10 never (> i 20) collect i) program-error) t) (deftest loop.12.error.52 (signals-error (loop for i from 1 to 10 collect i thereis (> i 20)) program-error) t) (deftest loop.12.error.52a (signals-error (loop for i from 1 to 10 thereis (> i 20) collect i) program-error) t) ;;; 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) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.12.56 (macrolet ((%m (z) z)) (loop for i in '(1 2 3 4) always (expand-in-current-env (%m (< i 10))))) t) (deftest loop.12.57 (macrolet ((%m (z) z)) (loop for i in '(1 2 3 4) always (expand-in-current-env (%m t)))) t) (deftest loop.12.58 (macrolet ((%m (z) z)) (loop for i in '(1 2 3 4) never (expand-in-current-env (%m (>= i 10))))) t) (deftest loop.12.59 (macrolet ((%m (z) z)) (loop for i in '(1 2 3 4) never (expand-in-current-env (%m t)))) nil) (deftest loop.12.60 (macrolet ((%m (z) z)) (loop for i in '(1 2 3 4) thereis (expand-in-current-env (%m (and (>= i 2) (+ i 1)))))) 3) gcl27-2.7.0/ansi-tests/loop13.lsp000066400000000000000000000222261454061450500163750ustar00rootroot00000000000000;-*- 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- (min call-arguments-limit 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) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.13.88 (macrolet ((%m (z) z)) (loop do (expand-in-current-env (%m (return 10))))) 10) (deftest loop.13.89 (macrolet ((%m (z) z)) (loop for i from 0 below 100 by 7 when (> i 50) return (expand-in-current-env (%m i)))) 56) (deftest loop.13.90 (macrolet ((%m (z) z)) (loop return (expand-in-current-env (%m 'a)))) a) gcl27-2.7.0/ansi-tests/loop14.lsp000066400000000000000000000162401454061450500163750ustar00rootroot00000000000000;-*- 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) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.14.46 (macrolet ((%m (z) z)) (loop for x from 1 to 6 when (expand-in-current-env (%m (evenp x))) collect x)) (2 4 6)) (deftest loop.14.47 (macrolet ((%m (z) z)) (loop for x from 1 to 6 unless (expand-in-current-env (%m (evenp x))) collect x)) (1 3 5)) (deftest loop.14.48 (macrolet ((%m (z) z)) (loop for x from 1 to 6 when (expand-in-current-env (%m t)) sum x)) 21) (deftest loop.14.49 (macrolet ((%m (z) z)) (loop for x from 1 to 10 if (expand-in-current-env (%m (evenp x))) collect x end)) (2 4 6 8 10)) gcl27-2.7.0/ansi-tests/loop15.lsp000066400000000000000000000117671454061450500164070ustar00rootroot00000000000000;-*- 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 (let () (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 (let () (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 (let () (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 (let () (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 (let () (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 (let () (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) gcl27-2.7.0/ansi-tests/loop16.lsp000066400000000000000000000122641454061450500164010ustar00rootroot00000000000000;-*- 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 (let () (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 (let () (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 (let () (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 (let () (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 (let () (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 (let () (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) gcl27-2.7.0/ansi-tests/loop17.lsp000066400000000000000000000045551454061450500164060ustar00rootroot00000000000000;-*- 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)) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.17.22 (macrolet ((%m (z) z)) (loop with x = 0 initially (expand-in-current-env (%m (incf x))) until t finally (expand-in-current-env (%m (return x))))) 1) gcl27-2.7.0/ansi-tests/loop2.lsp000066400000000000000000000062141454061450500163120ustar00rootroot00000000000000;-*- 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 (signals-error (loop for x in '(a . b) collect x) type-error) t) (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 (signals-error (loop for x in '(a b c) for x in '(d e f) collect x) program-error) t) (deftest loop.2.15 (signals-error (loop for (x . x) in '((a b) (c d)) collect x) program-error) t) (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) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.2.24 (macrolet ((%m (z) z)) (loop for x in (expand-in-current-env (%m '(1 2 3))) sum x)) 6) (deftest loop.2.25 (macrolet ((%m (z) z)) (loop for (x . y) in (expand-in-current-env (%m '((a . b) (c . d) (e . f)))) collect (list x y))) ((a b) (c d) (e f))) (deftest loop.2.26 (macrolet ((%m (z) z)) (loop as x in (expand-in-current-env (%m '(1 2 3))) sum x)) 6)gcl27-2.7.0/ansi-tests/loop3.lsp000066400000000000000000000065061454061450500163170ustar00rootroot00000000000000;-*- 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 (signals-error (loop for x on '(a b c) for x on '(d e f) collect x) program-error) t) (deftest loop.3.15 (signals-error (loop for (x . x) on '((a b) (c d)) collect x) program-error) t) (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) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.3.24 (macrolet ((%m (z) z)) (loop for x on (expand-in-current-env (%m '(1 2 3))) sum (car x))) 6) (deftest loop.3.25 (macrolet ((%m (z) z)) (loop for e on (expand-in-current-env (%m '(a b c d e f))) by #'cddr collect (car e))) (a c e)) (deftest loop.3.26 (macrolet ((%m (z) z)) (loop for e on '(a b c d e f) by (expand-in-current-env (%m #'cddr)) collect (car e))) (a c e)) (deftest loop.3.27 (macrolet ((%m (z) z)) (loop as x on (expand-in-current-env (%m '(1 2 3))) sum (car x))) 6) gcl27-2.7.0/ansi-tests/loop4.lsp000066400000000000000000000037061454061450500163170ustar00rootroot00000000000000;-*- 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 (signals-error (loop for (x . x) = '(nil nil nil) until x count t) program-error) t) (deftest loop.4.7 (signals-error (macroexpand '(loop for (x . x) = '(nil nil nil) until x count t)) program-error) t) (deftest loop.4.8 (signals-error (macroexpand '(loop for x = '(nil nil nil) for x = 1 count x until t)) program-error) t) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.4.9 (macrolet ((%m (z) z)) (loop for x = (expand-in-current-env (%m 1)) then (1+ x) until (> x 5) collect x)) (1 2 3 4 5)) (deftest loop.4.10 (macrolet ((%m (z) z)) (loop for x = 1 then (expand-in-current-env (%m (1+ x))) until (> x 5) collect x)) (1 2 3 4 5)) (deftest loop.4.11 (macrolet ((%m (z) z)) (loop for x = 1 then (1+ x) until (expand-in-current-env (%m (> x 5))) collect x)) (1 2 3 4 5)) (deftest loop.4.12 (macrolet ((%m (z) z)) (loop for x = 1 then (1+ x) while (expand-in-current-env (%m (<= x 5))) collect x)) (1 2 3 4 5)) (deftest loop.4.13 (macrolet ((%m (z) z)) (loop for x = 1 then (1+ x) until (> x 5) collect (expand-in-current-env (%m x)))) (1 2 3 4 5)) gcl27-2.7.0/ansi-tests/loop5.lsp000066400000000000000000000140421454061450500163130ustar00rootroot00000000000000;-*- 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 (make-array '(4) :initial-contents "abcd" :element-type 'base-char))) (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)) (deftest loop.5.39 (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) :fill-pointer 6))) (loop for x across v collect x)) (1 2 3 4 5 6)) (deftest loop.5.40 (loop for i from 1 to 40 for type = `(unsigned-byte ,i) for v = (make-array '(10) :initial-contents '(0 0 1 1 0 1 1 1 0 0) :element-type type) for r = (loop for x across v collect x) unless (equal r '(0 0 1 1 0 1 1 1 0 0)) collect (list i r)) nil) (deftest loop.5.41 (loop for i from 1 to 40 for type = `(signed-byte ,i) for v = (make-array '(10) :initial-contents '(0 0 -1 -1 0 -1 -1 -1 0 0) :element-type type) for r = (loop for x across v collect x) unless (equal r '(0 0 -1 -1 0 -1 -1 -1 0 0)) collect (list i r)) nil) (deftest loop.5.42 (let ((vals '(0 0 1 1 0 1 1 1 0 0))) (loop for type in '(short-float single-float double-float long-float) for fvals = (loop for v in vals collect (coerce v type)) for v = (make-array '(10) :initial-contents fvals :element-type type) for r = (loop for x across v collect x) unless (equal r fvals) collect (list fvals r))) nil) (deftest loop.5.43 (let ((vals '(0 0 1 1 0 1 1 1 0 0))) (loop for etype in '(short-float single-float double-float long-float) for type = `(complex ,etype) for fvals = (loop for v in vals collect (coerce v type)) for v = (make-array '(10) :initial-contents fvals :element-type type) for r = (loop for x across v collect x) unless (equal r fvals) collect (list fvals r))) nil) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.5.44 (macrolet ((%m (z) z)) (loop for x across (expand-in-current-env (%m "148X")) collect x)) (#\1 #\4 #\8 #\X)) (deftest loop.5.45 (macrolet ((%m (z) z)) (loop as x across (expand-in-current-env (%m #*00110110)) collect x)) (0 0 1 1 0 1 1 0)) ;;; FIXME ;;; Add tests for other specialized array types (integer types, floats, complex) ;;; Error cases (deftest loop.5.error.1 (signals-error (loop for (e . e) across (vector '(x . y) '(u . v)) collect e) program-error) t) (deftest loop.5.error.2 (signals-error (loop for e across (vector '(x . y) '(u . v)) for e from 1 to 5 collect e) program-error) t) (deftest loop.5.error.3 (signals-error (macroexpand '(loop for (e . e) across (vector '(x . y) '(u . v)) collect e)) program-error) t) (deftest loop.5.error.4 (signals-error (macroexpand '(loop for e across (vector '(x . y) '(u . v)) for e from 1 to 5 collect e)) program-error) t) gcl27-2.7.0/ansi-tests/loop6.lsp000066400000000000000000000167661454061450500163330ustar00rootroot00000000000000;-*- 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)) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.6.41 (macrolet ((%m (z) z)) (loop for x being the hash-value of (expand-in-current-env (%m *loop.6.hash.1*)) sum x)) 6) (deftest loop.6.42 (macrolet ((%m (z) z)) (sort (loop for x being the hash-key of (expand-in-current-env (%m *loop.6.hash.1*)) collect x) #'symbol<)) (a b c)) ;;; Error tests (deftest loop.6.error.1 (signals-error (loop for k from 1 to 10 for k being the hash-keys of *loop.6.hash.1* count t) program-error) t) (deftest loop.6.error.2 (signals-error (loop for k being the hash-keys of *loop.6.hash.1* for k from 1 to 10 count t) program-error) t) (deftest loop.6.error.3 (signals-error (loop for (k . k) being the hash-keys of *loop.6.hash.3* count t) program-error) t) (deftest loop.6.error.4 (signals-error (loop for k being the hash-keys of *loop.6.hash.3* using (hash-value k) count t) program-error) t) (deftest loop.6.error.5 (signals-error (loop for k being the hash-values of *loop.6.hash.3* using (hash-key k) count t) program-error) t) gcl27-2.7.0/ansi-tests/loop7.lsp000066400000000000000000000143271454061450500163230ustar00rootroot00000000000000;-*- 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 (let () (ignore-errors (delete-package "LOOP.MISSING.PACKAGE")) (signals-error (loop for x being each symbol of "LOOP.MISSING.PACKAGE" collect x) package-error)) t) (deftest loop.7.19 (let () (ignore-errors (delete-package "LOOP.MISSING.PACKAGE")) (signals-error (loop for x being each present-symbol of "LOOP.MISSING.PACKAGE" collect x) package-error)) t) (deftest loop.7.20 (let () (ignore-errors (delete-package "LOOP.MISSING.PACKAGE")) (signals-error (loop for x being each external-symbol of "LOOP.MISSING.PACKAGE" collect x) package-error)) t) ;;; 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")) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.7.33 (macrolet ((%m (z) z)) (sort (mapcar #'symbol-name (loop for x being the symbols of (expand-in-current-env (%m "LOOP.CL-TEST.1")) collect x)) #'string<)) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.34 (macrolet ((%m (z) z)) (sort (mapcar #'symbol-name (loop for x being the external-symbols of (expand-in-current-env (%m "LOOP.CL-TEST.1")) collect x)) #'string<)) ("A" "B" "C")) (deftest loop.7.35 (macrolet ((%m (z) z)) (sort (mapcar #'symbol-name (loop for x being the present-symbols of (expand-in-current-env (%m "LOOP.CL-TEST.2")) collect x)) #'string<)) ("X" "Y" "Z")) gcl27-2.7.0/ansi-tests/loop8.lsp000066400000000000000000000057711454061450500163270ustar00rootroot00000000000000;-*- 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) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.8.24 (macrolet ((%m (z) z)) (loop with x = (expand-in-current-env (%m 1)) do (return x))) 1) ;;; 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 (signals-error (loop with a = 1 and a = 2 return a) program-error) t) (deftest loop.8.error.2 (signals-error (loop with a = 1 with a = 2 return a) program-error) t) gcl27-2.7.0/ansi-tests/loop9.lsp000066400000000000000000000132021454061450500163140ustar00rootroot00000000000000;-*- 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 (signals-error (loop with foo = '(a b) for x in '(c d) collect x into foo finally (return foo)) program-error) t) (deftest loop.9.11 (signals-error (loop with foo = '(a b) for x in '(c d) collecting x into foo finally (return foo)) program-error) t) (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 (signals-error (loop with foo = '(a b) for x in '(c d) append (list x) into foo finally (return foo)) program-error) t) (deftest loop.9.28 (signals-error (loop with foo = '(a b) for x in '(c d) appending (list x) into foo finally (return foo)) program-error) t) ;;; 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 (signals-error (loop with foo = '(a b) for x in '(c d) nconc (list x) into foo finally (return foo)) program-error) t) (deftest loop.9.38 (signals-error (loop with foo = '(a b) for x in '(c d) nconcing (list x) into foo finally (return foo)) program-error) t) ;;; 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)) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.9.43 (macrolet ((%m (z) z)) (loop for x in '(1 2 3) collect (expand-in-current-env (%m (- x))))) (-1 -2 -3)) (deftest loop.9.44 (macrolet ((%m (z) z)) (loop for x in '(1 2 3) collecting (expand-in-current-env (%m (list x))))) ((1) (2) (3))) (deftest loop.9.45 (macrolet ((%m (z) z)) (loop for x in '(a b c) collect (expand-in-current-env (%m (list x))) into foo finally (return (reverse foo)))) ((c) (b) (a))) (deftest loop.9.46 (macrolet ((%m (z) z)) (loop for x in '((a b) (c d) (e f g) () (i)) append (expand-in-current-env (%m x)))) (a b c d e f g i)) (deftest loop.9.47 (macrolet ((%m (z) z)) (loop for x in '((a b) (c d) (e f g) () (i)) nconc (expand-in-current-env (%m (copy-seq x))))) (a b c d e f g i)) gcl27-2.7.0/ansi-tests/macro-function.lsp000066400000000000000000000057731454061450500202140ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Jun 3 22:17:34 2005 ;;;; Contains: Tests of MACRO-FUNCTION (in-package :cl-test) (deftest macro-function.1 (loop for n in *cl-macro-symbols* unless (macro-function n) collect n) nil) (deftest macro-function.2 (loop for n in *cl-macro-symbols* unless (macro-function n nil) collect n) nil) (deftest macro-function.3 (loop for n in *cl-macro-symbols* unless (eval `(macrolet ((%m (s &environment env) (list 'quote (macro-function s env)))) (%m ,n))) collect n) nil) (deftest macro-function.4 (macro-function (gensym)) nil) (deftest macro-function.5 (remove-if-not #'macro-function *cl-function-symbols*) nil) (deftest macro-function.6 (remove-if-not #'macro-function *cl-accessor-symbols*) nil) (deftest macro-function.7 (let ((fn (macrolet ((%m () 16)) (macrolet ((%n (&environment env) (list 'quote (macro-function '%m env)))) (%n))))) (values (notnot (functionp fn)) (funcall fn '(%m) nil))) t 16) (deftest macro-function.8 (let ((sym (gensym))) (setf (macro-function sym) (macro-function 'pop)) (eval `(let ((x '(a b c))) (values (,sym x) x)))) a (b c)) (deftest macro-function.9 (let ((sym (gensym))) (setf (macro-function sym nil) (macro-function 'pop)) (eval `(let ((x '(a b c))) (values (,sym x) x)))) a (b c)) (deftest macro-function.10 (let ((sym (gensym))) (eval `(defun ,sym (x) :bad)) (setf (macro-function sym) (macro-function 'pop)) (eval `(let ((x '(a b c))) (values (,sym x) x)))) a (b c)) (deftest macro-function.11 (let ((fn (flet ((%m () 16)) (macrolet ((%n (&environment env) (list 'quote (macro-function '%m env)))) (%n))))) fn) nil) (deftest macro-function.12 (let ((sym (gensym))) (eval `(defmacro ,sym () t)) (let ((i 0)) (values (funcall (macro-function (progn (incf i) sym)) (list sym) nil) i))) t 1) (deftest macro-function.13 (let ((sym (gensym))) (eval `(defmacro ,sym () t)) (let ((i 0) a b) (values (funcall (macro-function (progn (setf a (incf i)) sym) (progn (setf b (incf i)) nil)) (list sym) nil) i a b))) t 2 1 2) (deftest macro-function.14 (let ((sym (gensym)) (i 0)) (setf (macro-function (progn (incf i) sym)) (macro-function 'pop)) (values (eval `(let ((x '(a b c))) (list (,sym x) x))) i)) (a (b c)) 1) (deftest macro-function.15 (let ((sym (gensym)) (i 0) a b) (setf (macro-function (progn (setf a (incf i)) sym) (progn (setf b (incf i)) nil)) (macro-function 'pop)) (values (eval `(let ((x '(a b c))) (list (,sym x) x))) i a b)) (a (b c)) 2 1 2) ;;; Error tests (deftest macro-function.error.1 (signals-error (macro-function) program-error) t) (deftest macro-function.error.2 (signals-error (macro-function 'pop nil nil) program-error) t) gcl27-2.7.0/ansi-tests/macroexpand-1.lsp000066400000000000000000000032271454061450500177170ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 28 13:47:32 2005 ;;;; Contains: Tests of MACROEXPAND-1 (in-package :cl-test) (deftest macroexpand-1.error.1 (signals-error (macroexpand-1) program-error) t) (deftest macroexpand-1.error.2 (signals-error (macroexpand-1 'x nil nil) program-error) t) ;;; Non-error tests (deftest macroexpand-1.1 (check-predicate #'(lambda (x) (or (symbolp x) (consp x) (let ((vals (multiple-value-list (macroexpand-1 x)))) (and (= (length vals) 2) (eql (car vals) x) (null (cadr vals))))))) nil) (deftest macroexpand-1.2 (check-predicate #'(lambda (x) (or (symbolp x) (consp x) (let ((vals (multiple-value-list (macroexpand-1 x nil)))) (and (= (length vals) 2) (eql (car vals) x) (null (cadr vals))))))) nil) (deftest macroexpand-1.3 (macrolet ((%m (&environment env) `(quote ,(check-predicate #'(lambda (x) (or (symbolp x) (consp x) (let ((vals (multiple-value-list (macroexpand-1 x env)))) (and (= (length vals) 2) (eql (car vals) x) (null (cadr vals)))))))))) (%m)) nil) (deftest macroexpand-1.4 (macrolet ((%m () ''foo)) (macrolet ((%m2 (&environment env) (macroexpand-1 '(%m) env))) (%m2))) foo) (deftest macroexpand-1.5 (let ((form (list (gensym))) (i 0)) (values (equalt (macroexpand-1 (progn (incf i) form)) form) i)) t 1) (deftest macroexpand-1.6 (let ((form (list (gensym))) (i 0) a b) (values (equalt (macroexpand-1 (progn (setf a (incf i)) form) (progn (setf b (incf i)) nil)) form) i a b)) t 2 1 2) gcl27-2.7.0/ansi-tests/macroexpand.lsp000066400000000000000000000031451454061450500175600ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 28 13:43:00 2005 ;;;; Contains: Tests of MACROEXPAND (in-package :cl-test) (deftest macroexpand.error.1 (signals-error (macroexpand) program-error) t) (deftest macroexpand.error.2 (signals-error (macroexpand 'x nil nil) program-error) t) ;;; Non-error tests (deftest macroexpand.1 (check-predicate #'(lambda (x) (or (symbolp x) (consp x) (let ((vals (multiple-value-list (macroexpand x)))) (and (= (length vals) 2) (eql (car vals) x) (null (cadr vals))))))) nil) (deftest macroexpand.2 (check-predicate #'(lambda (x) (or (symbolp x) (consp x) (let ((vals (multiple-value-list (macroexpand x nil)))) (and (= (length vals) 2) (eql (car vals) x) (null (cadr vals))))))) nil) (deftest macroexpand.3 (macrolet ((%m (&environment env) `(quote ,(check-predicate #'(lambda (x) (or (symbolp x) (consp x) (let ((vals (multiple-value-list (macroexpand x env)))) (and (= (length vals) 2) (eql (car vals) x) (null (cadr vals)))))))))) (%m)) nil) (deftest macroexpand.4 (macrolet ((%m () ''foo)) (macrolet ((%m2 (&environment env) (macroexpand '(%m) env))) (%m2))) foo) (deftest macroexpand.5 (let ((form (list (gensym))) (i 0)) (values (equalt (macroexpand (progn (incf i) form)) form) i)) t 1) (deftest macroexpand.6 (let ((form (list (gensym))) (i 0) a b) (values (equalt (macroexpand (progn (setf a (incf i)) form) (progn (setf b (incf i)) nil)) form) i a b)) t 2 1 2) gcl27-2.7.0/ansi-tests/macrolet.lsp000066400000000000000000000226271454061450500170730ustar00rootroot00000000000000;-*- 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 = `(ignore-errors (macrolet ((,s () ''a)) (,s))) unless (eq (eval form) 'a) collect s) nil) (deftest macrolet.17 (macrolet ((%m (&key (a t)) `(quote ,a))) (%m :a nil)) nil) (deftest macrolet.18 (macrolet ((%m (&key (a t a-p)) `(quote (,a ,(notnot a-p))))) (%m :a nil)) (nil t)) (deftest macrolet.19 (macrolet ((%m (x &optional y) `(quote (,x ,y)))) (values (%m 1) (%m 2 3))) (1 nil) (2 3)) (deftest macrolet.20 (macrolet ((%m (x &optional (y 'a)) `(quote (,x ,y)))) (values (%m 1) (%m 2 3))) (1 a) (2 3)) ;;; Note -- the supplied-p parameter in a macrolet &optional ;;; is required to be T (not just true) if the parameter is present. ;;; See section 3.4.4.1.2 (deftest macrolet.21 (macrolet ((%m (x &optional (y 'a y-p)) `(quote (,x ,y ,y-p)))) (values (%m 1) (%m 2 3))) (1 a nil) (2 3 t)) (deftest macrolet.22 (macrolet ((%m (x &optional ((y z) '(2 3))) `(quote (,x ,y ,z)))) (values (%m a) (%m a (b c)))) (a 2 3) (a b c)) (deftest macrolet.22a (macrolet ((%m (x &optional ((y z) '(2 3) y-z-p)) `(quote (,x ,y ,z ,y-z-p)))) (values (%m a) (%m a (b c)))) (a 2 3 nil) (a b c t)) (deftest macrolet.23 (macrolet ((%m (&rest y) `(quote ,y))) (%m 1 2 3)) (1 2 3)) ;;; According to 3.4.4.1.2, the entity following &rest is ;;; 'a destructuring pattern that matches the rest of the list.' (deftest macrolet.24 (macrolet ((%m (&rest (x y z)) `(quote (,x ,y ,z)))) (%m 1 2 3)) (1 2 3)) (deftest macrolet.25 (macrolet ((%m (&body (x y z)) `(quote (,x ,y ,z)))) (%m 1 2 3)) (1 2 3)) ;;; More key parameters (deftest macrolet.26 (macrolet ((%m (&key ((:a b))) `(quote ,b))) (values (%m) (%m :a x))) nil x) (deftest macrolet.27 (macrolet ((%m (&key ((:a (b c)))) `(quote (,c ,b)))) (%m :a (1 2))) (2 1)) (deftest macrolet.28 (macrolet ((%m (&key ((:a (b c)) '(3 4))) `(quote (,c ,b)))) (values (%m :a (1 2)) (%m :a (1 2) :a (10 11)) (%m))) (2 1) (2 1) (4 3)) (deftest macrolet.29 (macrolet ((%m (&key a (b a)) `(quote (,a ,b)))) (values (%m) (%m :a 1) (%m :b 2) (%m :a 3 :b 4) (%m :b 5 :a 6) (%m :a 7 :a 8) (%m :a 9 :b nil) (%m :a 10 :b nil :b 11))) (nil nil) (1 1) (nil 2) (3 4) (6 5) (7 7) (9 nil) (10 nil)) (deftest macrolet.30 (macrolet ((%m ((&key a) &key (b a)) `(quote (,a ,b)))) (values (%m ()) (%m (:a 1)) (%m () :b 2) (%m (:a 3) :b 4) (%m (:a 7 :a 8)) (%m (:a 9) :b nil) (%m (:a 10) :b nil :b 11))) (nil nil) (1 1) (nil 2) (3 4) (7 7) (9 nil) (10 nil)) (deftest macrolet.31 (macrolet ((%m (&key ((:a (b c)) '(3 4) a-p)) `(quote (,(notnot a-p) ,c ,b)))) (values (%m :a (1 2)) (%m :a (1 2) :a (10 11)) (%m))) (t 2 1) (t 2 1) (nil 4 3)) ;;; Allow-other-keys tests (deftest macrolet.32 (macrolet ((%m (&key a b c) `(quote (,a ,b ,c)))) (values (%m :allow-other-keys nil) (%m :a 1 :allow-other-keys nil) (%m :allow-other-keys t) (%m :allow-other-keys t :allow-other-keys nil :foo t) (%m :allow-other-keys t :c 1 :b 2 :a 3) (%m :allow-other-keys nil :c 1 :b 2 :a 3))) (nil nil nil) (1 nil nil) (nil nil nil) (nil nil nil) (3 2 1) (3 2 1)) (deftest macrolet.33 (macrolet ((%m (&key allow-other-keys) `(quote ,allow-other-keys))) (values (%m) (%m :allow-other-keys nil) (%m :allow-other-keys t :foo t))) nil nil t) (deftest macrolet.34 (macrolet ((%m (&key &allow-other-keys) :good)) (values (%m) (%m :foo t) (%m :allow-other-keys nil :foo t))) :good :good :good) (deftest macrolet.35 (macrolet ((%m (&key a b &allow-other-keys) `(quote (,a ,b)))) (values (%m :a 1) (%m :foo t :b 2) (%m :allow-other-keys nil :a 1 :foo t :b 2))) (1 nil) (nil 2) (1 2)) ;;; &whole is followed by a destructuring pattern (see 3.4.4.1.2) (deftest macrolet.36 (macrolet ((%m (&whole (m a b) c d) `(quote (,m ,a ,b ,c ,d)))) (%m 1 2)) (%m 1 2 1 2)) ;;; Macro names are shadowed by local functions (deftest macrolet.37 (macrolet ((%f () :bad)) (flet ((%f () :good)) (%f))) :good) ;;; The &environment parameter is bound first (deftest macrolet.38 (macrolet ((foo () 1)) (macrolet ((%f (&optional (x (macroexpand '(foo) env)) &environment env) x)) (%f))) 1) ;;; Test for bug that showed up in sbcl (deftest macrolet.39 (macrolet ((%m (()) :good)) (%m ())) :good) ;;; Test that macrolets accept declarations (deftest macrolet.40 (macrolet ((%x () t)) (declare (optimize))) nil) (deftest macrolet.41 (macrolet ((%x () t)) (declare (optimize)) (declare (notinline identity))) nil) (deftest macrolet.42 (macrolet ((%x () t)) (declare (optimize)) (%x)) t) (deftest macrolet.43 (let ((*x-in-macrolet.43* nil)) (declare (special *x-in-macrolet.43*)) (let ((*f* #'(lambda () *x-in-macrolet.43*))) (declare (special *f*)) (eval `(macrolet ((%m (*x-in-macrolet.43*) (declare (special *f*)) (funcall *f*))) (%m t))))) nil) (deftest macrolet.44 (let ((*x-in-macrolet.44* nil)) (declare (special *x-in-macrolet.44*)) (let ((*f* #'(lambda () *x-in-macrolet.44*))) (declare (special *f*)) (eval `(macrolet ((%m (*x-in-macrolet.44*) (declare (special *f* *x-in-macrolet.44*)) (funcall *f*))) (%m t))))) t) (deftest macrolet.45 (let ((*x-in-macrolet.45* nil)) (declare (special *x-in-macrolet.45*)) (let ((*f* #'(lambda () *x-in-macrolet.45*))) (declare (special *f*)) (eval `(macrolet ((%m ((*x-in-macrolet.45*)) (declare (special *f* *x-in-macrolet.45*)) (funcall *f*))) (%m (t)))))) t) ;;; Macros are expanded in the appropriate environment (deftest macrolet.46 (macrolet ((%m (z) z)) (macrolet () (expand-in-current-env (%m :good)))) :good) ;;; Free declarations in macrolet (deftest macrolet.47 (let ((x :good)) (declare (special x)) (let ((x :bad)) (macrolet () (declare (special x)) x))) :good) (deftest macrolet.48 (let ((x :good)) (let ((y :bad)) (macrolet () (declare (ignore y)) x))) :good) (deftest macrolet.49 (let ((x :good)) (let ((y :bad)) (macrolet () (declare (ignorable y)) x))) :good) ;;; TODO: more special declarations for other macrolet arguments gcl27-2.7.0/ansi-tests/make-array.lsp000066400000000000000000000513661454061450500173200ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Sep 20 06:47:37 2002 ;;;; Contains: Tests for MAKE-ARRAY (in-package :cl-test) (compile-and-load "array-aux.lsp") (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))))) ;; Should return a symbol only in error situations (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)) (deftest make-array.8c (loop for i from 1 to 32 for tp = `(unsigned-byte ,i) for a = (make-array 5 :fill-pointer 3 :element-type tp :initial-contents '(1 1 0 0 1)) when (symbolp a) collect (list i tp a)) nil) (deftest make-array.8d (loop for i from 2 to 32 for tp = `(signed-byte ,i) for a = (make-array 5 :fill-pointer 3 :element-type tp :initial-contents '(1 1 0 0 1)) when (symbolp a) collect (list i tp a)) nil) (deftest make-array.8e (loop for tp in '(short-float single-float double-float long-float) for v in '(1.0s0 1.0f0 1.0d0 1.0l0) for a = (make-array 5 :fill-pointer 3 :element-type tp :initial-element v) when (symbolp a) collect (list tp v a)) nil) (deftest make-array.8f (loop for tp in '(short-float single-float double-float long-float) for v in '(1.0s0 1.0f0 1.0d0 1.0l0) for a = (make-array 5 :fill-pointer 3 :element-type `(complex ,tp) :initial-element (complex v)) when (symbolp a) collect (list tp v a)) nil) ;;; 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.12a (make-array-with-checks 10 :element-type 'bit :initial-contents '(1 0 0 1 1 0 0 1 0 0) :fill-pointer 6) #*100110) (deftest make-array.12b (make-array-with-checks 10 :element-type 'character :initial-contents "abcdefghij" :fill-pointer 8) "abcdefgh") (deftest make-array.12c (make-array-with-checks 10 :element-type 'base-char :initial-contents "abcdefghij" :fill-pointer 8) "abcdefgh") (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.7a (make-array-with-checks '(4) :adjustable t :element-type 'bit :fill-pointer t :initial-contents '(1 0 0 1)) #(1 0 0 1)) (deftest make-array.adjustable.7b (make-array-with-checks '(4) :adjustable t :element-type 'base-char :fill-pointer t :initial-contents "abcd") "abcd") (deftest make-array.adjustable.7c (make-array-with-checks '(4) :adjustable t :element-type 'character :fill-pointer t :initial-contents "abcd") "abcd") (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 (signals-error (make-array) program-error) t) (deftest make-array.error.2 (signals-error (make-array '(10) :bad t) program-error) t) (deftest make-array.error.3 (signals-error (make-array '(10) :allow-other-keys nil :bad t) program-error) t) (deftest make-array.error.4 (signals-error (make-array '(10) :allow-other-keys nil :allow-other-keys t :bad t) program-error) t) (deftest make-array.error.5 (signals-error (make-array '(10) :bad) program-error) t) (deftest make-array.error.6 (signals-error (make-array '(10) 1 2) program-error) t) ;;; Order of evaluation tests (deftest make-array.order.1 (let ((i 0) a b c 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 e)) #(a a a a a) 4 1 2 3 4) (deftest make-array.order.2 (let ((i 0) a b 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 d e)) #(a a a a a) 4 1 2 3 4) ;; Must add back order tests for :displaced-to and :displaced-index-offset gcl27-2.7.0/ansi-tests/make-broadcast-stream.lsp000066400000000000000000000053301454061450500214230ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jan 29 21:28:25 2004 ;;;; Contains: Tests of MAKE-BROADCAST-STREAM (in-package :cl-test) (deftest make-broadcast-stream.1 (let ((s (make-broadcast-stream))) (assert (typep s 'stream)) (assert (typep s 'broadcast-stream)) (assert (output-stream-p s)) ;; (assert (not (input-stream-p s))) (assert (open-stream-p s)) (assert (streamp s)) ;; (assert (eq (stream-element-type s) t)) (values (notnot (typep s 'stream)) (notnot (typep s 'broadcast-stream)) (notnot (output-stream-p s)) (progn (write-char #\x s) nil) )) t t t nil) (deftest make-broadcast-stream.2 (with-output-to-string (s1) (let ((s (make-broadcast-stream s1))) (assert (typep s 'stream)) (assert (typep s 'broadcast-stream)) (assert (output-stream-p s)) ;; (assert (not (input-stream-p s))) (assert (open-stream-p s)) (assert (streamp s)) (assert (eql (stream-element-type s) (stream-element-type s1))) (write-char #\x s))) "x") (deftest make-broadcast-stream.3 (let ((s1 (make-string-output-stream)) (s2 (make-string-output-stream))) (let ((s (make-broadcast-stream s1 s2))) (assert (typep s 'stream)) (assert (typep s 'broadcast-stream)) (assert (output-stream-p s)) ;; (assert (not (input-stream-p s))) (assert (open-stream-p s)) (assert (streamp s)) (assert (eql (stream-element-type s) (stream-element-type s2))) (format s "This is a test")) (values (get-output-stream-string s1) (get-output-stream-string s2))) "This is a test" "This is a test") (deftest make-broadcast-stream.4 (fresh-line (make-broadcast-stream)) nil) (deftest make-broadcast-stream.5 (file-length (make-broadcast-stream)) 0) (deftest make-broadcast-stream.6 (file-position (make-broadcast-stream)) 0) (deftest make-broadcast-stream.7 (file-string-length (make-broadcast-stream) "antidisestablishmentarianism") 1) (deftest make-broadcast-stream.8 (stream-external-format (make-broadcast-stream)) :default) ;;; FIXME ;;; Add tests for: close, ;;; peek-char, read-char-no-hang, terpri, fresh-line, unread-char, ;;; read-line, write-line, write-string, read-sequence, write-sequence, ;;; read-byte, write-byte, listen, clear-input, finish-output, force-output, ;;; clear-output, print, prin1 princ ;;; Error tests (deftest make-broadcast-stream.error.1 (check-type-error #'make-broadcast-stream #'(lambda (x) (and (streamp x) (output-stream-p x)))) nil) (deftest make-broadcast-stream.error.2 (check-type-error #'make-broadcast-stream #'(lambda (x) (and (streamp x) (output-stream-p x))) *streams*) nil) gcl27-2.7.0/ansi-tests/make-concatenated-stream.lsp000066400000000000000000000201551454061450500221130ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 14 08:41:18 2004 ;;;; Contains: Tests of MAKE-CONCATENATED-STREAM (in-package :cl-test) (deftest make-concatenated-stream.1 (let ((s (make-concatenated-stream))) (read s nil :eof)) :eof) (deftest make-concatenated-stream.2 (let ((s (make-concatenated-stream))) (notnot-mv (input-stream-p s))) t) (deftest make-concatenated-stream.3 (let ((s (make-concatenated-stream))) (output-stream-p s)) nil) (deftest make-concatenated-stream.4 (let ((s (make-concatenated-stream))) (notnot-mv (streamp s))) t) (deftest make-concatenated-stream.5 (let ((s (make-concatenated-stream))) (notnot-mv (typep s 'stream))) t) (deftest make-concatenated-stream.6 (let ((s (make-concatenated-stream))) (notnot-mv (typep s 'concatenated-stream))) t) (deftest make-concatenated-stream.7 (let ((s (make-concatenated-stream))) (notnot-mv (open-stream-p s))) t) (deftest make-concatenated-stream.8 (let ((s (make-concatenated-stream *standard-input*))) (notnot-mv (stream-element-type s))) t) (deftest make-concatenated-stream.9 (let ((pn #p"tmp.dat") (element-type '(unsigned-byte 8))) (with-open-file (s pn :direction :output :element-type element-type :if-exists :supersede) (dolist (b '(1 5 9 13)) (write-byte b s))) (with-open-file (s1 pn :direction :input :element-type element-type) (with-open-file (s2 pn :direction :input :element-type element-type) (let ((s (make-concatenated-stream s1 s2))) (loop repeat 8 collect (read-byte s)))))) (1 5 9 13 1 5 9 13)) (deftest make-concatenated-stream.10 (let ((s (make-concatenated-stream))) (read-byte s nil :eof)) :eof) (deftest make-concatenated-stream.11 (let ((s (make-concatenated-stream))) (peek-char nil s nil :eof)) :eof) (deftest make-concatenated-stream.12 (with-input-from-string (s1 "a") (with-input-from-string (s2 "b") (let ((s (make-concatenated-stream s1 s2))) (values (peek-char nil s) (read-char s) (peek-char nil s) (read-char s) (peek-char nil s nil :eof))))) #\a #\a #\b #\b :eof) (deftest make-concatenated-stream.13 (with-input-from-string (s1 " a ") (with-input-from-string (s2 " b ") (let ((s (make-concatenated-stream s1 s2))) (values (peek-char t s) (read-char s) (peek-char t s) (read-char s) (peek-char t s nil :eof))))) #\a #\a #\b #\b :eof) (deftest make-concatenated-stream.14 (with-input-from-string (s1 "a") (with-input-from-string (s2 "b") (let ((s (make-concatenated-stream s1 s2))) (values (read-char s) (unread-char #\a s) (read-char s) (read-char s) (unread-char #\b s) (read-char s) (read-char s nil :eof))))) #\a nil #\a #\b nil #\b :eof) (deftest make-concatenated-stream.15 (let ((s (make-concatenated-stream))) (read-char-no-hang s nil :eof)) :eof) (deftest make-concatenated-stream.16 (with-input-from-string (s1 "a") (with-input-from-string (s2 "b") (let ((s (make-concatenated-stream s1 s2))) (values (read-char-no-hang s) (read-char-no-hang s) (read-char-no-hang s nil :eof))))) #\a #\b :eof) (deftest make-concatenated-stream.17 (with-input-from-string (s1 "a") (with-input-from-string (s2 "b") (let ((s (make-concatenated-stream s1 s2))) (multiple-value-bind (str mnp) (read-line s) (values str (notnot mnp)))))) "ab" t) (deftest make-concatenated-stream.18 (with-input-from-string (s1 "ab") (with-input-from-string (s2 "") (let ((s (make-concatenated-stream s1 s2))) (multiple-value-bind (str mnp) (read-line s) (values str (notnot mnp)))))) "ab" t) (deftest make-concatenated-stream.19 (with-input-from-string (s1 "") (with-input-from-string (s2 "ab") (let ((s (make-concatenated-stream s1 s2))) (multiple-value-bind (str mnp) (read-line s) (values str (notnot mnp)))))) "ab" t) (deftest make-concatenated-stream.20 (with-input-from-string (s1 "ab") (with-input-from-string (s2 (concatenate 'string (string #\Newline) "def")) (let ((s (make-concatenated-stream s1 s2))) (read-line s)))) "ab" nil) (deftest make-concatenated-stream.21 (with-input-from-string (s1 "") (with-input-from-string (s2 "") (let ((s (make-concatenated-stream s1 s2))) (multiple-value-bind (str mnp) (read-line s nil :eof) (values str (notnot mnp)))))) :eof t) (deftest make-concatenated-stream.22 (let ((pn #p"tmp.dat") (element-type '(unsigned-byte 8))) (with-open-file (s pn :direction :output :element-type element-type :if-exists :supersede) (dolist (b '(1 5 9 13)) (write-byte b s))) (with-open-file (s1 pn :direction :input :element-type element-type) (with-open-file (s2 pn :direction :input :element-type element-type) (let ((s (make-concatenated-stream s1 s2)) (x (vector nil nil nil nil nil nil nil nil))) (values (read-sequence x s) x))))) 8 #(1 5 9 13 1 5 9 13)) (deftest make-concatenated-stream.23 (let ((pn #p"tmp.dat") (element-type '(unsigned-byte 8))) (with-open-file (s pn :direction :output :element-type element-type :if-exists :supersede) (dolist (b '(1 5 9 13)) (write-byte b s))) (with-open-file (s1 pn :direction :input :element-type element-type) (with-open-file (s2 pn :direction :input :element-type element-type) (let ((s (make-concatenated-stream s1 s2)) (x (vector nil nil nil nil nil nil))) (values (read-sequence x s) x))))) 6 #(1 5 9 13 1 5)) (deftest make-concatenated-stream.24 (let ((pn #p"tmp.dat") (element-type '(unsigned-byte 8))) (with-open-file (s pn :direction :output :element-type element-type :if-exists :supersede) (dolist (b '(1 5 9 13)) (write-byte b s))) (with-open-file (s1 pn :direction :input :element-type element-type) (with-open-file (s2 pn :direction :input :element-type element-type) (let ((s (make-concatenated-stream s1 s2)) (x (vector nil nil nil nil nil nil nil nil nil nil))) (values (read-sequence x s) x))))) 8 #(1 5 9 13 1 5 9 13 nil nil)) (deftest make-concatenated-stream.25 (close (make-concatenated-stream)) t) (deftest make-concatenated-stream.26 (let ((s (make-concatenated-stream))) (values (prog1 (close s) (close s)) (open-stream-p s))) t nil) (deftest make-concatenated-stream.27 (with-input-from-string (s1 "abc") (let ((s (make-concatenated-stream s1))) (values (notnot (open-stream-p s1)) (notnot (open-stream-p s)) (close s) (notnot (open-stream-p s1)) (open-stream-p s)))) t t t t nil) (deftest make-concatenated-stream.28 (with-input-from-string (s1 "a") (let ((s (make-concatenated-stream s1))) (notnot-mv (listen s)))) t) (deftest make-concatenated-stream.28a (listen (make-concatenated-stream)) nil) (deftest make-concatenated-stream.29 (with-input-from-string (s1 "") (let ((s (make-concatenated-stream s1))) (listen s))) nil) (deftest make-concatenated-stream.30 (with-input-from-string (s1 "") (with-input-from-string (s2 "a") (let ((s (make-concatenated-stream s1 s2))) (notnot-mv (listen s))))) t) (deftest make-concatenated-stream.31 (with-input-from-string (s1 "") (with-input-from-string (s2 "") (let ((s (make-concatenated-stream s1 s2))) (listen s)))) nil) (deftest make-concatenated-stream.32 (clear-input (make-concatenated-stream)) nil) (deftest make-concatenated-stream.33 (with-input-from-string (s1 "abc") (clear-input (make-concatenated-stream s1))) nil) ;;; Error cases (deftest make-concatenated-stream.error.1 (loop for x in *mini-universe* unless (or (and (streamp x) (input-stream-p x)) (eval `(signals-error (make-concatenated-stream ',x) t))) collect x) nil) (deftest make-concatenated-stream.error.2 (loop for x in *streams* unless (or (and (streamp x) (input-stream-p x)) (eval `(signals-error (make-concatenated-stream ',x) t))) collect x) nil) gcl27-2.7.0/ansi-tests/make-condition.lsp000066400000000000000000000024571454061450500201650ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jun 23 11:54:10 2005 ;;;; Contains: Tests of MAKE-CONDITION (in-package :cl-test) (deftest make-condition.1 (loop for tp in *cl-condition-type-symbols* for c = (make-condition tp) unless (and (typep c tp) (typep c 'condition)) collect (list tp c)) nil) (deftest make-condition.2 (loop for tp in *cl-condition-type-symbols* for class = (find-class tp) for c = (and class (make-condition class)) unless (or (not class) (and (typep c tp) (typep c class) (typep c 'condition))) collect (list tp c)) nil) (deftest make-condition.3 :notes (:make-condition-with-compound-name :ansi-spec-problem) (let* ((tp '(or program-error type-error)) (c (make-condition tp))) (or (not (and (subtypep tp 'condition) (or (subtypep 'program-error tp) (subtypep 'type-error tp)))) (notnot-mv (typep c tp)))) t) (deftest make-condition.4 :notes (:make-condition-with-compound-name :ansi-spec-problem) (let* ((tp '(and simple-error type-error)) (c (make-condition tp))) (or (not (and (subtypep 'simple-error tp) (subtypep 'type-error tp) (subtypep tp 'condition))) (notnot-mv (typep c tp)))) t) ;;; Error tests (deftest make-condition.error.1 (signals-error (make-condition) program-error) t) gcl27-2.7.0/ansi-tests/make-echo-stream.lsp000066400000000000000000000217501454061450500204030ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Feb 12 04:34:42 2004 ;;;; Contains: Tests of MAKE-ECHO-STREAM (in-package :cl-test) (deftest make-echo-stream.1 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (values (read-char s) (get-output-stream-string os))) #\f "f") (deftest make-echo-stream.2 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (get-output-stream-string os)) "") (deftest make-echo-stream.3 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (values (read-line s nil) (get-output-stream-string os))) "foo" "foo") ;;; Tests of READ-BYTE on echo streams (deftest make-echo-stream.4 (let ((pn #p"tmp.dat") (pn2 #p"tmp2.dat") (element-type '(unsigned-byte 8))) (with-open-file (os pn :direction :output :element-type element-type :if-exists :supersede) (loop for x in '(2 3 5 7 11) do (write-byte x os))) (with-open-file (is pn :direction :input :element-type element-type) (values (with-open-file (os pn2 :direction :output :if-exists :supersede :element-type element-type) (let ((s (make-echo-stream is os))) (loop repeat 6 collect (read-byte s nil :eof1)))) (with-open-file (s pn2 :direction :input :element-type element-type) (loop repeat 6 collect (read-byte s nil :eof2)))))) (2 3 5 7 11 :eof1) (2 3 5 7 11 :eof2)) (deftest make-echo-stream.5 (let ((pn #p"tmp.dat") (pn2 #p"tmp2.dat") (element-type '(unsigned-byte 8))) (with-open-file (os pn :direction :output :element-type element-type :if-exists :supersede) (loop for x in '(2 3 5 7 11) do (write-byte x os))) (with-open-file (is pn :direction :input :element-type element-type) (values (with-open-file (os pn2 :direction :output :if-exists :supersede :element-type element-type) (let ((s (make-echo-stream is os))) (loop repeat 6 collect (read-byte s nil 100)))) (with-open-file (s pn2 :direction :input :element-type element-type) (loop repeat 6 collect (read-byte s nil 200)))))) (2 3 5 7 11 100) (2 3 5 7 11 200)) (deftest make-echo-stream.6 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (values (coerce (loop repeat 3 collect (read-char-no-hang s)) 'string) (get-output-stream-string os))) "foo" "foo") (deftest make-echo-stream.7 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (values (coerce (loop repeat 4 collect (read-char-no-hang s nil '#\z)) 'string) (get-output-stream-string os))) "fooz" "foo") ;;; peek-char + echo streams is tested in peek-char.lsp ;;; unread-char + echo streams is tested in unread-char.lsp (deftest make-echo-stream.8 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os)) (x (copy-seq "xxxxxx"))) (values (read-sequence x s) x (get-output-stream-string os))) 3 "fooxxx" "foo") (deftest make-echo-stream.9 (let ((pn #p"tmp.dat") (pn2 #p"tmp2.dat") (element-type '(unsigned-byte 8))) (with-open-file (os pn :direction :output :element-type element-type :if-exists :supersede) (loop for x in '(2 3 5 7 11) do (write-byte x os))) (with-open-file (is pn :direction :input :element-type element-type) (values (with-open-file (os pn2 :direction :output :if-exists :supersede :element-type element-type) (let ((s (make-echo-stream is os)) (x (vector 0 0 0 0 0 0 0 0))) (list (read-sequence x s) x))) (with-open-file (s pn2 :direction :input :element-type element-type) (loop repeat 8 collect (read-byte s nil nil)))))) (5 #(2 3 5 7 11 0 0 0)) (2 3 5 7 11 nil nil nil)) (deftest make-echo-stream.10 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (values (notnot (open-stream-p s)) (close s) (open-stream-p s) (notnot (open-stream-p is)) (notnot (open-stream-p os)))) t t nil t t) (deftest make-echo-stream.11 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (values (notnot (listen s)) (read-char s) (notnot (listen s)) (read-char s) (notnot (listen s)) (read-char s) (listen s))) t #\f t #\o t #\o nil) (deftest make-echo-stream.12 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (values (notnot (streamp s)) (notnot (typep s 'stream)) (notnot (typep s 'echo-stream)) (notnot (input-stream-p s)) (notnot (output-stream-p s)) (notnot (stream-element-type s)))) t t t t t t) ;;; FIXME ;;; Add tests for clear-input, file-position(?) ;;; Also, add tests for output operations (since echo-streams are ;;; bidirectional) (deftest make-echo-stream.13 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (values (write-char #\0 s) (close s) (get-output-stream-string os))) #\0 t "0") (deftest make-echo-stream.14 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (values (terpri s) (close s) (get-output-stream-string os))) nil t #.(string #\Newline)) (deftest make-echo-stream.15 (let ((pn #p"tmp.dat") (pn2 #p"tmp2.dat") (element-type '(unsigned-byte 8))) (with-open-file (os pn :direction :output :element-type element-type :if-exists :supersede)) (with-open-file (is pn :direction :input :element-type element-type) (values (with-open-file (os pn2 :direction :output :if-exists :supersede :element-type element-type) (let ((s (make-echo-stream is os)) (x (mapcar #'char-code (coerce "abcdefg" 'list)))) (loop for b in x do (assert (equal (list b) (multiple-value-list (write-byte b s))))) (close s))))) (with-open-file (is pn2 :direction :input :element-type element-type) (let ((x (vector 0 0 0 0 0 0 0))) (read-sequence x is) (values (read-byte is nil :done) (map 'string #'code-char x))))) :done "abcdefg") (deftest make-echo-stream.16 (let ((pn #p"tmp.dat") (pn2 #p"tmp2.dat") (element-type '(unsigned-byte 8))) (with-open-file (os pn :direction :output :element-type element-type :if-exists :supersede)) (with-open-file (is pn :direction :input :element-type element-type) (values (with-open-file (os pn2 :direction :output :if-exists :supersede :element-type element-type) (let ((s (make-echo-stream is os)) (x (map 'vector #'char-code "abcdefg"))) (assert (equal (multiple-value-list (write-sequence x s)) (list x))) (close s))))) (with-open-file (is pn2 :direction :input :element-type element-type) (let ((x (vector 0 0 0 0 0 0 0))) (read-sequence x is) (values (read-byte is nil :done) (map 'string #'code-char x))))) :done "abcdefg") (deftest make-echo-stream.17 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (values (write-char #\X s) (notnot (fresh-line s)) (finish-output s) (force-output s) (close s) (get-output-stream-string os))) #\X t nil nil t #.(coerce '(#\X #\Newline) 'string)) (deftest make-echo-stream.18 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (values (write-string "159" s) (close s) (get-output-stream-string os))) "159" t "159") (deftest make-echo-stream.20 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (values (write-string "0159X" s :start 1 :end 4) (close s) (get-output-stream-string os))) "0159X" t "159") (deftest make-echo-stream.21 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (values (write-line "159" s) (close s) (get-output-stream-string os))) "159" t #.(concatenate 'string "159" (string #\Newline))) (deftest make-echo-stream.22 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (values (write-char #\0 s) (clear-output s))) #\0 nil) ;;; Error tests (deftest make-echo-stream.error.1 (signals-error (make-echo-stream) program-error) t) (deftest make-echo-stream.error.2 (signals-error (make-echo-stream *standard-input*) program-error) t) (deftest make-echo-stream.error.3 (signals-error (make-echo-stream *standard-input* *standard-output* nil) program-error) t) gcl27-2.7.0/ansi-tests/make-hash-table.lsp000066400000000000000000000137461454061450500202120ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 21:36:33 2003 ;;;; Contains: Tests for MAKE-HASH-TABLE (in-package :cl-test) ;; (eval-when (:load-toplevel :compile-toplevel :execute) ;; (compile-and-load "hash-table-aux.lsp")) (deftest make-hash-table.1 (let ((ht (make-hash-table))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.2 (let ((ht (make-hash-table :size 0))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.3 (let ((ht (make-hash-table :size 100))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.4 (let ((ht (make-hash-table :test #'eq))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.5 (let ((ht (make-hash-table :test 'eq))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.6 (let ((ht (make-hash-table :test #'eql))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.7 (let ((ht (make-hash-table :test 'eql))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.8 (let ((ht (make-hash-table :test #'equal))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.9 (let ((ht (make-hash-table :test 'equal))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.10 (let ((ht (make-hash-table :test #'equalp))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.11 (let ((ht (make-hash-table :test 'equalp))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.12 (let ((ht (make-hash-table :rehash-size 1))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.13 (let ((ht (make-hash-table :rehash-size 1000))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.14 (let ((ht (make-hash-table :rehash-size (+ 1.0f0 single-float-epsilon)))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.15 (let ((ht (make-hash-table :rehash-size 2.0))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.16 (let ((ht (make-hash-table :rehash-threshold 0))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.17 (let ((ht (make-hash-table :rehash-threshold 0.0s0))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.18 (let ((ht (make-hash-table :rehash-threshold 0.0f0))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.19 (let ((ht (make-hash-table :rehash-threshold 0.0d0))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.20 (let ((ht (make-hash-table :rehash-threshold 0.0l0))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.21 (let ((ht (make-hash-table :rehash-threshold 1/2))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.22 (let ((ht (make-hash-table :rehash-threshold 0.1s0))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.23 (let ((ht (make-hash-table :rehash-threshold 0.2f0))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.24 (let ((ht (make-hash-table :rehash-threshold 0.8d0))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.25 (let ((ht (make-hash-table :rehash-threshold 0.99f0))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.26 (let ((ht (make-hash-table :rehash-threshold least-positive-short-float))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.27 (let ((ht (make-hash-table :rehash-threshold least-positive-single-float))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.28 (let ((ht (make-hash-table :rehash-threshold least-positive-double-float))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.29 (let ((ht (make-hash-table :rehash-threshold least-positive-long-float))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) gcl27-2.7.0/ansi-tests/make-instance.lsp000066400000000000000000000143131454061450500177750ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon May 12 21:19:36 2003 ;;;; Contains: Tests of MAKE-INSTANCE (in-package :cl-test) ;;; MAKE-INSTANCE is used in many other tests as well (deftest make-instance.error.1 (signals-error (make-instance) program-error) t) (defclass make-instance-class-01 () ((a :initarg :a) (b :initarg :b))) (deftest make-instance.error.2 (signals-error (make-instance 'make-instance-class-01 :a) program-error) t) (deftest make-instance.error.3 (handler-case (progn (eval '(make-instance 'make-instance-class-01 :z 1)) t) (error () :good)) :good) (deftest make-instance.error.4 (handler-case (progn (eval '(make-instance (find-class 'make-instance-class-01) :z 1)) t) (error () :good)) :good) (deftest make-instance.error.5 (signals-error (let () (make-instance) nil) program-error) t) (deftest make-instance.error.6 (loop for cl in *built-in-classes* unless (eval `(signals-error (make-instance ',cl) error)) collect cl) nil) ;; Definitions of methods (defmethod make-instance ((x make-instance-class-01) &rest initargs &key &allow-other-keys) initargs) (deftest make-instance.1 (make-instance (make-instance 'make-instance-class-01)) nil) (deftest make-instance.2 (make-instance (make-instance 'make-instance-class-01) :a 1 :b 2) (:a 1 :b 2)) #| (when *can-define-metaclasses* (defclass make-instance-class-02 () (a b c) (:metaclass substandard-class)) (defmethod make-instance ((class (eql (find-class 'make-instance-class-02))) &rest initargs &key (x nil) (y nil) (z nil) &allow-other-keys) (declare (ignore initargs)) (let ((obj (allocate-instance class))) (setf (slot-value obj 'a) x (slot-value obj 'b) y (slot-value obj 'c) z) obj)) (deftest make-instance.3 (let ((obj (make-instance 'make-instance-class-02))) (values (eqt (class-of obj) (find-class 'make-instance-class-02)) (slot-value obj 'a) (slot-value obj 'b) (slot-value obj 'c))) t nil nil nil) (deftest make-instance.4 (let ((obj (make-instance 'make-instance-class-02 :z 10 :y 45 :x 'd))) (values (eqt (class-of obj) (find-class 'make-instance-class-02)) (slot-value obj 'a) (slot-value obj 'b) (slot-value obj 'c))) t d 45 10) (deftest make-instance.5 (let ((obj (make-instance (find-class 'make-instance-class-02) :y 'g))) (values (eqt (class-of obj) (find-class 'make-instance-class-02)) (slot-value obj 'a) (slot-value obj 'b) (slot-value obj 'c))) t nil g nil) (deftest make-instance.6 (eq (make-instance 'make-instance-class-02) (make-instance 'make-instance-class-02)) nil) ;; Customization of make-instance (defclass make-instance-class-03 () ((a :initform 1) (b :initarg :b) c) (:metaclass substandard-class)) (defmethod make-instance ((class (eql (find-class 'make-instance-class-03))) &rest initargs &key (x nil x-p) (y nil y-p) (z nil z-p) &allow-other-keys) (declare (ignore initargs)) (let ((obj (allocate-instance (find-class 'make-instance-class-03)))) (when x-p (setf (slot-value obj 'a) x)) (when y-p (setf (slot-value obj 'b) y)) (when z-p (setf (slot-value obj 'c) z)) obj)) (deftest make-instance.7 (let ((obj (make-instance 'make-instance-class-03))) (values (eqt (class-of obj) (find-class 'make-instance-class-03)) (map-slot-boundp* obj '(a b c)))) t (nil nil nil)) (deftest make-instance.8 (let* ((class (find-class 'make-instance-class-03)) (obj (make-instance class :b 10))) (values (eqt (class-of obj) class) (map-slot-boundp* obj '(a b c)))) t (nil nil nil)) (deftest make-instance.9 (let* ((class (find-class 'make-instance-class-03)) (obj (make-instance class :x 'g :z 'i :y 'k :foo t :x 'bad))) (values (eqt (class-of obj) class) (map-slot-boundp* obj '(a b c)) (map-slot-value obj '(a b c)))) t (t t t) (g k i)) ;; After method combination (defparameter *make-instance-class-04-var* 0) (defclass make-instance-class-04 () ((a :initform *make-instance-class-04-var*)) (:metaclass substandard-class)) (defmethod make-instance :after ((class (eql (find-class 'make-instance-class-04))) &rest initargs &key &allow-other-keys) (declare (ignore initargs)) (incf *make-instance-class-04-var* 10)) (deftest make-instance.10 (let* ((*make-instance-class-04-var* 0) (obj (make-instance 'make-instance-class-04))) (values (slot-value obj 'a) *make-instance-class-04-var*)) 0 10) ;; Around method combination (defclass make-instance-class-05 () ((a :initarg :a) (b :initarg :b :initform 'foo) c) (:metaclass substandard-class)) (defmethod make-instance :around ((class (eql (find-class 'make-instance-class-05))) &rest initargs &key &allow-other-keys) (declare (ignore initargs)) (let ((obj (call-next-method))) (setf (slot-value obj 'c) 'bar) obj)) (deftest make-instance.11 (let ((obj (make-instance 'make-instance-class-05))) (values (map-slot-boundp* obj '(a b c)) (map-slot-value obj '(b c)))) (nil t t) (foo bar)) ) |# ;;; Order of argument evaluation (deftest make-instance.order.1 (let* ((i 0) x y (obj (make-instance 'make-instance-class-01 :a (setf x (incf i)) :b (setf y (incf i))))) (values (map-slot-value obj '(a b)) i x y)) (1 2) 2 1 2) (deftest make-instance.order.2 (let* ((i 0) x y z w (obj (make-instance 'make-instance-class-01 :a (setf x (incf i)) :b (setf y (incf i)) :b (setf z (incf i)) :a (setf w (incf i))))) (values (map-slot-value obj '(a b)) i x y z w)) (1 2) 4 1 2 3 4) (deftest make-instance.order.3 (let* ((i 0) u x y z w (obj (make-instance (prog1 'make-instance-class-01 (setf u (incf i))) :a (setf x (incf i)) :b (setf y (incf i)) :b (setf z (incf i)) :a (setf w (incf i))))) (values (map-slot-value obj '(a b)) i u x y z w)) (2 3) 5 1 2 3 4 5) gcl27-2.7.0/ansi-tests/make-instances-obsolete.lsp000066400000000000000000000030171454061450500217710ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 17 08:12:35 2003 ;;;; Contains: Tests of MAKE-INSTANCES-OBSOLETE (in-package :cl-test) (defclass make-instances-obsolete-class-01 () ((a :initarg :a) (b :initarg :b :allocation :class) (c :initarg :c :initform 'abc) (d :initarg :d :type fixnum :initform 0))) (deftest make-instances-obsolete.1 (let* ((class-designator 'make-instances-obsolete-class-01) (class (find-class class-designator)) (obj (make-instance class :a 'x :b 'y :c 'z :d 17))) (values (eqt (class-of obj) class) (map-slot-value obj '(a b c d)) (let ((val (make-instances-obsolete class))) (or (eqt val class-designator) (eqt val class))) (map-slot-value obj '(a b c d)))) t (x y z 17) t (x y z 17)) (deftest make-instances-obsolete.2 (let* ((class-designator 'make-instances-obsolete-class-01) (class (find-class class-designator)) (obj (make-instance class :a 'x :b 'y :c 'z :d 17))) (values (eqt (class-of obj) class) (map-slot-value obj '(a b c d)) (let ((val (make-instances-obsolete class-designator))) (or (eqt val class-designator) (eqt val class))) (map-slot-value obj '(a b c d)))) t (x y z 17) t (x y z 17)) ;;; Error cases (deftest make-instances-obsolete.error.1 (signals-error (make-instances-obsolete) program-error) t) (deftest make-instances-obsolete.error.2 (signals-error (make-instances-obsolete (find-class 'make-instances-obsolete-class-01) nil) program-error) t) gcl27-2.7.0/ansi-tests/make-list.lsp000066400000000000000000000044441454061450500171500ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:04:27 2003 ;;;; Contains: Tests of MAKE-LIST (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) (def-fold-test make-list.fold.1 (make-list 1)) (def-fold-test make-list.fold.2 (make-list 10 :initial-element 'x)) ;;; Error tests (deftest make-list.error.1 (check-type-error #'make-list (typef 'unsigned-byte)) nil) (deftest make-list.error.3 (signals-error (make-list) program-error) t) (deftest make-list.error.4 (signals-error (make-list 5 :bad t) program-error) t) (deftest make-list.error.5 (signals-error (make-list 5 :initial-element) program-error) t) (deftest make-list.error.6 (signals-error (make-list 5 1 2) program-error) t) (deftest make-list.error.7 (signals-error (make-list 5 :bad t :allow-other-keys nil) program-error) t) (deftest make-list.error.8 (signals-error (locally (make-list 'a) t) type-error) t) gcl27-2.7.0/ansi-tests/make-load-form-saving-slots.lsp000066400000000000000000000136111454061450500225000ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 17 11:54:54 2003 ;;;; Contains: Tests of MAKE-LOAD-FORM-SAVING-SLOTS (in-package :cl-test) ;;; These are tests of MAKE-LOAD-FORM-SAVING-SLOTS proper; tests involving ;;; file compilation will be located elsewhere. (defstruct mlfss-01 a b c) (deftest make-load-form-saving-slots.1 (let* ((obj (make-mlfss-01)) (forms (multiple-value-list (make-load-form-saving-slots obj)))) (values (length forms) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (eqt (class-of obj) (class-of newobj))))) 2 t) (deftest make-load-form-saving-slots.2 (let* ((obj (make-mlfss-01)) (forms (multiple-value-list (make-load-form-saving-slots obj :slot-names '(a b))))) (values (length forms) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (eqt (class-of obj) (class-of newobj))))) 2 t) (defclass mlfss-02 () ((a :initarg :a) (b :initarg :b) (c :initarg :c))) (deftest make-load-form-saving-slots.3 (let* ((obj (make-instance 'mlfss-02)) (forms (multiple-value-list (make-load-form-saving-slots obj)))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values (length forms) (eqt (class-of obj) (class-of newobj)) (map-slot-boundp* newobj '(a b c))))) 2 t (nil nil nil)) (deftest make-load-form-saving-slots.4 (let* ((obj (make-instance 'mlfss-02 :a 1 :b 'a :c '(x y z))) (forms (multiple-value-list (make-load-form-saving-slots obj :slot-names '(a b c))))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values (length forms) (eqt (class-of obj) (class-of newobj)) (map-slot-boundp* newobj '(a b c)) (map-slot-value newobj '(a b c))))) 2 t (t t t) (1 a (x y z))) (deftest make-load-form-saving-slots.5 (let* ((obj (make-instance 'mlfss-02 :a #(x y z))) (forms (multiple-value-list (make-load-form-saving-slots obj :slot-names '(a b))))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values (length forms) (eqt (class-of obj) (class-of newobj)) (map-slot-boundp* newobj '(a b c)) (slot-value newobj 'a)))) 2 t (t nil nil) #(x y z)) (deftest make-load-form-saving-slots.6 (let* ((obj (make-instance 'mlfss-02)) (forms (multiple-value-list (make-load-form-saving-slots obj :allow-other-keys nil)))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values (length forms) (eqt (class-of obj) (class-of newobj)) (map-slot-boundp* newobj '(a b c))))) 2 t (nil nil nil)) ;;; If :slot-names is missing, all initialized slots are retained (deftest make-load-form-saving-slots.7 (let* ((obj (make-instance 'mlfss-02 :a (list 'x) :c 6/5)) (forms (multiple-value-list (make-load-form-saving-slots obj)))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values (length forms) (eqt (class-of obj) (class-of newobj)) (map-slot-boundp* newobj '(a b c)) (map-slot-value newobj '(a c))))) 2 t (t nil t) ((x) 6/5)) ;;; If :slot-names is present, all initialized slots in the list are retained (deftest make-load-form-saving-slots.8 (let* ((obj (make-instance 'mlfss-02 :a (list 'x) :c 6/5)) (forms (multiple-value-list (make-load-form-saving-slots obj :slot-names '(c))))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values (length forms) (eqt (class-of obj) (class-of newobj)) (map-slot-boundp* newobj '(a b c)) (slot-value newobj 'c)))) 2 t (nil nil t) 6/5) ;; It takes an :environment parameter (deftest make-load-form-saving-slots.9 (let* ((obj (make-instance 'mlfss-02 :a 7 :c 64 :b 100)) (forms (multiple-value-list (make-load-form-saving-slots obj :environment nil)))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values (length forms) (eqt (class-of obj) (class-of newobj)) (map-slot-boundp* newobj '(a b c)) (map-slot-value newobj '(a b c))))) 2 t (t t t) (7 100 64)) (defpackage "CL-TEST-MLFSS-PACKAGE" (:use) (:export #:a)) (defstruct mlfss-03 cl-test-mlfss-package:a) (deftest make-load-form-savings-slots.10 (let* ((obj (make-mlfss-03 :a 17)) (forms (multiple-value-list (make-load-form-saving-slots obj)))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values (mlfss-03-a obj) (length forms) (eqt (class-of obj) (class-of newobj)) (mlfss-03-a newobj)))) 17 2 t 17) (deftest make-load-form-savings-slots.11 (let* ((obj (make-mlfss-03 :a 17)) (forms (multiple-value-list (make-load-form-saving-slots obj :slot-names '(cl-test-mlfss-package:a))))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values (mlfss-03-a obj) (length forms) (eqt (class-of obj) (class-of newobj)) (mlfss-03-a newobj)))) 17 2 t 17) (defstruct mlfss-04 (a 0 :read-only t)) (deftest make-load-form-savings-slots.12 (let* ((obj (make-mlfss-04 :a 123)) (forms (multiple-value-list (make-load-form-saving-slots obj)))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values (mlfss-04-a obj) (length forms) (eqt (class-of obj) (class-of newobj)) (mlfss-04-a newobj)))) 123 2 t 123) ;;; General error tests (deftest make-load-form-saving-slots.error.1 (signals-error (make-load-form-saving-slots) program-error) t) (deftest make-load-form-saving-slots.error.2 (signals-error (make-load-form-saving-slots (make-instance 'mlfss-02) :slot-names) program-error) t) (deftest make-load-form-saving-slots.error.3 (signals-error (make-load-form-saving-slots (make-instance 'mlfss-02) (gensym) t) program-error) t) gcl27-2.7.0/ansi-tests/make-load-form.lsp000066400000000000000000000140741454061450500200550ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 17 09:16:20 2003 ;;;; Contains: Tests of MAKE-LOAD-FORM (in-package :cl-test) ;;; These tests are just of MAKE-LOAD-FORM itself; tests of file compilation ;;; that depend on MAKE-LOAD-FORM will be found elsewhere. (defclass make-load-form-class-01 () (a b c)) (deftest make-load-form.1 (let* ((fun #'make-load-form) (obj (make-instance 'make-load-form-class-01))) (if (eql (or (find-method fun nil '(standard-object) nil) (find-method fun nil (list (find-class t)) nil) :none) (car (compute-applicable-methods fun (list obj)))) ;; The default method applies (handler-case (progn (make-load-form obj) :bad) (error () :good)) :good)) :good) (defstruct make-load-form-struct-02 a b c) (deftest make-load-form.2 (let* ((fun #'make-load-form) (obj (make-make-load-form-struct-02))) (if (eql (or (find-method fun nil '(structure-object) nil) (find-method fun nil (list (find-class t)) nil) :none) (car (compute-applicable-methods fun (list obj)))) ;; The default method applies (handler-case (progn (make-load-form obj) :bad) (error () :good)) :good)) :good) (define-condition make-load-form-condition-03 () ((a) (b) (c))) (deftest make-load-form.3 (let* ((fun #'make-load-form) (obj (make-condition 'make-load-form-condition-03))) (if (eql (or (find-method fun nil '(condition) nil) (find-method fun nil (list (find-class t)) nil) :none) (car (compute-applicable-methods fun (list obj)))) ;; The default method applies (handler-case (progn (make-load-form obj :bad)) (error () :good)) :good)) :good) ;;; Make sure these errors are due to the method, not due to lack of ;;; methods (deftest make-load-form.4 (let* ((obj (make-instance 'make-load-form-class-01)) (fun #'make-load-form) (methods (compute-applicable-methods fun (list obj)))) (notnot-mv methods)) t) (deftest make-load-form.5 (let* ((obj (make-make-load-form-struct-02)) (fun #'make-load-form) (methods (compute-applicable-methods fun (list obj)))) (notnot-mv methods)) t) (deftest make-load-form.6 (let* ((obj (make-condition 'make-load-form-condition-03)) (fun #'make-load-form) (methods (compute-applicable-methods fun (list obj)))) (notnot-mv methods)) t) (deftest make-load-form.7 (let* ((obj (make-instance 'make-load-form-class-01)) (fun #'make-load-form) (methods (compute-applicable-methods fun (list obj nil)))) (notnot-mv methods)) t) (deftest make-load-form.8 (let* ((obj (make-make-load-form-struct-02)) (fun #'make-load-form) (methods (compute-applicable-methods fun (list obj nil)))) (notnot-mv methods)) t) (deftest make-load-form.9 (let* ((obj (make-condition 'make-load-form-condition-03)) (fun #'make-load-form) (methods (compute-applicable-methods fun (list obj nil)))) (notnot-mv methods)) t) (deftest make-load-form.10 (macrolet ((%m (&environment env) (let* ((obj (make-instance 'make-load-form-class-01)) (fun #'make-load-form) (methods (compute-applicable-methods fun (list obj env)))) (notnot-mv methods)))) (%m)) t) (deftest make-load-form.11 (macrolet ((%m (&environment env) (let* ((obj (make-make-load-form-struct-02)) (fun #'make-load-form) (methods (compute-applicable-methods fun (list obj env)))) (notnot-mv methods)))) (%m)) t) (deftest make-load-form.12 (macrolet ((%m (&environment env) (let* ((obj (make-condition 'make-load-form-condition-03)) (fun #'make-load-form) (methods (compute-applicable-methods fun (list obj env)))) (notnot-mv methods)))) (%m)) t) ;;; User-defined methods (defclass make-load-form-class-04 () ((a :initarg :a) (b :initarg :b) (c :initarg :c))) (defmethod make-load-form ((obj make-load-form-class-04) &optional (env t)) (declare (ignore env)) (let ((newobj (gensym))) `(let ((,newobj (allocate-instance (find-class 'make-load-form-class-04)))) ,@(loop for slot-name in '(a b c) when (slot-boundp obj slot-name) collect `(setf (slot-value ,newobj ',slot-name) ',(slot-value obj slot-name))) ,newobj))) (deftest make-load-form.13 (let* ((obj (make-instance 'make-load-form-class-04)) (obj2 (eval (make-load-form obj)))) (values (eqt (class-of obj2) (class-of obj)) (map-slot-boundp* obj2 '(a b c)))) t (nil nil nil)) (deftest make-load-form.14 (let* ((obj (make-instance 'make-load-form-class-04 :a 1 :b '(a b c) :c 'a)) (obj2 (eval (make-load-form obj)))) (values (eqt (class-of obj2) (class-of obj)) (map-slot-boundp* obj2 '(a b c)) (map-slot-value obj2 '(a b c)))) t (t t t) (1 (a b c) a)) (deftest make-load-form.15 (let* ((obj (make-instance 'make-load-form-class-04 :b '(a b c) :c 'a)) (obj2 (eval (make-load-form obj nil)))) (values (eqt (class-of obj2) (class-of obj)) (map-slot-boundp* obj2 '(a b c)) (map-slot-value obj2 '(b c)))) t (nil t t) ((a b c) a)) #| (defclass make-load-form-class-05a () ((a :initarg :a))) (defclass make-load-form-class-05b (make-load-form-class-05a) ((b :initarg :b))) (defmethod make-load-form ((obj make-load-form-class-05a) &optional (env t)) (declare (ignore env)) (let ((newobj (gensym))) `(let ((,newobj (allocate-instance (find-class 'make-load-form-class-04)))) ,@(when (slot-boundp obj 'a) `((setf (slot-value ,newobj 'a) ',(slot-value obj 'a)))) ,newobj))) (defmethod make-load-form :around ((obj make-load-form-class-05b) &optional (env t)) (declare (ignore env)) (let ((newobj (gensym))) `(let ((,newobj (allocate-instance (find-class 'make-load-form-class-04)))) ,@(when (slot-boundp obj 'a) `((setf (slot-value ,newobj 'a) ',(slot-value obj 'a)))) ,newobj))) |# ;;; Other error tests (deftest make-load-form.error.1 (signals-error (make-load-form) program-error) t) (deftest make-load-form.error.2 (signals-error (let ((obj (make-instance 'make-load-form-class-04 :b '(a b c) :c 'a))) (make-load-form obj nil nil)) program-error) t) gcl27-2.7.0/ansi-tests/make-package.lsp000066400000000000000000000350731454061450500175720ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:02:43 1998 ;;;; Contains: Tests of MAKE-PACKAGE (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 (set-up-packages) (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 (set-up-packages) (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 (set-up-packages) (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 (set-up-packages) (safely-delete-package '#:|TEST1|) (let ((p (ignore-errors (make-package '#:|TEST1| :use '("A"))))) (multiple-value-prog1 (values (notnot (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 t t t t) (deftest make-package.8a (progn (set-up-packages) (safely-delete-package '#:|TEST1|) (let ((p (ignore-errors (make-package '#:|TEST1| :use '(#:|A|))))) (multiple-value-prog1 (values (notnot (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 t t t t) (deftest make-package.8b (progn (set-up-packages) (safely-delete-package '#:|TEST1|) (let ((p (ignore-errors (make-package '#:|TEST1| :use '(#\A))))) (multiple-value-prog1 (values (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 t t t t) (deftest make-package.9 (progn (set-up-packages) (safely-delete-package #\X) (let ((p (ignore-errors (make-package #\X :use '("A"))))) (multiple-value-prog1 (values (notnot (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 t t t t) (deftest make-package.9a (progn (set-up-packages) (safely-delete-package #\X) (let ((p (ignore-errors (make-package #\X :use '(#:|A|))))) (multiple-value-prog1 (values (notnot (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 t t t t) (deftest make-package.9b (progn (set-up-packages) (safely-delete-package #\X) (let ((p (ignore-errors (make-package #\X :use '(#\A))))) (multiple-value-prog1 (values (notnot (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 t t t t) ;; make-package with nicknames (deftest make-package.10 (progn (mapc #'safely-delete-package '("TEST1" "F")) (let ((p (make-package "TEST1" :nicknames '("F")))) (multiple-value-prog1 (values (notnot (packagep p)) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) '("F")) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t t t t) (deftest make-package.11 (progn (mapc #'safely-delete-package '("TEST1" "G")) (let ((p (make-package '#:|TEST1| :nicknames '(#:|G|)))) (multiple-value-prog1 (values (notnot (packagep p)) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) '("G")) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t t t t) (deftest make-package.12 (progn (mapc #'safely-delete-package '("TEST1" "G")) (let ((p (make-package '#:|TEST1| :nicknames '(#\G)))) (multiple-value-prog1 (values (notnot (packagep p)) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) '("G")) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t t t t) (deftest make-package.13 (progn (mapc #'safely-delete-package '(#\X #\F #\G #\H)) (let ((p (make-package #\X :nicknames '("F" #\G #:|H|)))) (multiple-value-prog1 (values (notnot (packagep p)) (equalt (package-name p) "X") (set-exclusive-or (package-nicknames p) '("F" "G" "H") :test #'equal) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t t nil t) ;;; Specialized sequences as designators ;;; The package name being a specialized sequence (defmacro def-make-package-test1 (test-name name-form) `(deftest ,test-name (let ((name ,name-form)) (assert (string= name "TEST1")) (safely-delete-package "TEST1") (let ((p (ignore-errors (make-package name)))) (multiple-value-prog1 (values (notnot (packagep p)) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) nil) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t t t t)) (def-make-package-test1 make-package.14 (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) (def-make-package-test1 make-package.15 (make-array 12 :initial-contents "TEST1xxxyyyz" :fill-pointer 5 :element-type 'base-char)) (def-make-package-test1 make-package.16 (make-array 12 :initial-contents "TEST1xxxyyyz" :fill-pointer 5 :element-type 'character)) (def-make-package-test1 make-package.17 (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'base-char)) (def-make-package-test1 make-package.18 (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'character)) (def-make-package-test1 make-package.19 (let* ((etype 'base-char) (name0 (make-array 10 :initial-contents "xxTEST1yyy" :element-type etype))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 2))) (def-make-package-test1 make-package.20 (let* ((etype 'character) (name0 (make-array 10 :initial-contents "xxTEST1yyy" :element-type etype))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 2))) ;;; Nicknames being specialized sequences (defmacro def-make-package-test2 (test-name name-form) `(deftest ,test-name (let ((name ,name-form) (nickname "TEST1-NICKNAME")) (safely-delete-package "TEST1") (safely-delete-package nickname) (let ((p (make-package name :nicknames (list nickname)))) (multiple-value-prog1 (values (notnot (packagep p)) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) (list nickname)) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t t t t)) (def-make-package-test2 make-package.21 (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) (def-make-package-test2 make-package.22 (make-array 12 :initial-contents "TEST1xxxyyyz" :fill-pointer 5 :element-type 'base-char)) (def-make-package-test2 make-package.23 (make-array 12 :initial-contents "TEST1xxxyyyz" :fill-pointer 5 :element-type 'character)) (def-make-package-test2 make-package.24 (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'base-char)) (def-make-package-test2 make-package.25 (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'character)) (def-make-package-test2 make-package.26 (let* ((etype 'base-char) (name0 (make-array 10 :initial-contents "xxTEST1yyy" :element-type etype))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 2))) (def-make-package-test2 make-package.27 (let* ((etype 'character) (name0 (make-array 10 :initial-contents "xxTEST1yyy" :element-type etype))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 2))) ;;; USE names being specialized sequences (defmacro def-make-package-test3 (test-name name-form) `(deftest ,test-name (let ((name ,name-form)) (set-up-packages) (safely-delete-package "TEST1") (assert (find-package name)) (let ((p (ignore-errors (make-package "TEST1" :use (list name))))) (multiple-value-prog1 (values (notnot (packagep p)) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) nil) (equalt (package-use-list p) (list (find-package name))) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t t t t t)) (def-make-package-test3 make-package.28 (make-array 1 :initial-contents "A" :element-type 'base-char)) (def-make-package-test3 make-package.29 (make-array 8 :initial-contents "Axxxyyyz" :fill-pointer 1 :element-type 'base-char)) (def-make-package-test3 make-package.30 (make-array 8 :initial-contents "Axxxyyyz" :fill-pointer 1 :element-type 'character)) (def-make-package-test3 make-package.31 (make-array 1 :initial-contents "A" :adjustable t :element-type 'base-char)) (def-make-package-test3 make-package.32 (make-array 1 :initial-contents "A" :adjustable t :element-type 'character)) (def-make-package-test3 make-package.33 (let* ((etype 'base-char) (name0 (make-array 10 :initial-contents "xxAyyy0123" :element-type etype))) (make-array 1 :element-type etype :displaced-to name0 :displaced-index-offset 2))) (def-make-package-test3 make-package.34 (let* ((etype 'character) (name0 (make-array 10 :initial-contents "xxAzzzzyyy" :element-type etype))) (make-array 1 :element-type etype :displaced-to name0 :displaced-index-offset 2))) ;; Signal a continuable error if the package or any nicknames ;; exist as packages or nicknames of packages (deftest make-package.error.1 (progn (set-up-packages) (handle-non-abort-restart (make-package "A"))) success) (deftest make-package.error.2 (progn (set-up-packages) (handle-non-abort-restart (make-package "Q"))) success) (deftest make-package.error.3 (progn (set-up-packages) (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") (set-up-packages) (make-package "TEST1" :nicknames '("Q"))) success) (deftest make-package.error.5 (signals-error (make-package) program-error) t) (deftest make-package.error.6 (progn (safely-delete-package "MPE6") (signals-error (make-package "MPE6" :bad t) program-error)) t) (deftest make-package.error.7 (progn (safely-delete-package "MPE7") (signals-error (make-package "MPE7" :nicknames) program-error)) t) (deftest make-package.error.8 (progn (safely-delete-package "MPE8") (signals-error (make-package "MPE8" :use) program-error)) t) (deftest make-package.error.9 (progn (safely-delete-package "MPE9") (signals-error (make-package "MPE9" 'bad t) program-error)) t) (deftest make-package.error.10 (progn (safely-delete-package "MPE10") (signals-error (make-package "MPE10" 1 2) program-error)) t) (deftest make-package.error.11 (progn (safely-delete-package "MPE11") (signals-error (make-package "MPE11" 'bad t :allow-other-keys nil) program-error)) t) gcl27-2.7.0/ansi-tests/make-pathname.lsp000066400000000000000000000104231454061450500177640ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Nov 29 05:54:30 2003 ;;;; Contains: Tests of MAKE-PATHNAME (in-package :cl-test) (defvar *null-pathname* (make-pathname)) (defun make-pathname-test (&rest args &key (defaults nil) (host (if defaults (pathname-host defaults) (pathname-host *default-pathname-defaults*))) (device (if defaults (pathname-device defaults) (pathname-device *null-pathname*))) (directory (if defaults (pathname-directory defaults) (pathname-directory *null-pathname*))) (name (if defaults (pathname-name defaults) (pathname-name *null-pathname*))) (type (if defaults (pathname-type defaults) (pathname-type *null-pathname*))) (version (if defaults (pathname-version defaults) (pathname-version *null-pathname*))) case) (declare (ignorable case)) (let* ((vals (multiple-value-list (apply #'make-pathname args))) (pn (first vals))) (and (= (length vals) 1) (typep pn 'pathname) (equalp (pathname-host pn) host) (equalp (pathname-device pn) device) ;; (equalp (pathname-directory pn) directory) (let ((pnd (pathname-directory pn))) (if (eq directory :wild) (member pnd '((:absolute :wild-inferiors) (:absolute :wild)) :test #'equal) (equalp pnd directory))) (equalp (pathname-name pn) name) (equalp (pathname-type pn) type) (equalp (pathname-version pn) version) t))) (deftest make-pathname.1 (make-pathname-test) t) (deftest make-pathname.2 (make-pathname-test :name "foo") t) (deftest make-pathname.2a (do-special-strings (s "foo") (assert (make-pathname-test :name s))) nil) (deftest make-pathname.3 (make-pathname-test :name "foo" :type "txt") t) (deftest make-pathname.3a (do-special-strings (s "txt") (assert (make-pathname-test :name "foo" :type s))) nil) (deftest make-pathname.4 (make-pathname-test :type "lsp") t) (deftest make-pathname.5 (make-pathname-test :directory :wild) t) (deftest make-pathname.6 (make-pathname-test :name :wild) t) (deftest make-pathname.7 (make-pathname-test :type :wild) t) (deftest make-pathname.8 (make-pathname-test :version :wild) t) (deftest make-pathname.9 (make-pathname-test :defaults *default-pathname-defaults*) t) (deftest make-pathname.10 (make-pathname-test :defaults (make-pathname :name "foo" :type "bar")) t) (deftest make-pathname.11 (make-pathname-test :version :newest) t) (deftest make-pathname.12 (make-pathname-test :case :local) t) (deftest make-pathname.13 (make-pathname-test :case :common) t) (deftest make-pathname.14 (let ((*default-pathname-defaults* (make-pathname :name "foo" :type "lsp" :version :newest))) (make-pathname-test)) t) ;;; Works on the components of actual pathnames (deftest make-pathname.rebuild (loop for p in *pathnames* for host = (pathname-host p) for device = (pathname-device p) for directory = (pathname-directory p) for name = (pathname-name p) for type = (pathname-type p) for version = (pathname-version p) for p2 = (make-pathname :host host :device device :directory directory :name name :type type :version version) unless (equal p p2) collect (list p p2)) nil) ;;; Various constraints on :directory (deftest make-pathname-error-absolute-up (signals-error (directory (make-pathname :directory '(:absolute :up))) file-error) t) (deftest make-pathname-error-absolute-back (signals-error (directory (make-pathname :directory '(:absolute :back))) file-error) t) ;; The next test is correct, but was causing very large amounts of time to be spent ;; in buggy implementations (deftest make-pathname-error-absolute-wild-inferiors-up (signals-error (directory (make-pathname :directory '(:absolute :wild-inferiors :up))) file-error) t) (deftest make-pathname-error-relative-wild-inferiors-up (signals-error (length (directory (make-pathname :directory '(:relative :wild-inferiors :up)))) file-error) t) (deftest make-pathname-error-absolute-wild-inferiors-back (signals-error (directory (make-pathname :directory '(:absolute :wild-inferiors :back))) file-error) t) (deftest make-pathname-error-relative-wild-inferiors-back (signals-error (directory (make-pathname :directory '(:relative :wild-inferiors :back))) file-error) t) gcl27-2.7.0/ansi-tests/make-random-element-of.lsp000066400000000000000000000224371454061450500215100ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Dec 28 20:28:03 2004 ;;;; Contains: Code to make random elements of types (in-package :cl-test) (defgeneric make-random-element-of (type) (:documentation "Create a random element of TYPE, or throw an error if it can't figure out how to do it.")) (defgeneric make-random-element-of-compound-type (type args &key &allow-other-keys) (:documentation "Create a random element of (TYPE . ARGS), or throw an error if it can't figure out how to do it.")) (defmethod make-random-element-of ((type cons)) (make-random-element-of-compound-type (car type) (cdr type))) (defmethod make-random-element-of ((type (eql bit))) (random 2)) (defmethod make-random-element-of ((type (eql boolean))) (random-from-seq #(nil t))) (defmethod make-random-elememt-of ((type (eql symbol))) (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| car))) (defmethod make-random-element-of ((type (eql unsigned-byte))) (random-from-interval (1+ (ash 1 (random *maximum-random-int-bits*))))) (defmethod make-random-elememt-of ((type (eql signed-byte))) (random-from-interval (1+ (ash 1 (random *maximum-random-int-bits*))) (- (ash 1 (random *maximum-random-int-bits*))))) (defmethod make-random-element-of ((type (eql rational))) (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*)))) (n (random r)) (d (loop for x = (random r) unless (zerop x) do (return x)))) (if (coin) (/ n d) (- (/ n d))))) (defmethod make-random-element-of ((type (eql integer))) (let* ((b (random *maximum-random-int-bits*)) (x (ash 1 b))) (rcase (1 (+ x (make-random-element-of 'integer))) (1 (- (make-random-element-of 'integer) x)) (6 (random-from-interval (1+ x) (- x)))))) (defmethod make-random-element-of ((type (eql short-float))) (make-random-element-of (list type))) (defmethod make-random-element-of ((type (eql single-float))) (make-random-element-of (list type))) (defmethod make-random-element-of ((type (eql double-float))) (make-random-element-of (list type))) (defmethod make-random-element-of ((type (eql long-float))) (make-random-element-of (list type))) (defmethod make-random-element-of ((type (eql float))) (make-random-element-of (list (random-from-seq #'(short-float single-float double-float long-float))))) (defmethod make-random-element-of ((type (eql real))) (make-random-element-of (random-from-seq #(integer rational float)))) (defmethod make-random-element-of ((type (eql ratio))) (loop for x = (make-random-element-of 'rational) unless (integerp x) return x)) (defmethod make-random-element-of ((type complex)) (make-random-element-of '(complex real))) (defmethod make-random-element-of ((type fixnum)) (make-random-element-of `(integer ,most-negative-fixnum ,most-positive-fixnum))) (defmethod make-random-element-of ((type bignum)) (make-random-element-of `(or (integer * (,most-negative-fixnum)) (integer (,most-positive-fixnum))))) (defmethod make-random-element-of ((type (eql number))) (make-random-element-of (random-from-seq #(integer rational float complex)))) (defmethod make-random-element-of ((type (eql character))) (rcase (3 (random-from-seq +standard-chars+)) (2 (let ((r (random 256))) (or (code-char r) (make-random-element-of 'character)))) (1 (let ((r (random #.(ash 1 16)))) (or (code-char r) (make-random-element-of 'character)))) (1 (let ((r (random #.(ash 1 24)))) (or (code-char r) (make-random-element-of 'character)))))) (defmethod make-random-element-of ((type 'base-char)) (random-from-seq +standard-chars+)) (defmethod make-random-element-of ((type 'standard-char)) (random-from-seq +standard-chars+)) (defmethod make-random-element-of ((type (eql bit-vector))) (make-random-vector 'bit '*)) (defmethod make-random-element-of ((type (eql simple-bit-vector))) (make-random-vector 'bit '* :simple t)) (defmethod make-random-element-of ((type (eql vector))) (make-random-vector '* '*)) (defmethod make-random-element-of ((type (eql simple-vector))) (make-random-vector 't '* :simple t)) (defmethod make-random-elemnt-of ((type (eql array))) (make-random-array '* '*)) (defmethod make-random-elemnt-of ((type (eql simple-array))) (make-random-array '* '* :simple t)) (defmethod make-random-elememt-of ((type (eql string))) (make-random-string '*)) (defmethod make-random-elememt-of ((type (eql simple-string))) (make-random-string '* :simple t)) (defmethod make-random-element-of ((type (eql base-string))) (make-random-vector 'base-char '*)) (defmethod make-random-element-of ((type (eql simple-base-string))) (make-random-vector 'base-char '* :simple t)) (defmethod make-random-element-of ((type (eql cons))) (make-random-element-of '(cons t t))) (defmethod make-random-element-of ((type (eql null))) nil) (defmethod make-random-elememt-of ((type (eql list))) (let ((len (min (random 10) (random 10)))) (loop repeat len collect (make-random-element-of-type t)))) (defmethod make-random-element-of ((type (eql sequence))) (make-random-element-of '(or list vector))) ;;;; (defun make-random-vector (length &key simple (element-type '*)) (setq element-type (make-random-array-element-type element-type)) (make-random-element-of `(,(if simple 'simple-vector 'vector) ,element-type ,length))) (defun make-random-array (dimensions &key simple (element-type '*)) (setq element-type (make-random-array-element-type element-type)) (make-random-element-of `(,(if simple 'simple-array 'array) ,element-type ,length))) (defun make-random-array-element-type (elememt-type) (if (eq element-type '*) (rcase (1 'bit) (1 `(unsigned-byte (1+ (random *maximum-random-int-bits*)))) (1 `(signed-byte (1+ (random *maximum-random-int-bits*)))) (2 (random-from-seq #(character base-char standard-char))) ;; Put float, complex types here also (4 t)) element-type)) ;;;; (defmethod make-random-element-of-compound-type ((type-op (eql or)) (args cons)) (make-random-element-of (random-from-seq args))) (defmethod make-random-element-of-compound-type ((type-op (eql and)) (args cons)) (loop for e = (make-random-element-of (car args)) repeat 100 when (or (null (cdr args)) (typep e (cons 'and (cdr args)))) return x finally (error "Cannot generate a random element of ~A" (cons 'and args)))) (defmethod make-random-element-of-compound-type ((type-op (eql integer)) (args t)) (let ((lo (let ((lo (car args))) (cond ((consp lo) (1+ (car lo))) ((eq lo nil) '*) (t lo)))) (hi (let ((hi (cadr args))) (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))))) (defmethod make-random-element-of-compound-type ((type-op (eql short-float)) (args t)) (make-random-element-of-float-type type args)) (defmethod make-random-element-of-compound-type ((type-op (eql single-float)) (args t)) (make-random-element-of-float-type type args)) (defmethod make-random-element-of-compound-type ((type-op (eql double-float)) (args t)) (make-random-element-of-float-type type args)) (defmethod make-random-element-of-compound-type ((type-op (eql long-float)) (args t)) (make-random-element-of-float-type type args)) (defun make-random-element-of-float-type (type-op args) (let ((lo (car args)) (hi (cadr args)) lo= hi=) (cond ((consp lo) nil) ((member lo '(* nil)) (setq lo (most-negative-float type-op)) (setq lo= t)) (t (assert (typep lo type-op)) (setq lo= t))) (cond ((consp hi) nil) ((member hi '(* nil)) (setq hi (most-positive-float type-op)) (setq hi= t)) (t (assert (typep hi type-op)) (setq hi= t))) (assert (<= lo hi)) (assert (or (< lo hi) (and lo= hi=))) (let ((limit 100000)) (cond ((or (<= hi 0) (>= lo 0) (and (<= (- limit) hi limit) (<= (- limit) lo limit))) (loop for x = (+ (random (- hi lo)) lo) do (when (or lo= (/= x lo)) (return x)))) (t (rcase (1 (random (min hi (float limit hi)))) (1 (- (random (min (float limit lo) (- lo))))))))))) (defmethod make-random-element-of-compound-type ((type-op (eql mod)) (args cons)) (let ((modulus (car args))) (assert (integerp modulus)) (assert (plusp modulus)) (make-random-element-of `(integer 0 (,modulus))))) (defmethod make-random-element-of-compound-type ((type-op (eql unsigned-byte)) (args t)) (if (null args) (make-random-element-of '(integer 0 *)) (let ((bits (car args))) (if (eq bits'*) (make-random-element-of '(integer 0 *)) (progn (assert (and (integerp bits) (>= bits 1))) (make-random-element-of `(integer 0 ,(1- (ash 1 bits))))))))) (defmethod make-random-element-of-compound-type ((type-op (eql eql)) (args cons)) (assert (null (cdr args))) (car args)) (defmethod make-random-element-of-compound-type ((type-op (eql member)) (args cons)) (random-from-seq args)) gcl27-2.7.0/ansi-tests/make-random-state.lsp000066400000000000000000000031221454061450500205630ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 6 17:53:30 2003 ;;;; Contains: Tests of MAKE-RANDOM-STATE (in-package :cl-test) ;;; Error tests (deftest make-random-state.error.1 (signals-error (make-random-state nil nil) program-error) t) (deftest make-random-state.error.2 (signals-error (make-random-state t nil) program-error) t) (deftest make-random-state.error.3 (signals-error (make-random-state *random-state* nil) program-error) t) (deftest make-random-state.error.4 (check-type-error #'make-random-state (typef '(or (member nil t) random-state))) nil) ;;; Non-error tests (deftest make-random-state.1 (let ((rs (make-random-state))) (and (not (eq rs *random-state*)) (random-state-p rs) (eqlt (random 1000000) (random 1000000 rs)))) t) (deftest make-random-state.2 (let ((rs (make-random-state *random-state*))) (and (not (eq rs *random-state*)) (random-state-p rs) (eqlt (random 1000000) (random 1000000 rs)))) t) (deftest make-random-state.3 (let ((rs (make-random-state))) (random 10) (let ((rs2 (make-random-state rs))) (and (not (eq rs *random-state*)) (not (eq rs rs2)) (not (eq rs2 *random-state*)) (random-state-p rs) (random-state-p rs2) (eqlt (random 1.0 rs) (random 1.0 rs2))))) t) (deftest make-random-state.4 (let ((rs (make-random-state t)) (rs2 (make-random-state t))) (and (random-state-p rs) (not (eq rs *random-state*)) (random-state-p rs2) (not (eq rs2 *random-state*)) (not (eq rs rs2)) (integerp (random 10 rs)) (floatp (random 1.0 rs2)) t)) t) gcl27-2.7.0/ansi-tests/make-sequence.lsp000066400000000000000000000321511454061450500200010ustar00rootroot00000000000000;-*- 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) #+:ansi-tests-strict-initial-element (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) #+:ansi-tests-strict-initial-element (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) #+:ansi-tests-strict-initial-element (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) #+:ansi-tests-strict-initial-element (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) #+:ansi-tests-strict-initial-element (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) #+:ansi-tests-strict-initial-element (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) #+:ansi-tests-strict-initial-element (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) #+:ansi-tests-strict-initial-element (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) #+:ansi-tests-strict-initial-element (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) #+:ansi-tests-strict-initial-element (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)) #+:ansi-tests-strict-initial-element (deftest make-sequence.26 (equalp (make-sequence 'string 5) (make-string 5)) t) (deftest make-sequence.27 (let ((len 10)) (loop for i from 1 to 40 for etype = `(unsigned-byte ,i) for type = `(vector ,etype) for vec = (make-sequence type len :initial-element 0) unless (and (typep vec type) (loop for i below len always (eql (elt vec i) 0))) collect (list i etype type vec))) nil) (deftest make-sequence.28 (let ((len 10)) (loop for i from 1 to 40 for etype = `(signed-byte ,i) for type = `(vector ,etype) for vec = (make-sequence type len :initial-element 0) unless (and (typep vec type) (loop for i below len always (eql (elt vec i) 0))) collect (list i etype type vec))) nil) (deftest make-sequence.29 (let ((len 10)) (loop for etype in '(short-float single-float double-float long-float) for type = `(vector ,etype) for elem = (coerce 1 etype) for vec = (make-sequence type len :initial-element elem) unless (and (typep vec type) (loop for i below len always (eql (elt vec i) elem))) collect (list etype type vec))) nil) (deftest make-sequence.30 (let ((len 10)) (loop for cetype in '(short-float single-float double-float long-float integer rational) for etype = `(complex ,cetype) for type = `(vector ,etype) for elem = (complex (coerce 1 cetype) (coerce -1 cetype)) for vec = (make-sequence type len :initial-element elem) unless (and (typep vec type) (loop for i below len always (eql (elt vec i) elem))) collect (list etype type vec))) nil) ;;; Other type specifiers (deftest make-sequence.31 (make-sequence '(simple-string) 10 :initial-element #\X) "XXXXXXXXXX") (deftest make-sequence.32 (make-sequence '(simple-string 10) 10 :initial-element #\X) "XXXXXXXXXX") (deftest make-sequence.33 (make-sequence '(string) 10 :initial-element #\X) "XXXXXXXXXX") (deftest make-sequence.34 (make-sequence '(vector) 10 :initial-element nil) #(nil nil nil nil nil nil nil nil nil nil)) (deftest make-sequence.35 (make-sequence '(simple-vector) 10 :initial-element nil) #(nil nil nil nil nil nil nil nil nil nil)) (deftest make-sequence.36 (make-sequence '(vector * *) 10 :initial-element nil) #(nil nil nil nil nil nil nil nil nil nil)) ;;; Bit vectors (deftest make-sequence.37 (make-sequence 'bit-vector 5 :initial-element 0) #*00000) (deftest make-sequence.38 (make-sequence 'bit-vector 7 :initial-element 1) #*1111111) (deftest make-sequence.39 (make-sequence 'bit-vector 0) #*) (deftest make-sequence.40 (make-sequence '(bit-vector) 4 :initial-element 1) #*1111) (deftest make-sequence.41 (make-sequence '(bit-vector *) 10 :initial-element 0) #*0000000000) (deftest make-sequence.42 (make-sequence '(bit-vector 5) 5 :initial-element 0) #*00000) (deftest make-sequence.43 (make-sequence 'simple-bit-vector 5 :initial-element 0) #*00000) (deftest make-sequence.44 (make-sequence 'simple-bit-vector 7 :initial-element 1) #*1111111) (deftest make-sequence.45 (make-sequence 'simple-bit-vector 0) #*) (deftest make-sequence.46 (make-sequence '(simple-bit-vector) 4 :initial-element 1) #*1111) (deftest make-sequence.47 (make-sequence '(simple-bit-vector *) 10 :initial-element 0) #*0000000000) (deftest make-sequence.48 (make-sequence '(simple-bit-vector 5) 5 :initial-element 0) #*00000) (deftest make-sequence.49 (if (subtypep (class-of nil) 'sequence) (make-sequence (class-of nil) 0) nil) nil) (deftest make-sequence.50 (if (subtypep (class-of '(nil nil nil)) 'sequence) (make-sequence (class-of '(nil nil nil)) 3 :initial-element nil) '(nil nil nil)) (nil nil nil)) (deftest make-sequence.51 (loop for i from 1 to 40 for vec = (make-array 1 :element-type `(unsigned-byte ,i) :initial-element 1) for class = (class-of vec) nconc (if (subtypep class 'vector) (let ((vec2 (make-sequence class 1 :initial-element 1))) (unless (equalp vec vec) (list (list i vec class vec2)))) nil)) nil) (deftest make-sequence.52 (let ((class (class-of "aaaa"))) (if (subtypep class 'vector) (make-sequence class 4 :initial-element #\a) "aaaa")) "aaaa") (deftest make-sequence.53 (let ((class (class-of (make-array 4 :element-type 'base-char :fill-pointer 4 :adjustable t :initial-contents "aaaa")))) (if (subtypep class 'vector) (make-sequence class 4 :initial-element #\a) "aaaa")) "aaaa") (deftest make-sequence.54 (let ((class (class-of (make-array 4 :element-type 'character :fill-pointer 4 :adjustable t :initial-contents "aaaa")))) (if (subtypep class 'vector) (make-sequence class 4 :initial-element #\a) "aaaa")) "aaaa") (deftest make-sequence.55 (let ((class (class-of (make-array 4 :element-type 'character :initial-contents "aaaa")))) (if (subtypep class 'vector) (make-sequence class 4 :initial-element #\a) "aaaa")) "aaaa") (deftest make-sequence.56 (loop for i from 1 to 40 for vec = (make-array 1 :element-type `(unsigned-byte ,i) :adjustable t :fill-pointer 1 :initial-element 1) for class = (class-of vec) nconc (if (subtypep class 'vector) (let ((vec2 (make-sequence class 1 :initial-element 1))) (unless (equalp vec vec) (list (list i vec class vec2)))) nil)) nil) (deftest make-sequence.57 (make-sequence (find-class 'list) 4 :initial-element 'x) (x x x x)) (deftest make-sequence.58 (make-sequence (find-class 'cons) 4 :initial-element 'x) (x x x x)) ;;; 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 (signals-error-always (make-sequence 'symbol 10) type-error) t t) (deftest make-sequence.error.2 (signals-error (make-sequence 'null 1) type-error) t) (deftest make-sequence.error.3 (signals-error (make-sequence '(vector * 4) 3) type-error) t) (deftest make-sequence.error.4 (signals-error (make-sequence '(vector * 2) 3) type-error) t) (deftest make-sequence.error.5 (signals-error (make-sequence '(string 4) 3) type-error) t) (deftest make-sequence.error.6 (signals-error (make-sequence '(simple-string 2) 3) type-error) t) (deftest make-sequence.error.7 (signals-error (make-sequence 'cons 0) type-error) t) (deftest make-sequence.error.8 (signals-error (make-sequence) program-error) t) (deftest make-sequence.error.9 (signals-error (make-sequence 'list) program-error) t) (deftest make-sequence.error.10 (signals-error (make-sequence 'list 10 :bad t) program-error) t) (deftest make-sequence.error.11 (signals-error (make-sequence 'list 10 :bad t :allow-other-keys nil) program-error) t) (deftest make-sequence.error.12 (signals-error (make-sequence 'list 10 :initial-element) program-error) t) (deftest make-sequence.error.13 (signals-error (make-sequence 'list 10 0 0) program-error) t) (deftest make-sequence.error.14 (signals-error-always (locally (make-sequence 'symbol 10) t) type-error) t t) (deftest make-sequence.error.15 :notes (:result-type-element-type-by-subtype) (if (subtypep '(or (vector bit) (vector t)) 'vector) (signals-error (make-sequence '(or (vector bit) (vector t)) 10 :initial-element 0) error) t) t) (deftest make-sequence.error.16 (signals-error-always (make-sequence (find-class 'integer) 0) type-error) t t) ;;; 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) ;;; Const fold tests (def-fold-test make-sequence.fold.1 (make-sequence 'list 5 :initial-element 'a)) (def-fold-test make-sequence.fold.2 (make-sequence 'vector 5 :initial-element 'a)) (def-fold-test make-sequence.fold.3 (make-sequence 'bit-vector 5 :initial-element 0)) (def-fold-test make-sequence.fold.4 (make-sequence 'string 5 :initial-element #\a)) ;;; FIXME: Add tests for upgrading of character subtypes gcl27-2.7.0/ansi-tests/make-string-input-stream.lsp000066400000000000000000000051061454061450500221250ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 14 18:36:48 2004 ;;;; Contains: Tests for MAKE-STRING-INPUT-STREAM (in-package :cl-test) (deftest make-string-input-stream.1 (let ((s (make-string-input-stream ""))) (values (notnot (typep s 'stream)) (notnot (streamp s)) (notnot (input-stream-p s)) (output-stream-p s))) t t t nil) (deftest make-string-input-stream.2 (let ((s (make-string-input-stream "abcd"))) (values (notnot (typep s 'stream)) (notnot (streamp s)) (notnot (input-stream-p s)) (output-stream-p s))) t t t nil) (deftest make-string-input-stream.3 (let ((s (make-string-input-stream "abcd" 1))) (values (read-line s))) "bcd") (deftest make-string-input-stream.4 (let ((s (make-string-input-stream "abcd" 0 2))) (values (read-line s))) "ab") (deftest make-string-input-stream.5 (let ((s (make-string-input-stream "abcd" 1 nil))) (values (read-line s))) "bcd") (deftest make-string-input-stream.6 (let ((str1 (make-array 6 :element-type 'character :initial-contents "abcdef" :fill-pointer 4))) (let ((s (make-string-input-stream str1))) (values (read-line s) (read-char s nil :eof)))) "abcd" :eof) (deftest make-string-input-stream.7 (let* ((str1 (make-array 6 :element-type 'character :initial-contents "abcdef")) (str2 (make-array 4 :element-type 'character :displaced-to str1))) (let ((s (make-string-input-stream str2))) (values (read-line s) (read-char s nil :eof)))) "abcd" :eof) (deftest make-string-input-stream.8 (let* ((str1 (make-array 6 :element-type 'character :initial-contents "abcdef")) (str2 (make-array 4 :element-type 'character :displaced-to str1 :displaced-index-offset 1))) (let ((s (make-string-input-stream str2))) (values (read-line s) (read-char s nil :eof)))) "bcde" :eof) (deftest make-string-input-stream.9 (let ((str1 (make-array 6 :element-type 'character :initial-contents "abcdef" :adjustable t))) (let ((s (make-string-input-stream str1))) (values (read-line s) (read-char s nil :eof)))) "abcdef" :eof) (deftest make-string-input-stream.10 :notes (:allow-nil-arrays :nil-vectors-are-strings) (let ((s (make-string-input-stream (make-array 0 :element-type nil)))) (read-char s nil :eof)) :eof) ;;; Error tests (deftest make-string-input-stream.error.1 (signals-error (make-string-input-stream) program-error) t) (deftest make-string-input-stream.error.2 (signals-error (make-string-input-stream "abc" 1 2 nil) program-error) t) gcl27-2.7.0/ansi-tests/make-string-output-stream.lsp000066400000000000000000000073271454061450500223350ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 14 19:42:07 2004 ;;;; Contains: Tests of MAKE-STRING-OUTPUT-STREAM (in-package :cl-test) (deftest make-string-output-stream.1 (let ((s (make-string-output-stream))) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (input-stream-p s) (notnot (output-stream-p s)) (notnot (open-stream-p s)))) t t nil t t) (deftest make-string-output-stream.2 (let ((s (make-string-output-stream :element-type 'character))) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (input-stream-p s) (notnot (output-stream-p s)) (notnot (open-stream-p s)))) t t nil t t) (deftest make-string-output-stream.3 (let ((s (make-string-output-stream :element-type 'base-char))) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (input-stream-p s) (notnot (output-stream-p s)) (notnot (open-stream-p s)))) t t nil t t) (deftest make-string-output-stream.4 :notes (:nil-vectors-are-strings) (let ((s (make-string-output-stream :element-type nil))) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (input-stream-p s) (notnot (output-stream-p s)) (notnot (open-stream-p s)))) t t nil t t) (deftest make-string-output-stream.5 (let ((s (make-string-output-stream :allow-other-keys nil))) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (input-stream-p s) (notnot (output-stream-p s)) (notnot (open-stream-p s)))) t t nil t t) (deftest make-string-output-stream.6 (let ((s (make-string-output-stream :allow-other-keys t :foo 'bar))) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (input-stream-p s) (notnot (output-stream-p s)) (notnot (open-stream-p s)))) t t nil t t) (deftest make-string-output-stream.7 (let ((s (make-string-output-stream :foo 'bar :allow-other-keys t :allow-other-keys nil :foo2 'x))) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (input-stream-p s) (notnot (output-stream-p s)) (notnot (open-stream-p s)))) t t nil t t) (deftest make-string-output-stream.8 (let ((s (make-string-output-stream))) (write-string "abc" s) (write-string "def" s) (get-output-stream-string s)) "abcdef") (deftest make-string-output-stream.9 (let ((s (make-string-output-stream :element-type 'character))) (write-string "abc" s) (write-string "def" s) (get-output-stream-string s)) "abcdef") (deftest make-string-output-stream.10 (let ((s (make-string-output-stream :element-type 'base-char))) (write-string "abc" s) (write-string "def" s) (get-output-stream-string s)) "abcdef") (deftest make-string-output-stream.11 :notes (:nil-vectors-are-strings) (let ((s (make-string-output-stream :element-type nil))) (get-output-stream-string s)) "") (deftest make-string-output-stream.12 :notes (:nil-vectors-are-strings) (let ((s (make-string-output-stream :element-type nil))) (typep #\a (array-element-type (get-output-stream-string s)))) nil) (deftest make-string-output-stream.13 (let ((s (make-string-output-stream))) (values (close s) (open-stream-p s))) t nil) ;;; Error tests (deftest make-string-output-stream.error.1 (signals-error (make-string-output-stream nil) program-error) t) (deftest make-string-output-stream.error.2 (signals-error (make-string-output-stream :foo nil) program-error) t) (deftest make-string-output-stream.error.3 (signals-error (make-string-output-stream :allow-other-keys nil :foo 'bar) program-error) t) gcl27-2.7.0/ansi-tests/make-string.lsp000066400000000000000000000100211454061450500174670ustar00rootroot00000000000000;-*- 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) #+:ansi-tests-strict-initial-element (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) #+:ansi-tests-strict-initial-element (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) #+:ansi-tests-strict-initial-element (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) #+:ansi-tests-strict-initial-element (string-all-the-same s) )) t) (deftest make-string.10 :notes (:nil-vectors-are-strings) (let ((s (make-string 0 :element-type nil))) (values (notnot (stringp s)) (eqlt (length s) 0) (equalt s ""))) t t t) (def-fold-test make-string.fold.1 (make-string 5 :initial-element #\a)) ;;; 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 (signals-error (make-string) program-error) t) (deftest make-string.error.2 (signals-error (make-string 10 :bad t) program-error) t) (deftest make-string.error.3 (signals-error (make-string 10 :bad t :allow-other-keys nil) program-error) t) (deftest make-string.error.4 (signals-error (make-string 10 :initial-element) program-error) t) (deftest make-string.error.5 (signals-error (make-string 10 1 1) program-error) t) (deftest make-string.error.6 (signals-error (make-string 10 :element-type) program-error) t) ;;; 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) gcl27-2.7.0/ansi-tests/make-symbol.lsp000066400000000000000000000057061454061450500175040ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jun 14 05:45:21 2003 ;;;; Contains: Tests of MAKE-SYMBOL (in-package :cl-test) (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.11 :notes (:nil-vectors-are-strings) (symbol-name (make-symbol (make-array '(0) :element-type nil))) "") (deftest make-symbol.12 (let* ((name (make-array '(4) :initial-contents '(#\A #\B #\C #\D) :element-type 'base-char)) (s (make-symbol name)) (name2 (symbol-name s))) (values (symbol-package s) (string=t name2 "ABCD"))) nil t) (deftest make-symbol.13 (let* ((name (make-array '(6) :initial-contents '(#\A #\B #\C #\D #\E #\F) :element-type 'character :fill-pointer 4)) (s (make-symbol name)) (name2 (symbol-name s))) (values (symbol-package s) (string=t name2 "ABCD"))) nil t) (deftest make-symbol.14 (let* ((name (make-array '(4) :initial-contents '(#\A #\B #\C #\D) :adjustable t :element-type 'character)) (s (make-symbol name)) (name2 (symbol-name s))) (values (symbol-package s) (string=t name2 "ABCD"))) nil t) (deftest make-symbol.15 (let* ((name0 (make-array '(6) :initial-contents '(#\0 #\A #\B #\C #\D #\E) :element-type 'character)) (name (make-array '(4) :element-type 'character :displaced-to name0 :displaced-index-offset 1)) (s (make-symbol name)) (name2 (symbol-name s))) (values (symbol-package s) (string=t name2 "ABCD"))) nil t) (deftest make-symbol.16 (let* ((name0 (make-array '(6) :initial-contents '(#\0 #\A #\B #\C #\D #\E) :element-type 'base-char)) (name (make-array '(4) :element-type 'base-char :displaced-to name0 :displaced-index-offset 1)) (s (make-symbol name)) (name2 (symbol-name s))) (values (symbol-package s) (string=t name2 "ABCD"))) nil t) (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 (check-type-error #'make-symbol #'stringp) nil) (deftest make-symbol.error.9 (signals-error (make-symbol) program-error) t) (deftest make-symbol.error.10 (signals-error (make-symbol "a" "a") program-error) t) (deftest make-symbol.error.11 (signals-type-error x '(#\a #\b #\c) (make-symbol x)) t) gcl27-2.7.0/ansi-tests/make-synonym-stream.lsp000066400000000000000000000051341454061450500211770ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jan 28 06:54:33 2004 ;;;; Contains: Tests of MAKE-SYNONYM-STREAM (in-package :cl-test) (deftest make-synonym-stream.1 (with-input-from-string (*s* "abcde") (declare (special *s*)) (let ((ss (make-synonym-stream '*s*))) (assert (typep ss 'stream)) (assert (typep ss 'synonym-stream)) (assert (input-stream-p ss)) (assert (not (output-stream-p ss))) (assert (open-stream-p ss)) (assert (streamp ss)) (assert (stream-element-type ss)) (values (read-char *s*) (read-char ss) (read-char *s*) (read-char ss) (read-char ss)))) #\a #\b #\c #\d #\e) ;;; This test was wrong (section 21.1.4) #| (deftest make-synonym-stream.2 (let ((ss (make-synonym-stream '*s*))) (with-input-from-string (*s* "z") (declare (special *s*)) (assert (typep ss 'stream)) (assert (typep ss 'synonym-stream)) (assert (input-stream-p ss)) (assert (not (output-stream-p ss))) (assert (open-stream-p ss)) (assert (streamp ss)) (assert (stream-element-type ss)) (read-char ss))) #\z) |# (deftest make-synonym-stream.3 (with-output-to-string (*s*) (declare (special *s*)) (let ((ss (make-synonym-stream '*s*))) (assert (typep ss 'stream)) (assert (typep ss 'synonym-stream)) (assert (output-stream-p ss)) (assert (not (input-stream-p ss))) (assert (open-stream-p ss)) (assert (streamp ss)) (assert (stream-element-type ss)) (write-char #\a *s*) (write-char #\b ss) (write-char #\x *s*) (write-char #\y ss))) "abxy") (deftest make-synonym-stream.4 (let ((ss (make-synonym-stream '*terminal-io*))) (assert (typep ss 'stream)) (assert (typep ss 'synonym-stream)) (assert (output-stream-p ss)) (assert (input-stream-p ss)) (assert (open-stream-p ss)) (assert (streamp ss)) (assert (stream-element-type ss)) nil) nil) ;;; FIXME ;;; Add tests for: close, ;;; peek-char, read-char-no-hang, terpri, fresh-line, unread-char, ;;; read-line, write-line, write-string, read-sequence, write-sequence, ;;; read-byte, write-byte, listen, clear-input, finish-output, force-output, ;;; clear-output, format, print, prin1, princ ;;; Error cases (deftest make-synonym-stream.error.1 (signals-error (make-synonym-stream) program-error) t) (deftest make-synonym-stream.error.2 (signals-error (make-synonym-stream '*standard-input* nil) program-error) t) (deftest make-synonym-stream.error.3 (check-type-error #'make-synonym-stream #'symbolp) nil) gcl27-2.7.0/ansi-tests/make-tar000077500000000000000000000001761454061450500161670ustar00rootroot00000000000000rm -f binary/* rt/binary/* tar cvf cltest.tar README *.system *.lsp make-tar binary/ rt/*.system rt/*.lsp rt/*.txt rt/binary/ gcl27-2.7.0/ansi-tests/make-two-way-stream.lsp000066400000000000000000000156561454061450500211040ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Jan 30 05:39:56 2004 ;;;; Contains: Tests for MAKE-TWO-WAY-STREAM (in-package :cl-test) (deftest make-two-way-stream.1 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (assert (typep s 'stream)) (assert (typep s 'two-way-stream)) (assert (streamp s)) (assert (open-stream-p s)) (assert (input-stream-p s)) (assert (output-stream-p s)) (assert (stream-element-type s)) (values (read-char s) (write-char #\b s) (read-char s) (write-char #\a s) (read-char s) (write-char #\r s) (get-output-stream-string os))) #\f #\b #\o #\a #\o #\r "bar") (deftest make-two-way-stream.2 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (values (close s) (open-stream-p s) (notnot (open-stream-p is)) (notnot (open-stream-p os)) (write-char #\8 os) (get-output-stream-string os))) t nil t t #\8 "8") (deftest make-two-way-stream.3 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (values (peek-char nil s) (read-char s) (get-output-stream-string os))) #\f #\f "") (deftest make-two-way-stream.4 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (values (read-char-no-hang s) (read-char-no-hang s nil) (read-char-no-hang s t :eof) (read-char-no-hang s nil :eof) (get-output-stream-string os))) #\f #\o #\o :eof "") (deftest make-two-way-stream.5 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (values (terpri s) (get-output-stream-string os))) nil #.(string #\Newline)) (deftest make-two-way-stream.6 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (values (write-char #\+ s) (notnot (fresh-line s)) (read-char s) (get-output-stream-string os))) #\+ t #\f #.(coerce (list #\+ #\Newline) 'string)) (deftest make-two-way-stream.7 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (values (read-char s) (unread-char #\f s) (read-char s) (read-char s) (unread-char #\o s) (get-output-stream-string os))) #\f nil #\f #\o nil "") (deftest make-two-way-stream.8 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (values (read-line s) (get-output-stream-string os))) "foo" "") (deftest make-two-way-stream.9 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (values (write-string "bar" s) (get-output-stream-string os))) "bar" "bar") (deftest make-two-way-stream.10 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (values (write-line "bar" s) (get-output-stream-string os))) "bar" #.(concatenate 'string "bar" '(#\Newline))) (deftest make-two-way-stream.11 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (let ((x (vector nil nil nil))) (values (read-sequence x s) x (get-output-stream-string os)))) 3 #(#\f #\o #\o) "") (deftest make-two-way-stream.12 (let ((pn1 #p"tmp.dat") (pn2 #p"tmp2.dat") (element-type '(unsigned-byte 8))) (with-open-file (s pn1 :direction :output :if-exists :supersede :element-type element-type) (dolist (b '(3 8 19 41)) (write-byte b s))) (with-open-file (is pn1 :direction :input :element-type element-type) (with-open-file (os pn2 :direction :output :element-type element-type :if-exists :supersede) (let ((s (make-two-way-stream is os)) (x (vector nil nil nil nil))) (assert (eql (read-sequence x s) 4)) (assert (equalp x #(3 8 19 41))) (let ((y #(100 5 18 211 0 178))) (assert (eql (write-sequence y s) y)) (close s))))) (with-open-file (s pn2 :direction :input :element-type element-type) (let ((x (vector nil nil nil nil nil nil nil))) (values (read-sequence x s) x)))) 6 #(100 5 18 211 0 178 nil)) (deftest make-two-way-stream.13 (let ((pn1 #p"tmp.dat") (pn2 #p"tmp2.dat") (element-type '(unsigned-byte 32))) (with-open-file (s pn1 :direction :output :if-exists :supersede :element-type element-type) (dolist (b '(3 8 19 41)) (write-byte b s))) (with-open-file (is pn1 :direction :input :element-type element-type) (with-open-file (os pn2 :direction :output :element-type element-type :if-exists :supersede) (let ((s (make-two-way-stream is os)) (x (vector nil nil nil nil))) (assert (eql (read-sequence x s) 4)) (assert (equalp x #(3 8 19 41))) (let ((y #(100 5 18 211 0 178))) (assert (eql (write-sequence y s) y)) (close s))))) (with-open-file (s pn2 :direction :input :element-type element-type) (let ((x (vector nil nil nil nil nil nil nil))) (values (read-sequence x s) x)))) 6 #(100 5 18 211 0 178 nil)) (deftest make-two-way-stream.14 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (values (write-string "abc" s) (clear-input s) (write-string "def" s) (get-output-stream-string os))) "abc" nil "def" "abcdef") ;;; Error tests (deftest make-two-way-stream.error.1 (signals-error (make-two-way-stream) program-error) t) (deftest make-two-way-stream.error.2 (signals-error (make-two-way-stream (make-string-input-stream "foo")) program-error) t) (deftest make-two-way-stream.error.3 (signals-error (let ((os (make-string-output-stream))) (make-two-way-stream (make-string-input-stream "foo") os nil)) program-error) t) (deftest make-two-way-stream.error.4 (check-type-error #'(lambda (x) (make-two-way-stream x (make-string-output-stream))) #'(lambda (x) (and (streamp x) (input-stream-p x)))) nil) (deftest make-two-way-stream.error.5 (check-type-error #'(lambda (x) (make-two-way-stream x (make-string-output-stream))) #'(lambda (x) (and (streamp x) (input-stream-p x))) *streams*) nil) (deftest make-two-way-stream.error.6 (check-type-error #'(lambda (x) (make-two-way-stream (make-string-input-stream "foo") x)) #'(lambda (x) (and (streamp x) (output-stream-p x)))) nil) (deftest make-two-way-stream.error.7 (check-type-error #'(lambda (x) (make-two-way-stream (make-string-input-stream "foo") x)) #'(lambda (x) (and (streamp x) (output-stream-p x))) *streams*) nil) gcl27-2.7.0/ansi-tests/makefile000066400000000000000000000133321454061450500162360ustar00rootroot00000000000000# LISP=gcl # LISP=../unixport/saved_ansi_gcl # LISP=sbcl --noinform # LISP=~/sbcl/src/runtime/sbcl --core ~/sbcl/output/sbcl.core --noinform # LISP=clisp -ansi -q # LISP=abcl # LISP=ecl # LISP=/usr/local/lib/LispWorks/nongraphic-lispworks-4450 # LISP=acl MAKE=make test: @rm -rf scratch cat doit.lsp | $(LISP) | tee test.out test_results: ../unixport/saved_ansi_gcl echo '(load "gclload")' | $< |tee $@ test-symbols: (cat doit1.lsp ; echo "(load \"load-symbols.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-symbols.out test-eval-and-compile: (cat doit1.lsp ; echo "(load \"load-eval-and-compile.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-eval-and-compile.out test-data-and-control-flow: (cat doit1.lsp ; echo "(load \"load-data-and-control-flow.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-data-and-control-flow.out test-iteration: (cat doit1.lsp ; echo "(load \"load-iteration.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-iteration.out test-objects: (cat doit1.lsp ; echo "(load \"load-objects.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-objects.out test-conditions: (cat doit1.lsp ; echo "(load \"load-conditions.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-conditions.out test-cons: (cat doit1.lsp ; echo "(load \"load-cons.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-cons.out test-arrays: (cat doit1.lsp ; echo "(load \"load-arrays.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-arrays.out test-hash-tables: (cat doit1.lsp ; echo "(load \"load-hash-tables.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-hash-tables.out test-packages: (cat doit1.lsp ; echo "(load \"load-packages.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-packages.out test-numbers: (cat doit1.lsp ; echo "(load \"load-numbers.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-numbers.out test-sequences: (cat doit1.lsp ; echo "(load \"load-sequences.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-sequences.out test-structures: (cat doit1.lsp ; echo "(load \"load-structures.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-structures.out test-types-and-class: (cat doit1.lsp ; echo "(load \"load-types-and-class.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-types-and-class.out test-strings: (cat doit1.lsp ; echo "(load \"load-strings.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-strings.out test-characters: (cat doit1.lsp ; echo "(load \"load-characters.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-characters.out test-pathnames: (cat doit1.lsp ; echo "(load \"load-pathnames.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-pathnames.out test-files: (cat doit1.lsp ; echo "(load \"load-files.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-files.out test-streams: (cat doit1.lsp ; echo "(load \"load-streams.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-streams.out test-printer: (cat doit1.lsp ; echo "(load \"load-printer.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-printer.out test-reader: (cat doit1.lsp ; echo "(load \"load-reader.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-reader.out test-system-construction: (cat doit1.lsp ; echo "(load \"load-system-construction.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-system-construction.out test-environment: (cat doit1.lsp ; echo "(load \"load-environment.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-environment.out test-misc: (cat doit1.lsp ; echo "(load \"load-misc.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-misc.out test-all: test-symbols test-eval-and-compile test-data-and-control-flow test-iteration test-objects \ test-conditions test-cons test-arrays test-hash-tables test-packages test-numbers \ test-sequences test-structures test-types-and-class test-strings test-characters test-pathnames \ test-files test-streams test-printer test-reader test-system-construction test-environment \ test-misc test-compiled: @rm -rf scratch echo "(load \"compileit.lsp\")" | $(LISP) | tee test.out test-unixport: echo "(load \"doit.lsp\")" | ../unixport/saved_ansi_gcl | tee test.out ##+gcl (setq compiler::*cc* \"gcc -c -DVOL=volatile -fsigned-char -pipe \") random-test: (echo "(progn \ (setq *load-verbose* nil) \ (let* ((*standard-output* (make-broadcast-stream)) \ (*error-output* *standard-output*)) \ (load \"gclload1.lsp\") \ (funcall (symbol-function 'compile-and-load) \"random-int-form.lsp\"))) \ (in-package :cl-test) (declaim (optimize (safety 0)))\ (let ((x (cl-test::test-random-integer-forms 1000 3 1000 :random-size t :random-nvars t))) \ (setq x (cl-test::prune-results x)) \ (with-open-file (*standard-output* \"failures.lsp\" \ :direction :output \ :if-exists :append \ :if-does-not-exist :create) \ (mapc #'print x))) \ #+allegro (excl::exit) \ ; extra quits added to avoid being trapped in debugger in some lisps \ (cl-user::quit) \ (cl-user::quit) \ (cl-user::quit) \ (cl-user::quit) \ (cl-user::quit) \ (cl-user::quit) \ (cl-user::quit) \ (cl-user::quit) \ (cl-user::quit) \ (cl-user::quit) \ (cl-user::quit)") | $(LISP) rm -f gazonk* rt_1000_8: echo "(load \"gclload1.lsp\") \ (compile-and-load \"random-int-form.lsp\") \ (in-package :cl-test) (loop-random-int-forms 1000 8)" | $(LISP) clean: @rm -f test*.out *.cls *.fasl *.o *.so *~ *.fn *.x86f *.fasl *.ufsl *.abcl *.fas *.lib \#*\# @rm -f *.dfsl *.d64fsl @(cd beyond-ansi; $(MAKE) clean) @rm -rf scratch/ scratch.txt @rm -f foo.txt foo.lsp foo.dat @rm -f tmp.txt tmp.dat tmp2.dat temp.dat @rm -f gazonk* out.class @rm -rf TMP/ @rm -f "CLTEST:file-that-was-renamed.txt" file-that-was-renamed.txt COMPILE-FILE-TEST-LP.OUT @rm -f compile-file-test-lp.lsp compile-file-test-lp.out ldtest.lsp test_results gcl27-2.7.0/ansi-tests/makunbound.lsp000066400000000000000000000021531454061450500174200ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jul 13 07:55:05 2004 ;;;; Contains: Add tests for MAKUNBOUND (in-package :cl-test) (deftest makunbound.1 (let ((sym (gensym))) (values (boundp sym) (equalt (multiple-value-list (makunbound sym)) (list sym)) (boundp sym) (setf (symbol-value sym) nil) (notnot (boundp sym)) (equalt (multiple-value-list (makunbound sym)) (list sym)) (boundp sym))) nil t nil nil t t nil) (deftest makunbound.2 (let ((sym (gensym))) (values (boundp sym) (setf (symbol-value sym) :foo) (equalt (multiple-value-list (makunbound sym)) (list sym)) (boundp sym) (handler-case (symbol-value sym) (unbound-variable (c) (if (eq (cell-error-name c) sym) :good (list :bad sym (cell-error-name c))))))) nil :foo t nil :good) ;;; Error cases (deftest makunbound.error.1 (signals-error (makunbound) program-error) t) (deftest makunbound.error.2 (signals-error (makunbound (gensym) nil) program-error) t) (deftest makunbound.error.3 (check-type-error #'makunbound #'symbolp) nil) gcl27-2.7.0/ansi-tests/map-into.lsp000066400000000000000000000313451454061450500170060ustar00rootroot00000000000000;-*- 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") (deftest map-into-string.13 (do-special-strings (s (copy-seq "12345") nil) (let ((s2 (map-into s #'identity "abcde"))) (assert (eq s s2)) (assert (string= s2 "abcde")))) nil) (deftest map-into-string.14 (do-special-strings (s "abcde" nil) (let* ((s1 (copy-seq "123456")) (s2 (map-into s1 #'identity s))) (assert (eq s1 s2)) (assert (string= s2 "abcde6")))) nil) ;;; 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) ;;; Other specialized vectors (deftest map-into.specialized-vector.1 (do-special-integer-vectors (v #(1 2 3 4) nil) (let ((result (list nil nil nil nil))) (assert (eq (map-into result #'identity v) result)) (assert (equal result '(1 2 3 4))))) nil) (deftest map-into.specialized-vector.2 (do-special-integer-vectors (v #(1 2 3) nil) (let ((result (list nil nil nil nil))) (assert (eq (map-into result #'identity v) result)) (assert (equal result '(1 2 3 nil))))) nil) (deftest map-into.specialized-vector.3 (do-special-integer-vectors (v #(1 1 0 1 1) nil) (let ((result (list nil nil nil nil))) (assert (eq (map-into result #'identity v) result)) (assert (equal result '(1 1 0 1))))) nil) (deftest map-into.specialized-vector.4 (do-special-integer-vectors (v #(1 2 1 2 2) nil) (let ((v2 #(2 1 2 2 1))) (assert (eq (map-into v #'identity v2) v)) (assert (equalp v #(2 1 2 2 1))))) nil) (deftest map-into.specialized-vector.5 (let ((len 10)) (loop for etype in '(short-float single-float double-float long-float) for vals = (loop for i below len collect (coerce i etype)) for vec = (make-array len :initial-contents vals :element-type etype) for target = (loop repeat len collect nil) for result = (map-into target #'identity vec) unless (and (eq target result) (= (length result) len) (= (length vec) len) (equal vals result)) collect (list etype vals vec result))) nil) (deftest map-into.specialized-vector.6 (let ((len 10)) (loop for cetype in '(short-float single-float double-float long-float) for etype = `(complex ,cetype) for vals = (loop for i from 1 to len collect (complex (coerce i cetype) (coerce (- i) cetype))) for vec = (make-array len :initial-contents vals :element-type etype) for target = (loop repeat len collect nil) for result = (map-into target #'identity vec) unless (and (eq target result) (= (length result) len) (= (length vec) len) (equal vals result)) collect (list etype vals vec result))) nil) (deftest map-into.specialized-vector.7 (let ((len 10)) (loop for etype in '(short-float single-float double-float long-float) for vals = (loop for i below len collect (coerce i etype)) for target = (make-array len :initial-contents vals :element-type etype) for result = (map-into target #'identity vals) unless (and (eq target result) (= (length result) len) (every #'= result vals)) collect (list etype vals result))) nil) (deftest map-into.specialized-vector.8 (let ((len 10)) (loop for cetype in '(short-float single-float double-float long-float) for etype = `(complex ,cetype) for vals = (loop for i from 1 to len collect (complex (coerce i cetype) (coerce (- i) cetype))) for target = (make-array len :initial-contents vals :element-type etype) for result = (map-into target #'identity vals) unless (and (eq target result) (= (length result) len) (every #'= result vals)) collect (list etype vals result))) nil) ;;; Error cases (deftest map-into.error.1 (check-type-error #'(lambda (x) (map-into x (constantly nil))) #'sequencep) nil) ;;; 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 (and (locally (declare (optimize (safety 3))) (handler-case (eval '(map-into nil #'identity 'a)) (type-error () nil))) :bad) nil) (deftest map-into.error.3 (check-type-error #'(lambda (x) (map-into (copy-seq '(a b c)) #'cons '(d e f) x)) #'sequencep) nil) (deftest map-into.error.4 (signals-error (map-into) program-error) t) (deftest map-into.error.5 (signals-error (map-into (list 'a 'b 'c)) program-error) t) (deftest map-into.error.6 (signals-error (locally (map-into 'a #'(lambda () nil)) t) type-error) t) (deftest map-into.error.7 (signals-error (map-into (list 'a 'b 'c) #'cons '(a b c)) program-error) t) (deftest map-into.error.8 (signals-error (map-into (list 'a 'b 'c) #'car '(a b c)) type-error) t) ;;; 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) gcl27-2.7.0/ansi-tests/map.lsp000066400000000000000000000245561454061450500160450ustar00rootroot00000000000000;-*- 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.37 (map 'simple-string #'identity '(#\a #\b #\c)) "abc") (deftest map.38 (map '(simple-string) #'identity '(#\a #\b #\c)) "abc") (deftest map.39 (map '(simple-string *) #'identity '(#\a #\b #\c)) "abc") (deftest map.40 (map '(simple-string 3) #'identity '(#\a #\b #\c)) "abc") (deftest map.41 (map '(base-string) #'identity '(#\a #\b #\c)) "abc") (deftest map.42 (map '(base-string *) #'identity '(#\a #\b #\c)) "abc") (deftest map.43 (map '(base-string 3) #'identity '(#\a #\b #\c)) "abc") (deftest map.44 (map 'simple-base-string #'identity '(#\a #\b #\c)) "abc") (deftest map.45 (map '(simple-base-string) #'identity '(#\a #\b #\c)) "abc") (deftest map.46 (map '(simple-base-string *) #'identity '(#\a #\b #\c)) "abc") (deftest map.47 (map '(simple-base-string 3) #'identity '(#\a #\b #\c)) "abc") (deftest map.48 :notes (:result-type-element-type-by-subtype) (let ((type '(or (vector t 10) (vector t 5)))) (if (subtypep type '(vector t)) (equalpt (map type #'identity '(1 2 3 4 5)) #(1 2 3 4 5)) t)) t) ;;; Error tests (deftest map.error.1 (signals-error-always (map 'symbol #'identity '(a b c)) type-error) t t) (deftest map.error.1a (signals-error (map 'symbol #'identity '(a b c)) type-error) t) (deftest map.error.2 (signals-error (map '(vector * 8) #'identity '(a b c)) type-error) t) (deftest map.error.3 (signals-error (map 'list #'identity '(a b . c)) type-error) t) (deftest map.error.4 (signals-error (map) program-error) t) (deftest map.error.5 (signals-error (map 'list) program-error) t) (deftest map.error.6 (signals-error (map 'list #'null) program-error) t) (deftest map.error.7 (signals-error (map 'list #'cons '(a b c d)) program-error) t) (deftest map.error.8 (signals-error (map 'list #'cons '(a b c d) '(1 2 3 4) '(5 6 7 8)) program-error) t) (deftest map.error.9 (signals-error (map 'list #'car '(a b c d)) type-error) t) (deftest map.error.10 :notes (:result-type-element-type-by-subtype) (let ((type '(or (vector bit) (vector t)))) (if (subtypep type 'vector) (eval `(signals-error-always (map ',type #'identity '(1 0 1)) error)) (values t t))) t t) (deftest map.error.11 (let ((type '(or (vector t 5) (vector t 10)))) (if (subtypep type 'vector) (eval `(signals-error (map ',type #'identity '(1 2 3 4 5 6)) type-error)) t)) t) (deftest map.error.12 (check-type-error #'(lambda (x) (map 'list #'identity x)) #'sequencep) nil) (deftest map.error.13 (check-type-error #'(lambda (x) (map 'vector #'cons '(a b c d) x)) #'sequencep) nil) ;;; 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)) ;;; Specialized string tests (deftest map.specialized-string.1 (do-special-strings (s "abcde" nil) (let ((s2 (map 'list #'identity s))) (assert (equal s2 '(#\a #\b #\c #\d #\e))))) nil) (deftest map.specialized-string.2 (do-special-strings (s "abcde" nil) (let ((s2 (map 'list #'(lambda (x y) y) '(1 2 3 4 5) s))) (assert (equal s2 '(#\a #\b #\c #\d #\e))))) nil) (deftest map.specialized-string.3 (let ((s (map 'base-string #'identity '(#\a #\b #\c)))) (assert (typep s 'base-string)) s) "abc") ;;; FIXME: Add tests for building strings of other character types ;;; Special vector types (deftest map.specialized-vector.1 (do-special-integer-vectors (v #(0 1 1 0 0 1) nil) (assert (equal (map 'list #'list v v) '((0 0) (1 1) (1 1) (0 0) (0 0) (1 1))))) nil) (deftest map.specialized-vector.2 (do-special-integer-vectors (v #(1 2 3 4 5 6 7) nil) (assert (equal (map 'list #'identity v) '(1 2 3 4 5 6 7)))) nil) (deftest map.specialized-vector.3 (do-special-integer-vectors (v #(-1 -2 -3 -4 -5 -6 -7) nil) (assert (equal (map 'list #'- v) '(1 2 3 4 5 6 7)))) nil) (deftest map.specialized-vector.4 (loop for i from 1 to 40 for type = `(unsigned-byte ,i) for bound = (ash 1 i) for len = 10 for vals = (loop repeat len collect (random i)) for result = (map `(vector ,type) #'identity vals) unless (and (= (length result) len) (every #'eql vals result)) collect (list i vals result)) nil) (deftest map.specialized-vector.5 (loop for i from 1 to 40 for type = `(signed-byte ,i) for bound = (ash 1 i) for len = 10 for vals = (loop repeat len collect (- (random i) (/ bound 2))) for result = (map `(vector ,type) #'identity vals) unless (and (= (length result) len) (every #'eql vals result)) collect (list i vals result)) nil) (deftest map.specialized-vector.6 (loop for type in '(short-float single-float long-float double-float) for len = 10 for vals = (loop for i from 1 to len collect (coerce i type)) for result = (map `(vector ,type) #'identity vals) unless (and (= (length result) len) (every #'eql vals result)) collect (list type vals result)) nil) (deftest map.specialized-vector.7 (loop for etype in '(short-float single-float long-float double-float integer rational) for type = `(complex ,etype) for len = 10 for vals = (loop for i from 1 to len collect (complex (coerce i etype) (coerce (- i) etype))) for result = (map `(vector ,type) #'identity vals) unless (and (= (length result) len) (every #'eql vals result)) collect (list type vals result)) nil) ;;; 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) ;;; Constant folding test (def-fold-test map.fold.1 (map 'vector #'identity '(a b c))) gcl27-2.7.0/ansi-tests/mapc.lsp000066400000000000000000000041041454061450500161730ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:21:24 2003 ;;;; Contains: Tests of MAPC (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) (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) ;;; Error tests (deftest mapc.error.1 (check-type-error #'(lambda (x) (mapc #'identity x)) #'listp) nil) (deftest mapc.error.2 (signals-error (mapc) program-error) t) (deftest mapc.error.3 (signals-error (mapc #'append) program-error) t) (deftest mapc.error.4 (signals-error (locally (mapc #'identity 1) t) type-error) t) (deftest mapc.error.5 (signals-error (mapc #'cons '(a b c)) program-error) t) (deftest mapc.error.6 (signals-error (mapc #'cons '(a b c) '(1 2 3) '(4 5 6)) program-error) t) (deftest mapc.error.7 (signals-error (mapc #'car '(a b c)) type-error) t) (deftest mapc.error.8 (signals-error (mapc #'identity (list* 1 2 3 4)) type-error) t) gcl27-2.7.0/ansi-tests/mapcan.lsp000066400000000000000000000050431454061450500165150ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:22:46 2003 ;;;; Contains: Tests of MAPCAN (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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 (check-type-error #'(lambda (x) (mapcan #'identity x)) #'listp) nil) (deftest mapcan.error.2 (signals-error (mapcan) program-error) t) (deftest mapcan.error.3 (signals-error (mapcan #'append) program-error) t) (deftest mapcan.error.4 (signals-error (locally (mapcan #'identity 1) t) type-error) t) (deftest mapcan.error.5 (signals-error (mapcan #'car '(a b c)) type-error) t) (deftest mapcan.error.6 (signals-error (mapcan #'cons '(a b c)) program-error) t) (deftest mapcan.error.7 (signals-error (mapcan #'cons '(a b c) '(1 2 3) '(4 5 6)) program-error) t) (deftest mapcan.error.8 (signals-error (mapcan #'identity (list* (list 1) (list 2) 3)) type-error) t) gcl27-2.7.0/ansi-tests/mapcar.lsp000066400000000000000000000053221454061450500165210ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:22:16 2003 ;;;; Contains: Tests of MAPCAR (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) (def-fold-test mapcar.fold.1 (mapcar 'identity '(a b c d))) (def-fold-test mapcar.fold.2 (mapcar 'not '(t nil nil t t))) ;;; Error tests (deftest mapcar.error.1 (check-type-error #'(lambda (x) (mapcar #'identity x)) #'listp) nil) (deftest mapcar.error.2 (signals-error (mapcar) program-error) t) (deftest mapcar.error.3 (signals-error (mapcar #'append) program-error) t) (deftest mapcar.error.4 (signals-error (locally (mapcar #'identity 1) t) type-error) t) (deftest mapcar.error.5 (signals-error (mapcar #'car '(a b c)) type-error) t) (deftest mapcar.error.6 (signals-error (mapcar #'cons '(a b c)) program-error) t) (deftest mapcar.error.7 (signals-error (mapcar #'cons '(a b c) '(1 2 3) '(4 5 6)) program-error) t) (deftest mapcar.error.8 (signals-error (mapcar #'identity (list* 1 2 3 4)) type-error) t) gcl27-2.7.0/ansi-tests/mapcon.lsp000066400000000000000000000035761454061450500165440ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:24:28 2003 ;;;; Contains: Tests of MAPCON (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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 (check-type-error #'(lambda (x) (mapcon #'identity x)) #'listp) nil) (deftest mapcon.error.2 (signals-error (mapcon) program-error) t) (deftest mapcon.error.3 (signals-error (mapcon #'append) program-error) t) (deftest mapcon.error.4 (signals-error (locally (mapcon #'identity 1) t) type-error) t) (deftest mapcon.error.5 (signals-error (mapcon #'caar '(a b c)) type-error) t) (deftest mapcon.error.6 (signals-error (mapcon #'cons '(a b c)) program-error) t) (deftest mapcon.error.7 (signals-error (mapcon #'cons '(a b c) '(1 2 3) '(4 5 6)) program-error) t) (deftest mapcon.error.8 (signals-error (mapcon #'copy-tree (cons 1 2)) type-error) t) gcl27-2.7.0/ansi-tests/maphash.lsp000066400000000000000000000073441454061450500167050ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Nov 28 09:36:58 2003 ;;;; Contains: Test of MAPHASH (in-package :cl-test) (deftest maphash.1 (let ((table (make-hash-table))) (loop for i from 1 to 1000 do (setf (gethash i table) (+ i i))) (let ((s1 0) (s2 0)) (values (multiple-value-list (maphash #'(lambda (k v) (incf s1 k) (incf s2 v)) table)) s1 s2))) (nil) #.(* 500 1001) #.(* 1000 1001)) (deftest maphash.2 (let ((table (make-hash-table :test 'equal))) (loop for i from 1 to 1000 do (setf (gethash i table) (+ i i))) (let ((s1 0) (s2 0)) (values (multiple-value-list (maphash #'(lambda (k v) (incf s1 k) (incf s2 v)) table)) s1 s2))) (nil) #.(* 500 1001) #.(* 1000 1001)) (deftest maphash.3 (let ((table (make-hash-table :test 'equalp))) (loop for i from 1 to 1000 do (setf (gethash i table) (+ i i))) (let ((s1 0) (s2 0)) (values (multiple-value-list (maphash #'(lambda (k v) (incf s1 k) (incf s2 v)) table)) s1 s2))) (nil) #.(* 500 1001) #.(* 1000 1001)) ;;; Test that REMHASH on the key being traversed is allowed (deftest maphash.4 (let ((table (make-hash-table))) (loop for i from 1 to 1000 do (setf (gethash i table) (+ i i))) (let ((s1 0) (s2 0)) (values (multiple-value-list (maphash #'(lambda (k v) (incf s1 k) (incf s2 v) (remhash k table)) table)) s1 s2 (hash-table-count table)))) (nil) #.(* 500 1001) #.(* 1000 1001) 0) (deftest maphash.5 (let ((table (make-hash-table :test 'equal))) (loop for i from 1 to 1000 do (setf (gethash i table) (+ i i))) (let ((s1 0) (s2 0)) (values (multiple-value-list (maphash #'(lambda (k v) (incf s1 k) (incf s2 v) (remhash k table)) table)) s1 s2 (hash-table-count table)))) (nil) #.(* 500 1001) #.(* 1000 1001) 0) (deftest maphash.6 (let ((table (make-hash-table :test 'equalp))) (loop for i from 1 to 1000 do (setf (gethash i table) (+ i i))) (let ((s1 0) (s2 0)) (values (multiple-value-list (maphash #'(lambda (k v) (incf s1 k) (incf s2 v) (remhash k table)) table)) s1 s2 (hash-table-count table)))) (nil) #.(* 500 1001) #.(* 1000 1001) 0) ;;; EQ hash tables (deftest maphash.7 (let ((symbols '(a b c d e f g h i j k l m n o p q r s t u v w x y z)) (table (make-hash-table :test #'eq))) (loop for sym in symbols for i from 1 do (setf (gethash sym table) i)) (let ((sum 0)) (values (multiple-value-list (maphash #'(lambda (k v) (assert (eq (elt symbols (1- v)) k)) (incf sum v)) table)) sum))) (nil) #.(* 13 27)) (deftest maphash.8 (let ((symbols '(a b c d e f g h i j k l m n o p q r s t u v w x y z)) (table (make-hash-table :test #'eq))) (loop for sym in symbols for i from 1 do (setf (gethash sym table) i)) (let ((sum 0)) (values (multiple-value-list (maphash #'(lambda (k v) (assert (eq (elt symbols (1- v)) k)) (remhash k table) (incf sum v)) table)) sum (hash-table-count table)))) (nil) #.(* 13 27) 0) ;;; Need to add tests where things are setf'd during traversal (deftest maphash.order.1 (let ((i 0) x y dummy (table (make-hash-table))) (values (multiple-value-list (maphash (progn (setf x (incf i)) #'(lambda (k v) (setf dummy (list k v)))) (progn (setf y (incf i)) table))) i x y dummy)) (nil) 2 1 2 nil) ;;; Error tests (deftest maphash.error.1 (signals-error (maphash) program-error) t) (deftest maphash.error.2 (signals-error (maphash #'list) program-error) t) (deftest maphash.error.3 (signals-error (maphash #'list (make-hash-table) nil) program-error) t) gcl27-2.7.0/ansi-tests/mapl.lsp000066400000000000000000000053461454061450500162150ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:23:23 2003 ;;;; Contains: Tests of MAPL (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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 (check-type-error #'(lambda (x) (mapl #'identity x)) #'sequencep) nil) (deftest mapl.error.2 (signals-error (mapl) program-error) t) (deftest mapl.error.3 (signals-error (mapl #'append) program-error) t) (deftest mapl.error.4 (signals-error (locally (mapl #'identity 1) t) type-error) t) (deftest mapl.error.5 (signals-error (mapl #'cons '(a b c)) program-error) t) (deftest mapl.error.6 (signals-error (mapl #'cons '(a b c) '(1 2 3) '(4 5 6)) program-error) t) (deftest mapl.error.7 (signals-error (mapl #'caar '(a b c)) type-error) t) (deftest mapl.error.8 (signals-error (mapl #'identity (list* (list 1) (list 2) 3)) type-error) t) gcl27-2.7.0/ansi-tests/maplist.lsp000066400000000000000000000060721454061450500167320ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:24:00 2003 ;;;; Contains: Tests of MAPLIST (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) (def-fold-test maplist.fold.1 (maplist 'car '(a b c d e))) (def-fold-test maplist.fold.2 (maplist #'cadr '(a b c d e))) ;;; Error tests (deftest maplist.error.1 (check-type-error #'(lambda (x) (maplist #'identity x)) #'listp) nil) (deftest maplist.error.2 (signals-error (maplist #'identity 1) type-error) t) (deftest maplist.error.3 (signals-error (maplist #'identity 1.1323) type-error) t) (deftest maplist.error.4 (signals-error (maplist #'identity "abcde") type-error) t) (deftest maplist.error.5 (signals-error (maplist) program-error) t) (deftest maplist.error.6 (signals-error (maplist #'append) program-error) t) (deftest maplist.error.7 (signals-error (locally (maplist #'identity 'a) t) type-error) t) (deftest maplist.error.8 (signals-error (maplist #'caar '(a b c)) type-error) t) (deftest maplist.error.9 (signals-error (maplist #'cons '(a b c)) program-error) t) (deftest maplist.error.10 (signals-error (maplist #'cons '(a b c) '(1 2 3) '(4 5 6)) program-error) t) (deftest maplist.error.11 (signals-error (maplist #'identity (list* (list 1) (list 2) 3)) type-error) t) gcl27-2.7.0/ansi-tests/mask-field.lsp000066400000000000000000000042031454061450500172670ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Sep 11 21:27:13 2003 ;;;; Contains: Tests of MASK-FIELD (in-package :cl-test) ;;; Error tests (deftest mask-field.error.1 (signals-error (mask-field) program-error) t) (deftest mask-field.error.2 (signals-error (mask-field (byte 1 1)) program-error) t) (deftest mask-field.error.3 (signals-error (mask-field (byte 1 1) -1 0) program-error) t) ;;; Non-error tests (deftest mask-field.1 (loop for x = (random-fixnum) for pos = (random 30) for size = (random 30) repeat 10000 unless (eql (mask-field (byte size pos) x) (logand (ash (1- (ash 1 size)) pos) x)) collect (list x pos size)) nil) (deftest mask-field.2 (let ((bound (ash 1 300))) (loop for x = (random-from-interval bound) for pos = (random 300) for size = (random 300) repeat 1000 unless (eql (mask-field (byte size pos) x) (logand (ash (1- (ash 1 size)) pos) x)) collect (list x pos size))) nil) (deftest mask-field.3 (loop for i of-type fixnum from -1000 to 1000 always (eql (mask-field (byte 0 0) i) 0)) t) (deftest mask-field.order.1 (let ((i 0) a b c d) (values (mask-field (progn (setf a (incf i)) (byte (progn (setf b (incf i)) 3) (progn (setf c (incf i)) 1))) (progn (setf d (incf i)) -1)) i a b c d)) 14 4 1 2 3 4) ;;; mask-field on places (deftest mask-field.place.1 (let ((x 0)) (values (setf (mask-field (byte 4 1) x) -1) x)) -1 30) (deftest mask-field.place.2 (loop for pos from 0 to 100 always (loop for size from 0 to 100 always (let ((x 0) (field (ash 1 pos))) (and (eql (setf (mask-field (byte size pos) x) field) field) (if (> size 0) (eql x field) (eql x 0)) )))) t) (deftest mask-field.place.order.1 (let ((i 0) a b c d e f (x (copy-seq #(63)))) (values (setf (mask-field (progn (setf a (incf i)) (byte (progn (setf b (incf i)) 3) (progn (setf c (incf i)) 1))) (aref (progn (setf d (incf i)) x) (progn (setf e (incf i)) 0))) (progn (setf f (incf i)) (lognot 14))) x i a b c d e f)) -15 #(49) 6 1 2 3 4 5 6) gcl27-2.7.0/ansi-tests/max.lsp000066400000000000000000000101751454061450500160450ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 3 15:55:17 2003 ;;;; Contains: Tests of MAX (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest max.error.1 (signals-error (max) program-error) t) (deftest max.error.2 (check-type-error #'max #'realp) nil) (deftest max.error.3 (check-type-error #'(lambda (x) (max 0 x)) #'realp) nil) ;;; Non-error tests (deftest max.1 (loop for n in *reals* when (or (not (eql (max n) n)) (not (eql (max n n) n)) (not (eql (max n n n) n)) (not (eql (apply #'max (make-list (min 256 (1- call-arguments-limit)) :initial-element n)) n))) collect n) nil) (deftest max.2 (max.2-fn) nil) (deftest max.3 (loop for x = (- (random 60000) 30000) for y = (- (random 60000) 30000) for m = (max x y) for m2 = (if (>= x y) x y) repeat 1000 unless (eql m m2) collect (list x y m m2)) nil) (deftest max.4 (loop for x = (- (random 6000000) 3000000) for y = (- (random 6000000) 3000000) for m = (max x y) for m2 = (if (>= x y) x y) repeat 1000 unless (eql m m2) collect (list x y m m2)) nil) (deftest max.5 (loop for x = (- (random 1000000000000) 500000000000) for y = (- (random 1000000000000) 500000000000) for m = (max x y) for m2 = (if (>= x y) x y) repeat 1000 unless (eql m m2) collect (list x y m m2)) nil) (deftest max.6 (let ((m (max 2 1.0s0))) (or (eqlt m 2) (eqlt m 2.0s0))) t) (deftest max.7 (max 0 1.0s0) 1.0s0) (deftest max.8 (let ((m (max 2 1.0f0))) (or (eqlt m 2) (eqlt m 2.0f0))) t) (deftest max.9 (max 0 1.0f0) 1.0f0) (deftest max.10 (let ((m (max 2 1.0d0))) (or (eqlt m 2) (eqlt m 2.0d0))) t) (deftest max.11 (max 0 1.0d0) 1.0d0) (deftest max.12 (let ((m (max 2 1.0l0))) (or (eqlt m 2) (eqlt m 2.0l0))) t) (deftest max.13 (max 0 1.0l0) 1.0l0) (deftest max.15 (let ((m (max 1.0s0 0.0f0))) (or (eqlt m 1.0s0) (eqlt m 1.0f0))) t) (deftest max.16 (max 0.0s0 1.0f0) 1.0f0) (deftest max.17 (let ((m (max 1.0s0 0.0d0))) (or (eqlt m 1.0s0) (eqlt m 1.0d0))) t) (deftest max.18 (max 0.0s0 1.0d0) 1.0d0) (deftest max.19 (let ((m (max 1.0s0 0.0l0))) (or (eqlt m 1.0s0) (eqlt m 1.0l0))) t) (deftest max.20 (max 0.0s0 1.0l0) 1.0l0) (deftest max.21 (let ((m (max 1.0f0 0.0d0))) (or (eqlt m 1.0f0) (eqlt m 1.0d0))) t) (deftest max.22 (max 0.0f0 1.0d0) 1.0d0) (deftest max.23 (let ((m (max 1.0f0 0.0l0))) (or (eqlt m 1.0f0) (eqlt m 1.0l0))) t) (deftest max.24 (max 0.0f0 1.0l0) 1.0l0) (deftest max.25 (let ((m (max 1.0d0 0.0l0))) (or (eqlt m 1.0d0) (eqlt m 1.0l0))) t) (deftest max.26 (max 0.0d0 1.0l0) 1.0l0) (deftest max.27 (loop for i from 1 to (min 256 (1- call-arguments-limit)) for x = (make-list i :initial-element 0) do (setf (elt x (random i)) 1) unless (eql (apply #'max x) 1) collect x) nil) (deftest max.28 (let ((m (max 1/3 0.2s0))) (or (eqlt m 1/3) (eqlt m (float 1/3 0.2s0)))) t) (deftest max.29 (let ((m (max 1.0s0 3 2.0f0))) (or (eqlt m 3) (eqlt m 3.0f0))) t) (deftest max.30 (let ((m (max 1.0d0 3 2.0f0))) (or (eqlt m 3) (eqlt m 3.0d0))) t) (deftest max.31 (let ((m (max 1.0s0 3 2.0l0))) (or (eqlt m 3) (eqlt m 3.0l0))) t) (deftest max.32 (let ((m (max 1.0l0 3 2.0s0))) (or (eqlt m 3) (eqlt m 3.0l0))) t) (deftest max.33 (let ((m (max 1.0d0 3 2.0l0))) (or (eqlt m 3) (eqlt m 3.0l0))) t) (deftest max.34 (let ((m (max 1.0l0 3 2.0d0))) (or (eqlt m 3) (eqlt m 3.0l0))) t) (deftest max.order.1 (let ((i 0) x y) (values (max (progn (setf x (incf i)) 10) (progn (setf y (incf i)) 20)) i x y)) 20 2 1 2) (deftest max.order.2 (let ((i 0) x y z) (values (max (progn (setf x (incf i)) 10) (progn (setf y (incf i)) 20) (progn (setf z (incf i)) 30)) i x y z)) 30 3 1 2 3) (deftest max.order.3 (let ((i 0) u v w x y z) (values (max (progn (setf u (incf i)) 10) (progn (setf v (incf i)) 20) (progn (setf w (incf i)) 30) (progn (setf x (incf i)) 10) (progn (setf y (incf i)) 20) (progn (setf z (incf i)) 30)) i u v w x y z)) 30 6 1 2 3 4 5 6) gcl27-2.7.0/ansi-tests/member-if-not.lsp000066400000000000000000000065621454061450500177260ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:39:29 1998 ;;;; Contains: Tests of MEMBER-IF-NOT (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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 tests (deftest member-if-not.error.1 (check-type-error #'(lambda (x) (member-if-not #'identity x)) #'listp) nil) (deftest member-if-not.error.2 (signals-error (member-if-not) program-error) t) (deftest member-if-not.error.3 (signals-error (member-if-not #'null) program-error) t) (deftest member-if-not.error.4 (signals-error (member-if-not #'null '(a b c) :bad t) program-error) t) (deftest member-if-not.error.5 (signals-error (member-if-not #'null '(a b c) :bad t :allow-other-keys nil) program-error) t) (deftest member-if-not.error.6 (signals-error (member-if-not #'null '(a b c) :key) program-error) t) (deftest member-if-not.error.7 (signals-error (member-if-not #'null '(a b c) 1 2) program-error) t) (deftest member-if-not.error.8 (signals-error (locally (member-if-not #'identity 'a) t) type-error) t) (deftest member-if-not.error.9 (signals-error (member-if-not #'cons '(a b c)) program-error) t) (deftest member-if-not.error.10 (signals-error (member-if-not #'identity '(a b c) :key #'cons) program-error) t) gcl27-2.7.0/ansi-tests/member-if.lsp000066400000000000000000000065221454061450500171240ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:51:56 2003 ;;;; Contains: Tests of MEMBER-IF (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) ;;; Error cases (deftest member-if.error.1 (check-type-error #'(lambda (x) (member-if #'identity x)) #'listp) nil) (deftest member-if.error.2 (signals-error (member-if) program-error) t) (deftest member-if.error.3 (signals-error (member-if #'null) program-error) t) (deftest member-if.error.4 (signals-error (member-if #'null '(a b c) :bad t) program-error) t) (deftest member-if.error.5 (signals-error (member-if #'null '(a b c) :bad t :allow-other-keys nil) program-error) t) (deftest member-if.error.6 (signals-error (member-if #'null '(a b c) :key) program-error) t) (deftest member-if.error.7 (signals-error (member-if #'null '(a b c) 1 2) program-error) t) (deftest member-if.error.8 (signals-error (locally (member-if #'identity 'a) t) type-error) t) (deftest member-if.error.9 (signals-error (member-if #'cons '(a b c)) program-error) t) (deftest member-if.error.10 (signals-error (member-if #'identity '(a b c) :key #'cons) program-error) t) gcl27-2.7.0/ansi-tests/member.lsp000066400000000000000000000153671454061450500165370ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:38:57 1998 ;;;; Contains: Tests of MEMBER (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) (deftest member.20 (member 10 '(1 2 3 4 10 11 14 18) :test #'<) (11 14 18)) (deftest member.21 (member 10 '(1 2 3 4 10 11 14 18) :test-not #'>=) (11 14 18)) (defharmless member.test-and-test-not.1 (member 'b '(a b c) :test #'eql :test-not #'eql)) (defharmless member.test-and-test-not.2 (member 'b '(a b c) :test-not #'eql :test #'eql)) ;;; 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 (check-type-error #'(lambda (x) (member 'a x)) #'listp) nil) (deftest member.error.2 (signals-error (member 'a 1.3) type-error) t) (deftest member.error.3 (signals-error (member 'a 1) type-error) t) (deftest member.error.4 (signals-error (member 'a 0) type-error) t) (deftest member.error.5 (signals-error (member 'a "abcde") type-error) t) (deftest member.error.6 (signals-error (member 'a #\w) type-error) t) (deftest member.error.7 (signals-error (member 'a t) type-error) t) (deftest member.error.8 (signals-error (member) program-error) t) (deftest member.error.9 (signals-error (member nil) program-error) t) (deftest member.error.10 (signals-error (member nil nil :bad t) program-error) t) (deftest member.error.11 (signals-error (member nil nil :test) program-error) t) (deftest member.error.12 (signals-error (member nil nil :bad t :allow-other-keys nil) program-error) t) (deftest member.error.13 (signals-error (member nil nil nil) program-error) t) (deftest member.error.14 (signals-error (locally (member 'a t) t) type-error) t) (deftest member.error.15 (signals-error (member 'a '(a b c) :test #'identity) program-error) t) (deftest member.error.16 (signals-error (member 'a '(a b c) :test-not #'identity) program-error) t) (deftest member.error.17 (signals-error (member 'a '(a b c) :key #'cons) program-error) t) gcl27-2.7.0/ansi-tests/merge-pathnames.lsp000066400000000000000000000102741454061450500203350ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Dec 31 11:25:55 2003 ;;;; Contains: Tests of MERGE-PATHNAMES (in-package :cl-test) #| (defun merge-pathnames-test (&rest args) (assert (<= 1 (length args) 3)) (let* ((p1 (car args)) (p2 (if (cdr args) (cadr args) *default-pathname-defaults*)) (default-version (if (cddr args) (caddr args) :newest)) (results (multiple-value-list (apply #'merge-pathnames args)))) (assert (= (length results) 1)) (let ((p3 (first results))) |# (deftest merge-pathnames.1 (let* ((p1 (make-pathname :name "foo")) (p2 (merge-pathnames p1 p1 nil))) (values (equalpt (pathname-name p1) "foo") (if (equalpt p1 p2) t (list p1 p2)))) t t) (deftest merge-pathnames.2 (let* ((p1 (make-pathname :name "foo")) (p2 (merge-pathnames p1 p1))) (values (equalpt (pathname-host p1) (pathname-host p2)) (equalpt (pathname-device p1) (pathname-device p2)) (equalpt (pathname-directory p1) (pathname-directory p2)) (pathname-name p1) (pathname-name p2) (equalpt (pathname-type p1) (pathname-type p2)) (if (pathname-version p1) (equalpt (pathname-version p1) (pathname-version p2)) (equalpt (pathname-version p2) :newest)))) t t t "foo" "foo" t t) (deftest merge-pathnames.3 (let* ((p1 (make-pathname :name "foo")) (p2 (make-pathname :name "bar")) (p3 (merge-pathnames p1 p2))) (values (equalpt (pathname-host p1) (pathname-host p3)) (equalpt (pathname-device p1) (pathname-device p3)) (equalpt (pathname-directory p1) (pathname-directory p3)) (pathname-name p1) (pathname-name p3) (equalpt (pathname-type p1) (pathname-type p3)) (if (pathname-version p1) (equalpt (pathname-version p1) (pathname-version p3)) (equalpt (pathname-version p3) :newest)))) t t t "foo" "foo" t t) (deftest merge-pathnames.4 (let* ((p1 (make-pathname :name "foo")) (p2 (make-pathname :type "lsp")) (p3 (merge-pathnames p1 p2))) (values (equalpt (pathname-host p1) (pathname-host p3)) (equalpt (pathname-device p1) (pathname-device p3)) (equalpt (pathname-directory p1) (pathname-directory p3)) (pathname-name p1) (pathname-type p2) (pathname-type p3) (equalpt (pathname-type p2) (pathname-type p3)) (if (pathname-version p1) (equalpt (pathname-version p1) (pathname-version p3)) (equalpt (pathname-version p3) :newest)))) t t t "foo" "lsp" "lsp" t t) (deftest merge-pathnames.5 (let* ((p1 (make-pathname :name "foo")) (p2 (make-pathname :type "lsp" :version :newest)) (p3 (merge-pathnames p1 p2 nil))) (values (equalpt (pathname-host p1) (pathname-host p3)) (equalpt (pathname-device p1) (pathname-device p3)) (equalpt (pathname-directory p1) (pathname-directory p3)) (pathname-name p1) (pathname-name p3) (pathname-type p2) (pathname-type p3) (equalpt (pathname-version p1) (pathname-version p3)))) t t t "foo" "foo" "lsp" "lsp" t) (deftest merge-pathnames.6 (let* ((p1 (make-pathname)) (p2 (make-pathname :name "foo" :version :newest)) (p3 (merge-pathnames p1 p2 nil))) (values (equalpt (pathname-host p1) (pathname-host p3)) (equalpt (pathname-device p1) (pathname-device p3)) (equalpt (pathname-directory p1) (pathname-directory p3)) (pathname-name p2) (pathname-name p3) (equalpt (pathname-type p2) (pathname-type p3)) (pathname-version p2) (pathname-version p3))) t t t "foo" "foo" t :newest :newest) (deftest merge-pathnames.7 (let* ((p1 (make-pathname)) (p2 *default-pathname-defaults*) (p3 (merge-pathnames p1))) (values (equalpt (pathname-host p1) (pathname-host p3)) (equalpt (pathname-host p2) (pathname-host p3)) (equalpt (pathname-device p2) (pathname-device p3)) (equalpt (pathname-directory p2) (pathname-directory p3)) (equalpt (pathname-name p2) (pathname-name p3)) (equalpt (pathname-type p2) (pathname-type p3)) (cond ((pathname-version p1) (equalpt (pathname-version p1) (pathname-version p3))) ((pathname-version p2) (equalpt (pathname-version p2) (pathname-version p3))) (t (equalpt (pathname-version p3) :newest))))) t t t t t t t) gcl27-2.7.0/ansi-tests/merge.lsp000066400000000000000000000370731454061450500163650ustar00rootroot00000000000000;-*- 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)) (deftest merge-vector.18 (merge '(vector) (list 1 3 10) (list 2 4 6) #'<) #(1 2 3 4 6 10)) (deftest merge-vector.19 (merge '(vector *) (list 1 3 10) (list 2 4 6) #'<) #(1 2 3 4 6 10)) (deftest merge-vector.20 (merge '(vector t) (list 1 3 10) (list 2 4 6) #'<) #(1 2 3 4 6 10)) (deftest merge-vector.21 (merge '(vector * 6) (list 1 3 10) (list 2 4 6) #'<) #(1 2 3 4 6 10)) (deftest merge-vector.22 (merge '(simple-vector) (list 2 4 6) (list 1 3 5) #'<) #(1 2 3 4 5 6)) (deftest merge-vector.23 (merge '(simple-vector *) (list 2 4 6) (list 1 3 5) #'<) #(1 2 3 4 5 6)) (deftest merge-vector.24 (merge '(simple-vector 6) (list 2 4 6) (list 1 3 5) #'<) #(1 2 3 4 5 6)) ;;; 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 (copy-seq "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 (copy-seq "2459"))) (merge 'string x y #'char<)) "12345789") (deftest merge-string.1c (let ((x (copy-seq "1378")) (y (copy-seq "2459"))) (merge 'string x y #'char<)) "12345789") (deftest merge-string.1d (let ((x (copy-seq "1378")) (y (copy-seq "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") (deftest merge-string.19 (do-special-strings (s "ace" nil) (assert (string= (merge 'string s (copy-seq "bdf") #'char<) "abcdef"))) nil) (deftest merge-string.20 (do-special-strings (s "ace" nil) (assert (string= (merge 'base-string (copy-seq "bdf") s #'char<) "abcdef"))) nil) (deftest merge-string.21 (do-special-strings (s "ace" nil) (assert (string= (merge 'simple-string s (copy-seq "bdf") #'char<) "abcdef"))) nil) (deftest merge-string.22 (do-special-strings (s "ace" nil) (assert (string= (merge 'simple-base-string s (copy-seq "bdf") #'char<) "abcdef"))) nil) (deftest merge-string.23 (do-special-strings (s "ace" nil) (assert (string= (merge '(vector character) s (copy-seq "bdf") #'char<) "abcdef"))) nil) (deftest merge-string.24 (merge '(string) (copy-seq "ace") (copy-seq "bdf") #'char<) "abcdef") (deftest merge-string.25 (merge '(string *) (copy-seq "ace") (copy-seq "bdf") #'char<) "abcdef") (deftest merge-string.26 (merge '(string 6) (copy-seq "ace") (copy-seq "bdf") #'char<) "abcdef") (deftest merge-string.27 (merge '(simple-string) (copy-seq "ace") (copy-seq "bdf") #'char<) "abcdef") (deftest merge-string.28 (merge '(simple-string *) (copy-seq "ace") (copy-seq "bdf") #'char<) "abcdef") (deftest merge-string.29 (merge '(simple-string 6) (copy-seq "ace") (copy-seq "bdf") #'char<) "abcdef") (deftest merge-string.30 (merge '(base-string) (copy-seq "ace") (copy-seq "bdf") #'char<) "abcdef") (deftest merge-string.31 (merge '(base-string *) (copy-seq "ace") (copy-seq "bdf") #'char<) "abcdef") (deftest merge-string.32 (merge '(base-string 6) (copy-seq "ace") (copy-seq "bdf") #'char<) "abcdef") (deftest merge-string.33 (merge '(simple-base-string) (copy-seq "ace") (copy-seq "bdf") #'char<) "abcdef") (deftest merge-string.34 (merge '(simple-base-string *) (copy-seq "ace") (copy-seq "bdf") #'char<) "abcdef") (deftest merge-string.35 (merge '(simple-base-string 6) (copy-seq "ace") (copy-seq "bdf") #'char<) "abcdef") ;;; 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)) (merge 'symbol (list 1 2 3) (list 4 5 6) #'<))) (error () :caught)) :caught) (deftest merge.error.2 (signals-error (merge '(vector * 3) (list 1 2 3) (list 4 5 6) #'<) type-error) t) (deftest merge.error.3 (signals-error (merge '(bit-vector 3) (list 0 0 0) (list 1 1 1) #'<) type-error) t) (deftest merge.error.4 (signals-error (merge '(vector * 7) (list 1 2 3) (list 4 5 6) #'<) type-error) t) (deftest merge.error.5 (signals-error (merge '(bit-vector 7) (list 0 0 0) (list 1 1 1) #'<) type-error) t) (deftest merge.error.6 (signals-error (merge 'null (list 1 2 3) (list 4 5 6) #'<) type-error) t) (deftest merge.error.7 (signals-error (merge) program-error) t) (deftest merge.error.8 (signals-error (merge 'list) program-error) t) (deftest merge.error.9 (signals-error (merge 'list (list 2 4 6)) program-error) t) (deftest merge.error.10 (signals-error (merge 'list (list 2 4 6) (list 1 3 5)) program-error) t) (deftest merge.error.11 (signals-error (merge 'list (list 2 4 6) (list 1 3 5) #'< :bad t) program-error) t) (deftest merge.error.12 (signals-error (merge 'list (list 2 4 6) (list 1 3 5) #'< :key) program-error) t) (deftest merge.error.13 (signals-error (merge 'list (list 2 4 6) (list 1 3 5) #'< :bad t :allow-other-keys nil) program-error) t) (deftest merge.error.14 (signals-error (merge 'list (list 2 4 6) (list 1 3 5) #'< 1 2) program-error) t) (deftest merge.error.15 (signals-error (locally (merge '(vector * 3) (list 1 2 3) (list 4 5 6) #'<) t) type-error) t) (deftest merge.error.16 (signals-error (merge 'list (list 1 2) (list 3 4) #'car) program-error) t) (deftest merge.error.17 (signals-error (merge 'list (list 'a 'b) (list 3 4) #'max) type-error) t) gcl27-2.7.0/ansi-tests/method-qualifiers.lsp000066400000000000000000000023421454061450500206770ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 11 07:14:12 2003 ;;;; Contains: Tests of METHOD-QUALIFIERS (in-package :cl-test) (defgeneric mq-generic-function (x)) (defparameter *mq-method-1* (defmethod mq-generic-function ((x integer)) (1+ x))) (deftest method-qualifiers.1 (method-qualifiers *mq-method-1*) nil) (defclass mq-class-01 () (a b c)) (defparameter *mq-method-2* (defmethod mq-generic-function :before ((x mq-class-01)) 'foo)) (deftest method-qualifiers.2 (method-qualifiers *mq-method-2*) (:before)) (defclass mq-class-02 () (e f g)) (defparameter *mq-method-3* (defmethod mq-generic-function :after ((x mq-class-02)) 'foo)) (deftest method-qualifiers.3 (method-qualifiers *mq-method-3*) (:after)) (defclass mq-class-03 () (h i j)) (defparameter *mq-method-4* (defmethod mq-generic-function :around ((x mq-class-03)) 'foo)) (deftest method-qualifiers.4 (method-qualifiers *mq-method-4*) (:around)) ;;; Need tests on user-defined method combinations (deftest method-qualifiers.error.1 (signals-error (method-qualifiers) program-error) t) (deftest method-qualifiers.error.2 (signals-error (method-qualifiers *mq-method-4* nil) program-error) t) gcl27-2.7.0/ansi-tests/min.lsp000066400000000000000000000101641454061450500160410ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Aug 4 21:24:45 2003 ;;;; Contains: Tests of MIN (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (deftest min.error.1 (signals-error (min) program-error) t) (deftest min.error.2 (check-type-error #'min #'realp) nil) (deftest min.error.3 (check-type-error #'(lambda (x) (min 0 x)) #'realp) nil) (deftest min.1 (loop for n in *reals* when (or (not (eql (min n) n)) (not (eql (min n n) n)) (not (eql (min n n n) n)) (not (eql (apply #'min (make-list (min 256 (1- call-arguments-limit)) :initial-element n)) n))) collect n) nil) (deftest min.2 (min.2-fn) nil) (deftest min.3 (loop for x = (- (random 60000) 30000) for y = (- (random 60000) 30000) for m = (min x y) for m2 = (if (<= x y) x y) repeat 1000 unless (eql m m2) collect (list x y m m2)) nil) (deftest min.4 (loop for x = (- (random 6000000) 3000000) for y = (- (random 6000000) 3000000) for m = (min x y) for m2 = (if (<= x y) x y) repeat 1000 unless (eql m m2) collect (list x y m m2)) nil) (deftest min.5 (loop for x = (- (random 1000000000000) 500000000000) for y = (- (random 1000000000000) 500000000000) for m = (min x y) for m2 = (if (<= x y) x y) repeat 1000 unless (eql m m2) collect (list x y m m2)) nil) (deftest min.6 (let ((m (min 0 1.0s0))) (or (eqlt m 0) (eqlt m 0.0s0))) t) (deftest min.7 (min 2 1.0s0) 1.0s0) (deftest min.8 (let ((m (min 2 3.0f0))) (or (eqlt m 2) (eqlt m 2.0f0))) t) (deftest min.9 (min 2 1.0f0) 1.0f0) (deftest min.10 (let ((m (min 2 10.0d0))) (or (eqlt m 2) (eqlt m 2.0d0))) t) (deftest min.11 (min 100 1.0d0) 1.0d0) (deftest min.12 (let ((m (min 2 17.25l0))) (or (eqlt m 2) (eqlt m 2.0l0))) t) (deftest min.13 (min 2 1.0l0) 1.0l0) (deftest min.15 (let ((m (min 1.0s0 2.0f0))) (or (eqlt m 1.0s0) (eqlt m 1.0f0))) t) (deftest min.16 (min 3.0s0 1.0f0) 1.0f0) (deftest min.17 (let ((m (min 1.0s0 2.0d0))) (or (eqlt m 1.0s0) (eqlt m 1.0d0))) t) (deftest min.18 (min 5.0s0 1.0d0) 1.0d0) (deftest min.19 (let ((m (min 1.0s0 2.0l0))) (or (eqlt m 1.0s0) (eqlt m 1.0l0))) t) (deftest min.20 (min 2.0s0 1.0l0) 1.0l0) (deftest min.21 (let ((m (min 1.0f0 2.0d0))) (or (eqlt m 1.0f0) (eqlt m 1.0d0))) t) (deftest min.22 (min 18.0f0 1.0d0) 1.0d0) (deftest min.23 (let ((m (min 1.0f0 100.0l0))) (or (eqlt m 1.0f0) (eqlt m 1.0l0))) t) (deftest min.24 (min 19.0f0 1.0l0) 1.0l0) (deftest min.25 (let ((m (min 1.0d0 12.0l0))) (or (eqlt m 1.0d0) (eqlt m 1.0l0))) t) (deftest min.26 (min 15.0d0 1.0l0) 1.0l0) (deftest min.27 (loop for i from 1 to (min 256 (1- call-arguments-limit)) for x = (make-list i :initial-element 1) do (setf (elt x (random i)) 0) unless (eql (apply #'min x) 0) collect x) nil) (deftest min.28 (let ((m (min 1/3 0.8s0))) (or (eqlt m 1/3) (eqlt m (float 1/3 0.8s0)))) t) (deftest min.29 (let ((m (min 1.0s0 -3 2.0f0))) (or (eqlt m -3) (eqlt m -3.0f0))) t) (deftest min.30 (let ((m (min 1.0d0 -3 2.0f0))) (or (eqlt m -3) (eqlt m -3.0d0))) t) (deftest min.31 (let ((m (min 1.0s0 -3 2.0l0))) (or (eqlt m -3) (eqlt m -3.0l0))) t) (deftest min.32 (let ((m (min 1.0l0 -3 2.0s0))) (or (eqlt m -3) (eqlt m -3.0l0))) t) (deftest min.33 (let ((m (min 1.0d0 -3 2.0l0))) (or (eqlt m -3) (eqlt m -3.0l0))) t) (deftest min.34 (let ((m (min 1.0l0 -3 2.0d0))) (or (eqlt m -3) (eqlt m -3.0l0))) t) (deftest min.order.1 (let ((i 0) x y) (values (min (progn (setf x (incf i)) 10) (progn (setf y (incf i)) 20)) i x y)) 10 2 1 2) (deftest min.order.2 (let ((i 0) x y z) (values (min (progn (setf x (incf i)) 10) (progn (setf y (incf i)) 20) (progn (setf z (incf i)) 30)) i x y z)) 10 3 1 2 3) (deftest min.order.3 (let ((i 0) u v w x y z) (values (min (progn (setf u (incf i)) 10) (progn (setf v (incf i)) 20) (progn (setf w (incf i)) 30) (progn (setf x (incf i)) 10) (progn (setf y (incf i)) 20) (progn (setf z (incf i)) 30)) i u v w x y z)) 10 6 1 2 3 4 5 6) gcl27-2.7.0/ansi-tests/minus.lsp000066400000000000000000000107051454061450500164120ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 31 11:15:14 2003 ;;;; Contains: Tests of the - function (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (deftest minus.error.1 (signals-error (-) program-error) t) ;;; Unary minus tests (deftest minus.1 (loop for x in *numbers* unless (eql (- (- x)) x) collect x) nil) (deftest minus.2 (locally (declare (notinline -)) (loop for x in *numbers* unless (eql (- (- x)) x) collect x)) nil) (deftest minus.3 (loop for x in *reals* when (and (integerp x) (not (eql (- x) (- 0 x)))) collect x) nil) (deftest minus.4 (loop for x in *reals* for neg = (- x) when (and (floatp x) (not (zerop x)) (not (eql neg (- 0.0s0 x))) (eql (float 1.0s0 x) (float 1.0s0 neg))) collect x) nil) (deftest minus.5 (loop for x in *numbers* when (and (complexp x) (rationalp (realpart x)) (not (eql (- x) (- 0 x)))) collect x) nil) (deftest minus.6 (loop for x in *numbers* for neg = (- x) when (and (complexp x) (floatp (realpart x)) (eql (float 1.0s0 (realpart x)) (float 1.0s0 (realpart neg))) (or (/= neg (- 0 x)) (and (not (zerop (realpart x))) (not (eqlzt neg (- 0 x)))))) collect x) nil) (deftest minus.7 (let ((upper-bound most-positive-fixnum) (lower-bound most-negative-fixnum)) (loop for x = (+ (random (- upper-bound lower-bound)) lower-bound) for neg = (- x) repeat 1000 unless (and (integerp neg) (eql (abs x) (abs neg)) (if (> x 0) (< neg 0) (>= neg 0)) (zerop (+ x neg)) (eql x (- neg))) collect x)) nil) (deftest minus.8 (let ((upper-bound (ash 1 1000)) (lower-bound (- (ash 1 1000)))) (loop for x = (+ (random (- upper-bound lower-bound)) lower-bound) for neg = (- x) repeat 1000 unless (and (integerp neg) (eql (abs x) (abs neg)) (if (> x 0) (< neg 0) (>= neg 0)) (zerop (+ x neg)) (eql x (- neg))) collect x)) nil) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest minus.9 (macrolet ((%m (z) z)) (- (expand-in-current-env (%m 1)))) -1) ;;; Binary minus tests (deftest subtract.1 (loop for x = (random-fixnum) for y = (random-fixnum) repeat 1000 unless (and (eql (+ x (- y)) (- x y)) (eql (+ 1 x (- y)) (- x (1- y))) (eql (+ -1 x (- y)) (- x (1+ y)))) collect (list x y)) nil) (deftest subtract.2 (let ((bound (ash 1 1000))) (loop for x = (random-from-interval bound (- bound)) for y = (random-from-interval bound (- bound)) repeat 1000 unless (and (eql (+ x (- y)) (- x y)) (eql (+ 1 x (- y)) (- x (1- y))) (eql (+ -1 x (- y)) (- x (1+ y)))) collect (list x y))) nil) (deftest subtract.3 (let ((args nil)) (loop for i from 1 below (min 256 (1- call-arguments-limit)) do (push 1 args) always (eql (apply #'- 1000 args) (- 1000 i)))) t) ;;; Float contagion (deftest subtract.4 (loop for type1 in '(short-float single-float double-float long-float) for bits1 in '(13 24 50 50) for bound1 = (ash 1 (- bits1 2)) for c1 from 1 nconc (loop for type2 in '(short-float single-float double-float long-float) for bits2 in '(13 24 50 50) for bound2 = (ash 1 (- bits2 2)) for c2 from 1 nconc (loop for i = (random-from-interval bound1) for x = (coerce i type1) for j = (random-from-interval bound2) for y = (coerce j type2) for idiff1 = (- i j) for idiff2 = (- j i) for diff1 = (- x y) for diff2 = (- y x) repeat 1000 unless (or (zerop idiff1) (and (eql idiff1 (- idiff2)) (eql diff1 (- diff2)) (if (<= c1 c2) (eql (float diff1 y) diff1) (eql (float diff1 x) diff1)) (eql (float idiff1 diff1) diff1))) collect (list i x j y idiff1 idiff2 diff1 diff2)))) nil) ;;; Complex subtraction (deftest subtract.5 (loop for i = (random-fixnum) for ci = (complex i (+ i 100)) for j = (random-fixnum) for cj = (complex j (- j 200)) for diff = (- ci cj) repeat 1000 unless (eql diff (complex (- i j) (+ (- i j) 300))) collect (list i ci j cj (- ci cj))) nil) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest subtract.6 (macrolet ((%m (z) z)) (values (- (expand-in-current-env (%m 2)) 1) (- 17 (expand-in-current-env (%m 5))) (- 1/2 (expand-in-current-env (%m 1/6)) (expand-in-current-env (%m 0))))) 1 12 1/3) gcl27-2.7.0/ansi-tests/minusp.lsp000066400000000000000000000023121454061450500165650ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Aug 4 21:33:44 2003 ;;;; Contains: Tests of MINUSP (in-package :cl-test) (deftest minusp.error.1 (signals-error (minusp) program-error) t) (deftest minusp.error.2 (signals-error (minusp 0 0) program-error) t) (deftest minusp.error.3 (signals-error (minusp 0 nil) program-error) t) (deftest minusp.error.4 (check-type-error #'minusp #'realp) nil) (deftest minusp.1 (minusp 0) nil) (deftest minusp.2 (notnot-mv (minusp -1)) t) (deftest minusp.3 (minusp 1) nil) (deftest minusp.4 (loop for x in *reals* when (if (minusp x) (>= x 0) (< x 0)) collect x) nil) (deftest minusp.5 (some #'minusp '(-0.0s0 -0.0f0 -0.0d0 -0.0l0)) nil) (deftest minusp.6 (remove-if #'minusp (list least-negative-short-float least-negative-normalized-short-float least-negative-single-float least-negative-normalized-single-float least-negative-double-float least-negative-normalized-double-float least-negative-long-float least-negative-normalized-long-float most-negative-short-float most-negative-single-float most-negative-double-float most-negative-long-float)) nil) gcl27-2.7.0/ansi-tests/misc-cmucl-type-prop.lsp000066400000000000000000000244701454061450500212540ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Mar 4 06:21:51 2005 ;;;; Contains: CMUCL type prop failures (moved from misc.lsp) (in-package :cl-test) ;;; All these are 'strange template failures' ;;; The comment before each is the NAME of the template in the backtrace ;;; These tests seem to all have (space 2) (speed 3) ; X86::FAST-LOGAND-C/FIXNUM=>FIXNUM (deftest cmucl-type-prop.1 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 2) (debug 2) (space 3)) (type (member 2 -4 -211907662 -27215198) p1)) (logand (the (integer * 161212781) p1) 10600829))) -27215198) 2129952) ; X86::FAST-LOGAND/SIGNED-UNSIGNED=>UNSIGNED (deftest cmucl-type-prop.2 (funcall (compile nil '(lambda (p1 p2) (declare (optimize (speed 2) (safety 1) (debug 3) (space 3)) (type (integer 1619851121 1619868587) p1) (type (integer * 303689) p2)) (logandc2 (the (integer -5359291650 1619851136) p1) (the unsigned-byte p2)))) 1619851124 300065) 1619551060) ; X86::FAST-LOGIOR-C/FIXNUM=>FIXNUM (deftest cmucl-type-prop.3 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 3) (debug 0) (space 3)) (type (integer 59087 63964) p1)) (logior p1 -65887623))) 59967) -65869185) ; X86::FAST-LOGIOR/FIXNUM=>FIXNUM (deftest cmucl-type-prop.4 (funcall (compile nil '(lambda (p1 p2) (declare (optimize (speed 2) (safety 2) (debug 0) (space 3)) (type (integer 3585942 72924743) p1) (type (integer -70689 *) p2)) (logorc2 (the (integer * 8514860) p1) (the (integer 1 411) p2)))) 3586455 4) -1) ; X86::FAST-LOGAND-C/SIGNED=>SIGNED (deftest cmucl-type-prop.5 (funcall (compile nil '(lambda (p2) (declare (optimize (speed 2) (safety 1) (debug 2) (space 3)) (type (integer -257 *) p2)) (lognand 1020158769 (the (integer -5275217 2381998) p2)))) 2) -1) ; X86::FAST-LOGAND-C/SIGNED-UNSIGNED=>UNSIGNED (deftest cmucl-type-prop.6 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 1) (debug 0) (space 3)) (type (integer -96413017 -96297711) p1)) (lognand p1 3472289945))) -96413016) -3393245321) ; X86::FAST-LOGAND/UNSIGNED-SIGNED=>UNSIGNED (deftest cmucl-type-prop.7 (funcall (compile nil '(lambda (p1 p2) (declare (optimize (speed 2) (safety 3) (debug 2) (space 3)) (type (integer 438294 891242) p1) (type (member 16317 -15 -541332155 33554427) p2)) (logand (the (integer -33116139 1759877902) p1) p2))) 438295 16317) 12309) ; X86::FAST-LOGIOR-C/SIGNED=>SIGNED (deftest cmucl-type-prop.8 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 1) (debug 1) (space 3)) (type (integer -728025757 -727856169) p1)) (logorc1 (the (integer -734005577 -727855553) p1) -3311))) -727856176) -2241) ; X86::FAST-LOGXOR/FIXNUM=>FIXNUM (deftest cmucl-type-prop.9 (funcall (compile nil '(lambda (p1 p2) (declare (optimize (speed 2) (safety 3) (debug 3) (space 3)) (type (integer * 1489068) p1) (type (integer -7455 *) p2)) (logeqv (the (member 9543 -15 32766 -264472) p1) (the (integer -524303 11182721) p2)))) 9543 -8) 9536) ; X86::FAST-LOGXOR/SIGNED=>SIGNED (deftest cmucl-type-prop.10 (funcall (compile nil '(lambda (p1 p2) (declare (optimize (speed 2) (safety 1) (debug 3) (space 3)) (type (integer -616605365 -616598658) p1) (type (eql 499113) p2)) (logeqv (the real p1) p2))) -616604953 499113) 617035953) ; X86::FAST-LOGXOR-C/FIXNUM=>FIXNUM (deftest cmucl-type-prop.11 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 1) (debug 0) (space 3)) (type (integer -112225610 *) p1)) (logeqv (the (integer -2822315666 3) p1) 1679389))) 1) -1679389) ; X86::FAST-LOGXOR-C/SIGNED=>SIGNED (deftest cmucl-type-prop.12 (funcall (compile nil '(lambda (p2) (declare (optimize (speed 2) (safety 3) (debug 0) (space 3)) (type (integer -67 268435455) p2)) (logeqv 1038360149 (the (integer -3605943309) p2)))) -1) 1038360149) ; X86::-/SINGLE-FLOAT (deftest cmucl-type-prop.13 (notnot (typep (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 2) (debug 1) (space 3)) (type (eql 64848.973) p1)) (- (the (eql 64848.973f0) p1) -2808/1031))) 64848.973f0) 'single-float)) t) ; X86::-/DOUBLE-FLOAT (deftest cmucl-type-prop.14 (notnot (typep (funcall (compile nil '(lambda (p2) (declare (optimize (speed 2) (safety 1) (debug 1) (space 3)) (type (integer 9297 *) p2)) (- 54090.82691488265d0 (the (integer * 1263530808) p2)))) 9590) 'double-float)) t) ; X86::-/SINGLE-FLOAT (deftest cmucl-type-prop.15 (notnot (typep (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 3) (debug 3) (space 3)) (type (eql 328536/53893) p1)) (- p1 59218.633f0))) 328536/53893) 'single-float)) t) ; X86::FAST--/FIXNUM=>FIXNUM (deftest cmucl-type-prop.16 (funcall (compile nil '(lambda (p2) (declare (optimize (speed 2) (safety 2) (debug 3) (space 3)) (type (integer -605782 -28141) p2)) (- -61118 p2))) -28225) -32893) ; X86::FAST---C/FIXNUM=>FIXNUM (deftest cmucl-type-prop.17 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 1) (debug 1) (space 3)) (type (integer 5535202) p1)) (- (the (integer * 27858177) p1) 405))) 5535436) 5535031) ; X86::FAST--/SIGNED=>SIGNED (deftest cmucl-type-prop.18 (funcall (compile nil '(lambda (p2) (declare (optimize (speed 2) (safety 2) (debug 2) (space 3)) (type (integer -1175231414 -3471291) p2)) (- -440 p2))) -3536832) 3536392) ; X86::FAST-+-C/FIXNUM=>FIXNUM (deftest cmucl-type-prop.19 (funcall (compile nil '(lambda (p2) (declare (optimize (speed 2) (safety 3) (debug 2) (space 3)) (type (integer -1015240116 5) p2)) (+ 491841 (the unsigned-byte p2)))) 0) 491841) ; X86::+/DOUBLE-FLOAT (deftest cmucl-type-prop.20 (notnot (typep (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 3) (debug 3) (space 3)) (type (rational -1255531/68466 4) p1)) (+ p1 41888.98682005542d0))) -1255531/68466) 'double-float)) t) ; X86::+/SINGLE-FLOAT (deftest cmucl-type-prop.21 (notnot (typep (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 2) (debug 1) (space 3)) (type (integer -284887911 *) p1)) (+ (the (integer -50006902 19512639861) p1) 68648.28f0))) -16452463) 'single-float)) t) ; X86::=0/DOUBLE-FLOAT (deftest cmucl-type-prop.22 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 3) (debug 1) (space 3)) (type (complex double-float) p1)) (= p1 -1590311/896933))) #c(1.0d0 1.0d0)) nil) ; X86::=/SINGLE-FLOAT (deftest cmucl-type-prop.23 (funcall (compile nil '(lambda (p2) (declare (optimize (speed 2) (safety 2) (debug 1) (space 3)) (type (complex single-float) p2)) (= -976855 (the (eql #c(-57420.04 806984.0)) p2)))) #c(-57420.04f0 806984.0f0)) nil) ; X86::FAST-EQL/FIXNUM (deftest cmucl-type-prop.24 (notnot (funcall (compile nil '(lambda (p1 p2) (declare (optimize (speed 2) (safety 1) (debug 3) (space 3)) (type (integer -3705845 488458) p1) (type (integer * 869076010) p2)) (/= p1 (the (integer -69832764 470) p2)))) 488456 465)) t) ; X86::FAST-EQL-C/FIXNUM (deftest cmucl-type-prop.25 (notnot (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 3) (debug 2) (space 3)) (type (integer -69741922) p1)) (/= (the (integer * 216) p1) 182))) 103)) t) ; X86::FAST-IF->-C/FIXNUM (deftest cmucl-type-prop.26 (funcall (compile nil '(lambda (p2) (declare (optimize (speed 2) (safety 2) (debug 3) (space 3)) (type (integer -451 204073899) p2)) (< 134799 (the (integer -56 8589934581) p2)))) -2) nil) ; X86::FAST-IF-<-C/FIXNUM (deftest cmucl-type-prop.27 (funcall (compile nil '(lambda (p2) (declare (optimize (speed 2) (safety 2) (debug 2) (space 3)) (type (integer -93662 *) p2)) (<= -1 (the (integer -2975848 16770677) p2)))) -6548) nil) ; X86::FAST-+-C/FIXNUM=>FIXNUM ; (simple example) (deftest cmucl-type-prop.28 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 1) (debug 0) (space 3)) (type (integer -65545 80818) p1)) (1+ p1))) -1) 0) ; X86::FAST-NEGATE/FIXNUM (deftest cmucl-type-prop.29 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 1) (debug 0) (space 3)) (type (integer -4194320 11531) p1)) (- (the (integer -6253866924 34530147) p1)))) -20) 20) ;;; Bug in COPY-SEQ (deftest cmucl-type-prop.30 (let ((a (funcall (compile nil `(lambda () (declare (optimize (speed 2) (safety 2) (debug 0) (space 2))) (copy-seq ,(make-array '(0) :adjustable t))))))) (and (not (adjustable-array-p a)) (= (length a) 0) t)) t) ; Bug for PACKAGEP (deftest cmucl-type-prop.31 (funcall (compile nil '(lambda (x) (declare (optimize (speed 2) (space 3))) (packagep x))) t) nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; There were many failures in string comparison functions ;;; Some are that C::WIN strange template problem, but others ;;; are not. ;;; 0 is not of type (INTEGER 0 (0)) (deftest cmucl-type-prop.32 (funcall (compile nil '(lambda (p4) (declare (optimize (speed 1) (safety 1) (debug 1) (space 0)) (type (integer -2040 9) p4)) (string< "bbaa" "" :start1 p4))) 2) nil) ;;; 2 is not of type (INTEGER 0 (2)) (deftest cmucl-type-prop.33 (funcall (compile nil '(lambda (p4) (declare (optimize (speed 0) (safety 0) (debug 2) (space 0)) (type (integer -52340 *) p4)) (string< "baabbb" "bb" :start2 p4))) 1) nil) ;;; Incorrect return value (deftest cmucl-type-prop.34 (funcall (compile nil '(lambda (p1 p4) (declare (optimize (speed 2) (safety 0) (debug 3) (space 0)) (type (simple-string) p1) (type real p4)) (string< (the array p1) "bbbba" :start1 (the (integer -16382 *) p4) :end1 7))) "J4sPI71C3Xn" 5) 5) gcl27-2.7.0/ansi-tests/misc.lsp000066400000000000000000013153471454061450500162250ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 20 09:45:15 2003 ;;;; Contains: Miscellaneous tests ;;; ;;; This file contains odds-and-ends, mostly tests that came up as ;;; bug-stimulators in various implementations. ;;; (in-package :cl-test) (declaim (special *s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8*)) (deftest misc.1 (funcall (compile nil '(lambda (b) (declare (type (integer 8 22337) b)) (+ b 2607688420))) 100) 2607688520) (deftest misc.2 (funcall (compile nil '(lambda (b) (integer-length (dpb b (byte 4 28) -1005)))) 12800263) 32) (deftest misc.3 (funcall (compile nil '(lambda (a b) (declare (optimize (speed 3) (debug 1))) (let ((v7 (let ((v2 (block b5 (return-from b5 (if t b -4))))) a))) -65667836))) 1 2) -65667836) (deftest misc.4 (funcall (compile nil '(lambda (a b c) (declare (type (integer -629491 -333) a) (type (integer -142 1) b) (type (integer 0 12604) c) (optimize (speed 3) (safety 1) (debug 1))) (let ((v6 (block b7 (return-from b7 (if (eql b 0) 1358159 a))))) b))) -1000 -17 6143) -17) (deftest misc.5 (funcall (compile nil '(lambda () (* 390 (- (signum (logeqv -8005440 -2310)) -10604863))))) 4135896180) (deftest misc.6 (funcall (compile nil '(lambda (a c) (declare (optimize (speed 3) (debug 1))) (flet ((%f14 () (if c a -486826646))) (let ((v7 (flet ((%f18 () (%f14))) a))) (let ((v5 (%f14))) 0))))) 10 20) 0) (deftest misc.7 (funcall (compile nil '(lambda (c) (declare (optimize (speed 3) (debug 1))) (flet ((%f18 () -36)) (flet ((%f13 () (let () (block b8 (return-from b8 c))))) (%f18))))) 10) -36) (deftest misc.8 (funcall (compile nil '(lambda (a b) (declare (optimize (speed 3) (debug 1))) (let ((v3 (flet ((%f12 () (min b (block b2 (return-from b2 a))))) a))) (block b7 (flet ((%f5 () (return-from b7 b))) (%f5)))))) 10 20) 20) (deftest misc.9 (funcall (compile nil '(lambda () (declare (optimize (speed 3) (debug 1))) (block b6 (flet ((%f3 () (ldb (byte 19 23) (block b1 (let () (- (if nil (return-from b6 89627) 1160) (return-from b1 22923))))))) 1))))) 1) (deftest misc.10 (funcall (compile nil '(lambda (c) (declare (optimize (speed 3) (debug 1)) (type (integer -15417757 5816) c)) (flet ((%f3 () (if nil -3143 c))) (block b5 (let ((v7 (if (< 23613642 (%f3)) c -23097977))) (let ((v5 (return-from b5 (if (eql c v7) (let ((v6 (%f3))) 4650813) 782)))) -4362540)))))) -10000) 782) (deftest misc.11 (funcall (compile nil '(lambda (a b c) (declare (optimize (speed 3) (debug 1))) (block b8 (logxor (let ((v3 (return-from b8 120789657))) 3690) (block b2 (flet ((%f9 () (flet ((%f10 () -1)) c))) (flet ((%f3 () (let () (return-from b2 b)))) a))))))) 1 2 3) 120789657) (deftest misc.12 (funcall (compile nil '(lambda (c) (declare (optimize (speed 3) (safety 1) (debug 1)) (type (integer -171067 -5) c)) (flet ((%f16 () (flet ((%f12 () 439)) 3358))) (flet ((%f14 () c)) (if (%f14) -1 (%f14)))))) -100) -1) (deftest misc.13 (funcall (compile nil '(lambda (b c) (declare (optimize (speed 3) (safety 1) (debug 1)) (type (integer -1554410 36086789) b) (type (integer -15033876209 126774299) c) ) (block b3 (flet ((%f9 () (abs (flet ((%f5 () (return-from b3 -2))) (if (if (<= 1 c) b (%f5)) -65 -47895812))))) (min (let ((v3 (let ((v8 (%f9))) b))) b) (if (= 1364001 (%f9)) (logeqv (block b5 -2713) -247) -19)))))) 0 0) -2) (deftest misc.14 (funcall (compile nil '(lambda (c) (declare (notinline logandc1)) (block b6 (flet ((%f17 () (return-from b6 c))) (logandc1 (%f17) (if 1 450967818 (let ((v1 (%f17))) -17))))))) 10) 10) (deftest misc.15 (funcall (compile nil '(lambda (a b) (declare (optimize (speed 3) (safety 1) (debug 1))) (flet ((%f6 () a)) (block b5 (flet ((%f14 () (min 17593 (block b1 (return-from b1 b))))) (block b7 (if (%f6) (return-from b7 28182012) (return-from b5 0)))))))) 3 5) 28182012) (deftest misc.16 (funcall (compile nil '(lambda (a c) (flet ((%f14 () (block b6 (flet ((%f7 () (return-from b6 4))) (if 587793 (if (%f7) c -23086423) (%f7)))))) (block b1 (flet ((%f18 () a)) (logandc1 (return-from b1 -2781) (if (%f14) 58647578 -396746))))))) 1 2) -2781) (deftest misc.17 (funcall (compile nil '(lambda (a b c) (declare (optimize (speed 3) (safety 1) (debug 1)) (type (integer 4 23363) b) (type (integer -32681 41648) c) ) (flet ((%f18 () (if nil c b))) (if (if (> -71810514 a) 102077 465393) (block b3 (if (%f18) (return-from b3 c) c)) (%f18))))) 0 10 1000) 1000) (deftest misc.18 (funcall (compile nil '(lambda (a b c) (declare (optimize (speed 3) (safety 1) (debug 1)) (type (integer 7 58010860) a) (type (integer -3573280 -1) b) (type (integer -920848 -819) c) ) (flet ((%f15 () (if (logbitp 5 a) a c))) (min (if (%f15) b -39) (if (> 0 -14756) b (%f15)))))) 8 -1000 -10000) -1000) (deftest misc.19 (funcall (compile nil '(lambda (a b c) (declare (type (integer 54 3862515) a) (type (integer -961325 1539) b) (type (integer 6 31455) c) (ignorable a b c) (optimize (speed 3) (safety 1) (debug 1))) (lognor (flet ((%f13 () b)) (%f13)) (flet ((%f1 () (return-from %f1 a))) (labels ((%f3 () (%f1))) -428))))) 100 0 200) 427) (deftest misc.20 (funcall (compile nil '(lambda (a b c) (declare (type (integer -1 31880308) a) (type (integer -11374222037 5331202966) b) (type (integer -483 -1) c) (ignorable a b c) (optimize (speed 3) (safety 1) (debug 1))) (labels ((%f6 () a)) (if (eql (let ((v9 (%f6))) -50072824) c) 28146341 (if (< 119937 21304962) 21304962 (%f6)))))) 0 0 -1) 21304962) (deftest misc.21 (funcall (compile nil '(lambda (a b c) (declare (type (integer 398 3955) a) (type (integer 233 464963) b) (type (integer -124477 16) c) (ignorable a b c) (optimize (speed 3) (safety 1) (debug 1))) (logior (flet ((%f18 () -3584768)) (%f18)) (flet ((%f1 () (return-from %f1 c))) (flet ((%f9 () (if (%f1) 24181 7))) 56048))))) 400 300 0) -3547152) (deftest misc.22 (funcall (compile nil '(lambda (a b c) (declare (type (integer -126378 -103) a) (type (integer -1158604975 1) b) (type (integer 502 28036) c) (ignorable a b c) (optimize (speed 3) (safety 1) (debug 1))) (labels ((%f13 () c)) (labels ((%f3 () (logandc1 c (block b6 (max -73100 (if b (return-from b6 4935) (%f13))))))) (%f13))))) -200 0 1000) 1000) (deftest misc.23 (funcall (compile nil '(lambda (a b c) (declare (type (integer 1 18911480) a) (type (integer -1 48333) b) (type (integer -3881001767 -1937357) c) (ignorable a b c) (optimize (speed 3) (safety 1) (debug 1))) (labels ((%f10 () c)) (block b7 (logorc2 (* (%f10) (if (ldb-test (byte 27 1) -11337) (return-from b7 -2) 246137101)) (min (%f10) (return-from b7 -76114))))))) 1 0 -2000000) -2) (deftest misc.24 (funcall (compile nil '(lambda (a b c) (declare (type (integer -1477249397 -10697252) a) (type (integer -7 54591) b) (type (integer -102559556 15) c) (ignorable a b c) (optimize (speed 3) (safety 1) (debug 1))) (block b8 (let ((v1 (return-from b8 a))) (1+ (block b3 (flet ((%f10 () (min a (return-from b3 -1)))) 16776220))))))) -11000000 0 0) -11000000) (deftest misc.25 (funcall (compile nil '(lambda (a b c) (declare (type (integer -944 111244) a) (type (integer 100512 3286178) b) (type (integer -2170236 -107) c) (ignorable a b c) (optimize (speed 3) (safety 1) (debug 1))) (labels ((%f17 () c)) (labels ((%f16 () a)) (if (if (logbitp 10 1029643) t 355) (if (equal (%f17) b) c a) (if (= 1325844 (%f16)) -50285 (1- (%f17)))))))) 0 200000 -200) 0) (deftest misc.26 (funcall (compile nil '(lambda (c) (declare (optimize speed)) (block b5 (if (logbitp 6 -97) (let ((v2 (block b8 -42484))) c) (flet ((%f10 () (return-from b5 -785143))) (let ((v3 (%f10))) (%f10))))))) 0) -785143) (deftest misc.27 (funcall (compile nil '(lambda (a b c) (declare (optimize (speed 3) (debug 1))) (labels ((%f14 () c)) (logand (%f14) (labels ((%f15 () (logeqv (let ((v1 b)) c) (return-from %f15 -1740)))) (labels ((%f8 () (%f15))) a)))))) 5 2 3) 1) (deftest misc.28 (funcall (compile nil '(lambda (a b c) (declare (type (integer 1948 12024) b) (type (integer -104357939 -252) c) (optimize (speed 3) (debug 1))) (flet ((%f18 () c)) (logandc1 (if (eql b (%f18)) 0 a) (if (ldb-test (byte 30 30) 1) (%f18) 1) )))) 0 2000 -300) 1) (deftest misc.29 (funcall (compile nil '(lambda (a b c) (declare (type (integer 661607 10451683348) a) (type (integer -2 -2) b) (type (integer 5996117 18803237) c) (optimize (speed 3) (safety 1) (debug 1))) (labels ((%f16 () -29)) (flet ((%f7 () (labels ((%f1 () a)) (let () (block b3 (if 37101207 (return-from b3 -5322045) (let ((v5 b)) 146099574))))))) (if (%f16) c c))))) 1000000 -2 6000000) 6000000) (deftest misc.30 (funcall (compile nil '(lambda (c) (declare (type (integer -253 -1) c) (optimize (speed 3) (safety 1) (debug 1))) (flet ((%f8 () c)) (if (= (%f8) 481) (%f8) 1779465)))) -100) 1779465) (deftest misc.31 (funcall (compile nil '(lambda () (let ((v9 (labels ((%f13 () nil)) nil))) (let ((v3 (logandc2 97 3))) (* v3 (- 37391897 (logand v3 -66)))))))) 3589619040) (deftest misc.32 (funcall (compile nil '(lambda (a d) (declare (type (integer -8507 26755) a) (type (integer -393314538 2084485) d) (optimize (speed 3) (safety 1) (debug 1))) (gcd (if (= 0 a) 10 (abs -1)) (logxor -1 (min -7580 (max (logand a 31365125) d)))))) 1 1) 1) (deftest misc.33 (funcall (compile nil '(lambda (a b c d) (declare (type (integer 240 100434465) a) (optimize (speed 3) (safety 1) (debug 1))) (logxor (if (ldb-test (byte 27 4) d) -1 (max 55546856 -431)) (logorc2 (if (>= 0 b) (if (> b c) (logandc2 c d) (if (> d 224002) 0 d)) (signum (logior c b))) (logior a -1))))) 256 0 0 0) 55546856) (deftest misc.34 (funcall (compile nil `(lambda (b c) (declare (type (integer -23228343 2) b) (type (integer -115581022 512244512) c) (optimize (speed 3) (safety 1) (debug 1))) (* (* (logorc2 3 (deposit-field 4667947 (byte 14 26) b)) (deposit-field b (byte 25 27) -30424886)) (dpb b (byte 23 29) c) ))) 0 0) 0) (deftest misc.35 (funcall (compile nil '(lambda (c) (declare (type (integer -5945502333 12668542) c) (optimize (speed 3))) (let ((v2 (* c 12))) (- (max (if (/= 109335113 v2) -26479 v2) (deposit-field 311 (byte 14 28) (min (max 521326 c) -51))))))) 12668542) 26479) (deftest misc.36 (funcall (compile nil '(lambda () (declare (notinline + logand) (optimize (speed 0))) (logand (block b5 (flet ((%f1 () (return-from b5 -220))) (let ((v7 (%f1))) (+ 359749 35728422)))) -24076)))) -24284) (deftest misc.37 (funcall (compile nil '(lambda (b) (declare (notinline -) (optimize (speed 0))) (- (block b4 (flet ((%f4 () (return-from b4 b))) (%f4)))))) 10) -10) (deftest misc.38 (funcall (compile nil '(lambda (x) (declare (type (integer 0 100) x) (optimize (speed 3) (safety 1))) (logandc1 x x))) 79) 0) (deftest misc.39 (funcall (compile nil '(lambda (x) (declare (type (integer 0 100) x) (optimize (speed 3) (safety 1))) (logandc2 x x))) 79) 0) (deftest misc.40 (funcall (compile nil '(lambda (x) (declare (type (integer 0 100) x) (optimize (speed 3) (safety 1))) (logorc1 x x))) 79) -1) (deftest misc.41 (funcall (compile nil '(lambda (x) (declare (type (integer 0 100) x) (optimize (speed 3) (safety 1))) (logorc2 x x))) 79) -1) (deftest misc.42 (funcall (compile nil '(lambda (x) (declare (type (integer -100 100) x)) (ldb (byte 1 32) x))) -1) 1) (deftest misc.43 (funcall (compile nil '(lambda () (flet ((%f2 () 288213285)) (+ (%f2) (* 13 (%f2))))))) 4034985990) (deftest misc.44 (funcall (compile nil '(lambda (a) (declare (type (integer -917858 964754309) a) (optimize (speed 3))) (* 25 (min (max a 171625820) 171626138)))) 861929141) 4290653450) (deftest misc.45 (funcall (compile nil '(lambda (b) (declare (type (integer 21 9673) b) (optimize (speed 3))) (* (integer-length -198435631) (+ b 137206182)))) 6027) 3841941852) (deftest misc.46 (funcall (compile nil '(lambda (b c) (declare (type (integer 0 1) b) (optimize (speed 3))) (flet ((%f2 () (lognor (block b5 138) c))) (if (not (or (= -67399 b) b)) (deposit-field (%f2) (byte 11 8) -3) c)))) 0 0) 0) (deftest misc.47 (funcall (compile nil '(lambda (a) (declare (type (integer -4005718822 -50081775) a) (optimize (speed 3) (safety 1) (debug 1))) (lognor (ash a (min 0 a)) a))) -2878148992) 0) (deftest misc.48 (funcall (compile nil '(lambda (a) (declare (notinline ash min)) (lognor (ash a (min 0 a)) a))) -2878148992) 0) (deftest misc.49 (let ((body '(truncate (logorc1 -996082 C) -2)) (arg 25337234)) (values (funcall (compile nil `(lambda (c) ,body)) arg) (funcall (compile nil `(lambda (c) (declare (notinline truncate)) ,body)) arg))) -13099001 -13099001) (deftest misc.50 (funcall (compile nil `(lambda (c) (declare (optimize (speed 3)) (type (integer 23062188 149459656) c)) (mod c (min -2 0)))) 95019853) -1) (deftest misc.51 (funcall (compile nil `(lambda (b) (declare (optimize (speed 3)) (type (integer 2 152044363) b)) (rem b (min -16 0)))) 108251912) 8) (deftest misc.53 (funcall (compile nil '(lambda () (let (x) (block nil (flet ((%f (y z) (if (> y z) (setq x y) (setq x z)))) (%f 1 2) (%f (return 14) 2))) x)))) 2) (deftest misc.54 (funcall (compile nil '(lambda (a c) (declare (type (integer 8 117873977) a) (type (integer -131828754 234037511) c) (optimize (speed 3) (safety 1) (debug 1))) (* (mod (signum a) (max 50 -358301)) (* -2320445737132 (* (* a (deposit-field a (byte 32 19) a)) c))))) 11386 165297671) -49725654774521915007942373712) (deftest misc.55 (funcall (compile nil '(lambda (a b c) (declare (type (integer -5498929 389890) a) (type (integer -5029571274946 48793670) b) (type (integer 9221496 260169518304) c) (ignorable a b c) (optimize (speed 3) (safety 1) (debug 1))) (- (mod 1020122 (min -49 -420)) (logandc1 (block b2 (mod c (min -49 (if t (return-from b2 1582) b)))) (labels ((%f14 () (mod a (max 76 8)))) b))))) -1893077 -2965238893954 30902744890) 2965238894454) (deftest misc.56 (funcall (compile nil '(lambda (a c) (declare (type (integer -8691408487404 -9) a) (type (integer 266003133 2112105962) c) (optimize (speed 3) (safety 1) (debug 1))) (truncate (max (round a) c) (* (* a a) a)))) -10 266003133) -266003 133) (deftest misc.57 (funcall (compile nil '(lambda (a b c) (declare (type (integer -1907 58388940297) a) (type (integer -646968358 294016) b) (type (integer -708435313 89383896) c) (optimize (speed 3) (safety 1) (debug 1))) (let ((v6 (abs (min a (signum c))))) (if (ceiling v6 (max 77 v6)) b 2)))) 50005747335 -363030456 17382819) -363030456) (deftest misc.58 (funcall (compile nil '(lambda (a) (declare (type (integer -23 66141285) a) (optimize (speed 3))) (logorc2 (setq a 35191330) (* a 107)))) 4099241) -3764388885) (deftest misc.59 (funcall (compile nil '(lambda (a b c) (declare (type (integer -3966039360 -879349) a) (type (integer -62642199164 -8993827395) b) (type (integer -8065934654337 223) c) (optimize (speed 3) (safety 1) (debug 1))) (floor (* (ceiling c) c) (max 78 (* b (* a (* a b))))))) -1000000 -10000000000 0) 0 0) (deftest misc.60 (funcall (compile nil '(lambda () (let ((v5 46660)) (setq v5 (signum (rem v5 (max 53 v5)))))))) 0) (deftest misc.61 (progn (compile nil '(lambda (a b) (declare (type (integer -1785799651 -2) a) (type (integer -27 614132331) b) (optimize (speed 3) (safety 1) (debug 1))) (ceiling (max (floor -733432 (max 84 -20)) 346) (min -10 (* 17592186028032 (* (* a b) a)))))) :good) :good) (deftest misc.62 (funcall (compile nil '(lambda (a) (if (and (if a t nil) nil) a (min (block b5 -1) a)))) 100) -1) ;;; sbcl bug (probably #233) (deftest misc.63 (let* ((form '(flet ((%f12 () (setq c -9868204937))) (if (<= c (%f12)) -2 (if (= c c) b c)))) (form1 `(lambda (b c) (declare (type (integer -80421740610 1395590616) c)) ,form)) (form2 `(lambda (b c) ,form)) (vals '(-696742851945 686256271))) (eqlt (apply (compile nil form1) vals) (apply (compile nil form2) vals))) t) ;;; sbcl bug (probably #233) (deftest misc.64 (let* ((form '(logcount (if (not (> c (let ((v7 (setq c -246180))) -1))) (ldb (byte 24 11) c) c))) (form1 `(lambda (c) (declare (type (integer -256128 207636) c)) ,form)) (form2 `(lambda (c) ,form)) (vals '(11292)) ) (eqlt (apply (compile nil form1) vals) (apply (compile nil form2) vals))) t) ;;; sbcl bug (probably #233) (deftest misc.65 (let ((form1 '(lambda (b c) (declare (type (integer -350684427436 -255912007) b)) (logandc2 c (if (< b (setq b -25647585550)) b 0)))) (form2 '(lambda (b c) (logandc2 c (if (< b (setq b -25647585550)) b 0)))) (vals '(-297090677547 -20121092))) (eqlt (apply (compile nil form1) vals) (apply (compile nil form2) vals))) t) (deftest misc.66 (let* ((form '(if (> a (setq a -2198578292)) (min b (if (<= a -14866) a -128363)) a)) (form1 `(lambda (a b) (declare (type (integer -3709231882 0) a)) (declare (type (integer -562051054 -1) b)) ,form)) (form2 `(lambda (a b) ,form)) (vals '(-2095414787 -256985442))) (eqlt (apply (compile nil form1) vals) (apply (compile nil form2) vals))) t) ;;; sbcl/cmucl bug (on sparc) (deftest misc.67 (funcall (compile nil '(lambda (x) (declare (type (integer 10604862 10604862) x) (optimize speed)) (* x 390))) 10604862) 4135896180) ;;; cmucl bug (cvs, 10/10/2003) (deftest misc.68 (funcall (compile nil '(lambda (b) (flet ((%f8 () (rem b (identity (return-from %f8 0))))) (lognor (%f8) 0)))) 0) -1) (deftest misc.69 (funcall (compile nil '(lambda (b) (flet ((%f11 () (logorc2 (block b1 (let () (return-from b1 b))) -1984))) b))) 0) 0) (deftest misc.70 (funcall (compile nil '(lambda (c) (declare (type (integer 46156191457 126998564334) c)) (truncate c (min -16 186196583)))) 87723029763) -5482689360 3) (deftest misc.71 (funcall (compile nil '(lambda () (block b8 (if (identity (return-from b8 30)) 1 (identity (block b5 (labels ((%f10 () (min -52 (return-from b5 10)))) 20)))))))) 30) (deftest misc.72 (funcall (compile nil '(lambda () (flet ((%f13 () (rem 1 (min 0 (return-from %f13 17))))) (%f13))))) 17) (deftest misc.73 (funcall (compile nil '(lambda (c) (declare (type (integer 46156191457 126998564334) c)) (rem c (min -1 0)))) 87723029763) 0) (deftest misc.74 (funcall (compile nil '(lambda () (declare (optimize (safety 3) (speed 0) (debug 0))) (ash 6916244 (min 42 -185236061640))))) 0) ;;; Unwind-protect bug, from sbcl: ;;; "The value NIL is not of type SB-C::NODE." (deftest misc.75 (funcall (compile nil '(lambda () (flet ((%f12 () (unwind-protect 1))) 0)))) 0) ;;; cmucl (2003-10-12), "NIL is not of type C::REF" (deftest misc.76 (funcall (compile nil '(lambda (a c) (if nil (unwind-protect (max 521739 (unwind-protect c))) (logandc2 3942 a)))) 0 0) 3942) ;;; gcl (2003-10-11) Miscomputation of (mod 0 -53) in compiled code (deftest misc.77 (funcall (compile nil '(lambda () (mod 0 -53)))) 0) ;;; cmucl (2003-10-12) "NIL is not of type C::BYTE-LAMBDA-INFO" (deftest misc.78 (funcall (compile nil '(lambda () (declare (optimize (speed 0) (debug 0))) (let ((v4 (case 227 ((-11113 -106126) (unwind-protect 8473)) (t 43916)))) -12)))) -12) ;;; Same as misc.78, but with no declarations ;;; In cmucl (2003-10-12) "NIL is not of type C::ENVIRONMENT" (deftest misc.79 (funcall (compile nil '(lambda () (let ((v4 (case 227 ((-11113 -106126) (unwind-protect 8473)) (t 43916)))) -12)))) -12) (deftest misc.79a (funcall (compile nil '(lambda (a b) (declare (type (integer 72504 351460) a)) (declare (type (integer 2383 108330) b)) (declare (optimize (speed 2) (space 0) (safety 0) (debug 2) (compilation-speed 1))) (if (or (or (/= b 0) (logbitp 0 0)) (logbitp 0 a)) 0 (funcall (constantly 0) b 0 (catch 'ct4 b))))) 132318 12238) 0) ;;; cmucl (2003-10-12) "Invalid number of arguments: 2" (deftest misc.80 (funcall (compile nil '(lambda (b c) (declare (notinline > logior imagpart)) (declare (optimize (speed 0) (debug 0))) (labels ((%f16 () (imagpart (block b3 (logeqv (logior -122516 (if (> -1 0) (return-from b3 c) b)) (return-from %f16 32186310)))))) (lognor (%f16) b)))) -123886 -1656) 57385) ;;; cmucl (2003-10-12) "NIL is not of type C::REF" (deftest misc.81 (funcall (compile nil '(lambda (b) (block b7 (let ((v3 (return-from b7 b))) (unwind-protect b))))) 17) 17) ;;; cmucl (2003-10-12) "The assertion C::SUCC failed" (deftest misc.82 (funcall (compile nil '(lambda (c) (labels ((%f15 () (* (unwind-protect c) (max -5726369 (return-from %f15 3099206))))) c))) 0) 0) ;;; cmucl (2003-10-13) "The assertion (NOT (C::BLOCK-DELETE-P BLOCK)) failed." (deftest misc.83 (funcall (compile nil '(lambda (a c) (flet ((%f8 () (min c (min a (return-from %f8 c))))) c))) 0 -10) -10) (deftest misc.84 (funcall (compile nil '(lambda (a b) (flet ((%f18 () (let () (let () (if (ldb-test (byte 20 23) b) a (return-from %f18 431)))))) -674))) 0 0) -674) (deftest misc.85 (funcall (compile nil '(lambda (c) (labels ((%f14 () (let () (logandc1 (min -32 (return-from %f14 -69793)) c)))) 156))) 0) 156) ;;; Two tests showing bug(s) in clisp (2.31) (deftest misc.86 (funcall (compile nil '(lambda (b) (flet ((%f10 nil :bad)) (let ((v7 (let ((v2 (%f10))) b))) (unwind-protect b))))) :good) :good) (deftest misc.87 (apply (compile nil '(lambda (a b c) (let ((v9 a)) (let ((v2 (setq v9 c))) (unwind-protect c))))) '(x y z)) z) ;;; cmucl bug (18e+ 10/15/03) (deftest misc.88 (eval '(block b3 (max (return-from b3 1) (if (unwind-protect (unwind-protect 2)) 3 4)))) 1) ;;; ;;; cmucl bug (18e+ 10/15/03) ;;; Also occurs in sbcl (0.8.16.20) ;;; "Too large to be represented as a SINGLE-FLOAT" ;;; (a large bignum is coerced to a single-float in type propagation, ;;; with unfortunate results.) ;;; ;;; Here, the function were the problem occurs is - (deftest misc.89 (funcall (compile nil '(lambda (c) (declare (type (integer 0 130304) c)) (- (rem -26 (max 25 (load-time-value 505849129))) (* -15718867961526428520296254978781964 c)))) 0) -26) ;;; Here, it is MAX (deftest misc.89a (funcall (compile nil '(lambda (a b c d) (declare (type (integer -265115792172 -206231862770) a)) (declare (type (integer 11069 58322510034) b)) (declare (type (integer -7351 28730) c)) (declare (type (integer -913299295156 3670905260104) d)) (declare (ignorable a b c d)) (declare (optimize (safety 1) (space 1) (compilation-speed 2) (debug 0) (speed 2))) (- (signum (catch 'ct6 0)) (numerator (* -1303 d -20527703 d c))))) -261283766805 41605749408 5110 1269102278886) -220139978315039892599545286437019126040) ;;; Here, it is MOD (deftest misc.89b (funcall (compile nil '(lambda (a b c d) (declare (type (integer -481454219025 239286093202) a)) (declare (type (integer -1121405368785 213522) b)) (declare (type (integer -103720347879 -241) c)) (declare (type (integer -12830115357 3027711346) d)) (declare (ignorable a b c d)) (declare (optimize (speed 2) (compilation-speed 1) (space 1) (safety 3) (debug 2))) (floor (load-time-value 0) (min -18 (* a c b -12626))))) -78545446876 -460518205737 -38885914099 1598305189) 0 0) ;;; acl bugs (version 6.2, linux x86 trial) (deftest misc.90 (let* ((form '(- 0 (ignore-errors 20763) (logxor b 1 c -7672794) b)) (fn1 `(lambda (b c) (declare (type (integer -148895 -46982) b)) (declare (type (integer 0 1) c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) ,form)) (fn2 `(lambda (b c) ,form))) (let ((v1 (funcall (compile nil fn1) -76071 0)) (v2 (funcall (compile nil fn2) -76071 0)) (v3 (funcall (eval `(function ,fn2)) -76071 0))) (if (= v1 v2 v3) :good (list v1 v2 v3)))) :good) (deftest misc.91 (let ((fn1 '(lambda () (declare (optimize (speed 3) (safety 1))) (ash -10 (min 8 -481)))) (fn2 '(lambda () (ash -10 (min 8 -481))))) (let ((v1 (funcall (compile nil fn1))) (v2 (funcall (compile nil fn2))) (v3 (funcall (eval `(function ,fn2))))) (if (= v1 v2 v3) :good (list v1 v2 v3)))) :good) (deftest misc.92 (let* ((form '(- -16179207 b (lognor (let () 3) (logxor -17567197 c)))) (fn1 `(lambda (b c) (declare (type (integer -621 30) c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) ,form)) (fn2 `(lambda (b c) ,form)) (vals '(26291532469 -21))) (let ((v1 (apply (compile nil fn1) vals)) (v2 (apply (compile nil fn2) vals)) (v3 (apply (eval `(function ,fn2)) vals))) (if (= v1 v2 v3) :good (list v1 v2 v3)))) :good) (deftest misc.93 (let* ((form '(ash (1+ (flet ((%f5 (f5-1) c)) c)) (min 69 (logxor a b)))) (fn1 `(lambda (a b c) (declare (type (integer -128 -109) a) (type (integer -2 -1) b) (optimize (speed 3) (safety 1))) ,form)) (fn2 `(lambda (a b c) ,form)) (vals '(-123 -1 2590941967601))) (eqlt (apply (compile nil fn1) vals) (apply (compile nil fn2) vals))) t) (deftest misc.94 (not (funcall (compile nil '(lambda () (declare (optimize (speed 3) (safety 1) (debug 1))) (<= 268435280 (load-time-value 39763134374436777607194165739302560271120000)))))) nil) (deftest misc.95 (let* ((form '(+ 272 c (if (< b a) -49618 -29042) b)) (fn1 `(lambda (a b c) (declare (type (integer -1585918 601848636) a)) (declare (type (integer -4 16544323) b)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) ,form)) (fn2 `(lambda (a b c) ,form)) (vals '(601739317 10891850 17452477960))) (let ((v1 (apply (compile nil fn1) vals)) (v2 (apply (compile nil fn2) vals))) (if (eql v1 v2) :good (list v1 v2)))) :good) (deftest misc.96 (let* ((form '(max 26 (ceiling b (min -8 (max -1 c))))) (fn1 `(lambda (b c) (declare (type (integer 482134 96074347505) b)) (declare (type (integer -4036 -50) c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) ,form)) (fn2 `(lambda (b c) ,form)) (vals '(90244278480 -338))) (let ((v1 (apply (compile nil fn1) vals)) (v2 (apply (compile nil fn2) vals))) (if (eql v1 v2) :good (list v1 v2)))) :good) (deftest misc.97 (let* ((form '(- 349708 (gcd c 0) (logand b b (if (> -8543459 c) 83328 1073)))) (fn1 `(lambda (b c) (declare (type (integer 301653 329907) b)) (declare (type (integer 171971491 1073721279) c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) ,form)) (fn2 `(lambda (b c) ,form)) (vals '(321769 1073671227))) (let ((v1 (apply (compile nil fn1) vals)) (v2 (apply (compile nil fn2) vals))) (if (eql v1 v2) :good (list v1 v2)))) :good) ;;; sbcl bugs (0.8.4.40, x86 linux) (deftest misc.98 (funcall (compile nil '(lambda (x) (declare (type (integer -1000000 1000000) x)) (logand x x 0))) 12345) 0) (deftest misc.99 (funcall (compile nil '(lambda (a) (declare (type (integer 4303063 101130078) a)) (mask-field (byte 18 2) (ash a 77)))) 57132532) 0) (deftest misc.100 (funcall (compile nil '(lambda (c) (declare (type (integer -3924 1001809828) c)) (declare (optimize (speed 3))) (min 47 (if (ldb-test (byte 2 14) c) -570344431 (ignore-errors -732893970))))) 705347625) -570344431) (deftest misc.101 (funcall (compile nil '(lambda (a c) (declare (type (integer 185501219873 303014665162) a)) (declare (type (integer -160758 255724) c)) (declare (optimize (speed 3))) (let ((v8 (- -554046873252388011622614991634432 (ignore-errors c) (unwind-protect 2791485)))) (max (ignore-errors a) (let ((v6 (- v8 (restart-case 980)))) (min v8 v6)))))) 259448422916 173715) 259448422916) (deftest misc.102 (funcall (compile nil '(lambda (b) (declare (type (integer -1598566306 2941) b)) (declare (optimize (speed 3))) (max -148949 (ignore-errors b)))) 0) 0) (deftest misc.103 (funcall (compile nil '(lambda (a b) (min -80 (abs (ignore-errors (+ (logeqv b (block b6 (return-from b6 (load-time-value -6876935)))) (if (logbitp 1 a) b (setq a -1522022182249)))))))) -1802767029877 -12374959963) -80) (deftest misc.104 (funcall (compile nil '(lambda (a) (declare (type (integer 55400028 60748067) a)) (lognand 1505 (ash a (let () 40))))) 58194485) -1) (deftest misc.105 (funcall (compile nil '(lambda (b c) (declare (type (integer -4 -3) c)) (block b7 (flet ((%f1 (f1-1 f1-2 f1-3) (if (logbitp 0 (return-from b7 (- -815145138 f1-2))) (return-from b7 -2611670) 99345))) (let ((v2 (%f1 -2464 (%f1 -1146 c c) -2))) b))))) 2950453607 -4) -815145134) ;;; Gives the error The value NIL is not of type INTEGER. (in sbcl 0.8.4.40) (deftest misc.106 (progn (eval '(defun misc.106-fn (a b c) (declare (optimize speed)) (block b6 (flet ((%f8 (f8-1 f8-2) b)) (%f8 (%f8 c 338) (if t (return-from b6 a) c)))))) (misc.106-fn -30271 -1 -3043)) -30271) ;;; "The value NIL is not of type SB-C::IR2-LVAR." (sbcl 0.8.4.40) (deftest misc.107 (funcall (compile nil '(lambda (b c) (declare (type (integer -29742055786 23602182204) b)) (declare (type (integer -7409 -2075) c)) (declare (optimize (speed 3))) (floor (labels ((%f2 () (block b6 (ignore-errors (return-from b6 (if (= c 8) b 82674)))))) (%f2))))) 22992834060 -5833) 82674 0) ;;; "The value NIL is not of type SB-C::IR2-LVAR." (sbcl 0.8.10.15) (deftest misc.107a (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 0) (safety 1) (debug 3) (compilation-speed 0))) (flet ((%f14 (f14-1 &optional (f14-2 (rationalize (catch 'ct4 0))) (f14-3 0) (f14-4 0)) (dotimes (iv2 0 0) (progn f14-2)))) (apply #'%f14 0 0 0 nil))))) 0) ;;; "The value NIL is not of type SB-C::IR2-LVAR." (sbcl 0.8.14.18) (deftest misc.107b (funcall (compile nil '(lambda (a b c) (declare (type (integer 7215 1030625885) a)) (declare (type (integer -4361 -6) b)) (declare (type (integer -3798210806 -898) c)) (declare (ignorable a b c)) (declare (optimize (speed 2) (space 2) (safety 2) (debug 3) (compilation-speed 1))) (block b4 (let ((*s7* (cons c 0))) (declare (special *s7*)) (return-from b4 (prog1 0 (the integer (integer-length (1+ (let () (gcd (cdr *s7*) (case b ((31 38 20 0 5 45) 2) ((34 35 64 61 47) 39) ((58) a) (t 131788))))))))))))) 734649164 -3343 -2306504518) 0) (deftest misc.107c (funcall (compile nil '(lambda (c) (declare (optimize (speed 2) (space 1) (safety 1) (debug 3) (compilation-speed 0))) (let* ((*s6* (unwind-protect 0 (the integer (ash 2914825 (min 8 c)))))) (declare (special *s6*)) 0))) -105) 0) (deftest misc.107d (funcall (compile nil '(lambda (a b) (declare (optimize (speed 1) (space 1) (safety 1) (debug 3) (compilation-speed 1))) (catch 'ct4 (logorc1 (the integer (case (dotimes (iv2 2 2) (progn 203)) ((-51) -59598) ((-31 -150) a) (t b))) (throw 'ct4 0))))) 10 20) 0) (deftest misc.107e (funcall (compile nil '(lambda (a) (declare (optimize (speed 1) (space 0) (safety 1) (debug 3) (compilation-speed 1))) (flet ((%f11 (&key (key1 (the integer (- a 245241933)))) 0)) (%f11)))) 1) 0) ;;; cmucl bug (Argument X is not a NUMBER: NIL) (deftest misc.108 (funcall (compile nil '(lambda (b) (block b7 (- b (ignore-errors (return-from b7 57876)))))) 10) 57876) ;;; "The assertion (C::CONSTANT-CONTINUATION-P C::CONT) failed." (cmucl) (deftest misc.109 (funcall (compile nil '(lambda () (load-time-value (block b4 (* (return-from b4 -27) (block b5 (return-from b4 (return-from b5 (ignore-errors (unwind-protect (return-from b5 0)))))))))))) -27) ;;; This bug was occuring a lot in sbcl, and now occurs in cmucl too ;;; NIL fell through ETYPECASE expression. Wanted one of (C:FIXUP X86::EA C:TN). (deftest misc.110 (funcall (compile nil '(lambda (c) (declare (type (integer -1441970837 -427) c)) (declare (optimize (speed 3))) (block b7 (abs (min c (ignore-errors (return-from b7 c))))))) -500) -500) ;;; In sbcl 0.8.10.14 ;;; NIL fell through ETYPECASE expression. ;;; Wanted one of (SB-C:FIXUP SB-VM::EA SB-C:TN). (deftest misc.110a (funcall (compile nil '(lambda (a b c d e f) (declare (type (integer -1294746569 1640996137) a)) (declare (type (integer 33628514900 90005963619) b)) (declare (type (integer -807801310 3) c)) (declare (type (integer 36607 121946) d)) (declare (type (integer -6669690514043 -1776180885905) e)) (declare (type (integer -1472 1979) f)) (declare (ignorable a b c d e f)) (declare (optimize (speed 3) (space 3) (safety 0) (debug 0) (compilation-speed 3))) (catch 'ct7 (if (logbitp 0 (if (/= 0 a) c (ignore-errors (progn (if (ldb-test (byte 0 0) (rational (throw 'ct7 0))) 0 0) 0)))) 0 0)))) 391833530 36648101240 -32785211 91893 -4124561581760 1358) 0) ;;; CLISP (2.31+) compiler bug (deftest misc.111 (funcall (compile nil '(lambda (a c) (if (or (ldb-test (byte 12 18) a) (not (and t (not (if (not (and c t)) nil nil))))) 170 -110730))) 3035465333 1919088834) 170) ;;; sbcl (0.8.5.8) "The value NIL is not of type SB-C::IR2-LVAR." (deftest misc.112 (funcall (compile nil '(lambda (a) (declare (type (integer -944 -472) a)) (declare (optimize (speed 3))) (round (block b3 (return-from b3 (if (= 55957 a) -117 (ignore-errors (return-from b3 a)))))))) -589) -589 0) ;;; sbcl (0.8.5.8) "The value NIL is not of type SB-C::CTRAN" (deftest misc.113 (funcall (compile nil '(lambda (b c) (if (or (ldb-test (byte 8 10) b) t) c (min (if (<= -6467 c) c 6) (flet ((%f3 (f3-1 f3-2) f3-1)) (multiple-value-call #'%f3 (values b 107))))))) -238 -23658556) -23658556) ;;; clisp (1 Oct 2003 cvs HEAD) "*** - CAR: #:G7744659 is not a LIST" (deftest misc.114 (funcall (compile nil '(lambda (a b) (unwind-protect (block b2 (flet ((%f1 nil b)) (logior (if a (if (ldb-test (byte 23 1) 253966182) (return-from b2 a) -103275090) 62410) (if (not (not (if (not nil) t (ldb-test (byte 2 27) 253671809)))) (return-from b2 -22) (%f1)))))))) 777595384624 -1510893868) 777595384624) ;;; clisp (1 Oct 2003 cvs HEAD) "Compiler bug!! Occurred in OPTIMIZE-LABEL." (deftest misc.115 (funcall (compile nil '(lambda (a b c) (declare (type (integer 0 1000) a b c)) (if (and (if b (not (and (not (or a t)) nil)) nil) (logbitp 6 c)) c b))) 0 100 600) 600) (deftest misc.116 (funcall (compile nil '(lambda (a c) (declare (type (integer 0 1000) a c)) (if (if (and (not (and (not (or a t)) nil)) t) c nil) 91 -1725615))) 0 0) 91) (deftest misc.117 (funcall (compile nil '(lambda (a c) (declare (type (integer 0 1000) a c)) (if (or c (not (or nil (not (and (not (or a t)) nil))))) 373146181 115))) 0 0) 373146181) (deftest misc.118 (funcall (compile nil '(lambda (a) (declare (type (integer 0 10000) a)) (if (or (or nil (not (or (not (or a nil)) t))) a) a 9376))) 0) 0) (deftest misc.119 (funcall (compile nil '(lambda () (if (and (if (1+ 0) nil (not (and (not (and (<= 3) nil)) nil))) (if (= -31) -20 -2371)) 1493 39720)))) 39720) (deftest misc.120 (funcall (compile nil '(lambda (c) (declare (type (integer 377036 4184626) c)) (if (or (and t (not (and (not (and c nil)) nil))) nil) 3470653 c))) 1000000) 3470653) (deftest misc.121 (funcall (compile nil '(lambda (a b c) (if (and (and -92220 (not (and (not (or c nil)) nil))) a) b b))) 2000000 150000 -1) 150000) ;;; CAR: #:G243 is not a LIST (deftest misc.122 (funcall (compile nil '(lambda (a b c) (declare (type (integer 2872749 5754655) a)) (declare (type (integer 24114340 89504792) b)) (declare (type (integer 506491 1412971) c)) (declare (ignorable a b c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (- (let ((v7 (ignore-errors a))) -6) (logand (if c -13936 c) (block b3 (if (if (or t b) (not nil) c) (return-from b3 -3114) (ignore-errors 7) )))))) 3000000 30000000 600000) 15978) ;;; gcl bug (30 Oct 2003) (deftest misc.123 (let* ((fn1 '(lambda (b) (declare (optimize (safety 1))) (labels ((%f7 (f7-1 f7-2) (let ((v2 (setq b 723149855))) 25620))) (max b (multiple-value-call #'%f7 (values b 2)))))) (fn2 '(lambda (b) (labels ((%f7 (f7-1 f7-2) (let ((v2 (setq b 723149855))) 25620))) (max b (multiple-value-call #'%f7 (values b 2)))))) (vals '(1439719153)) (v1 (apply (compile nil fn1) vals)) (v2 (apply (compile nil fn2) vals))) (if (eql v1 v2) :good (list v1 v2))) :good) (deftest misc.124 (let* ((fn1 '(lambda (b) (declare (optimize (safety 1))) (labels ((%f7 (f7-1 f7-2) (let ((v2 (setq b 723149855))) 25620))) (max b (funcall #'%f7 b 2))))) (fn2 '(lambda (b) (labels ((%f7 (f7-1 f7-2) (let ((v2 (setq b 723149855))) 25620))) (max b (funcall #'%f7 b 2))))) (vals '(1439719153)) (v1 (apply (compile nil fn1) vals)) (v2 (apply (compile nil fn2) vals))) (if (eql v1 v2) :good (list v1 v2))) :good) ;;; This passed in gcl, but I added it for completeness. (deftest misc.125 (let* ((fn1 '(lambda (b) (declare (optimize (safety 1))) (labels ((%f7 (f7-1 f7-2) (let ((v2 (setq b 723149855))) 25620))) (max b (%f7 b 2))))) (fn2 '(lambda (b) (labels ((%f7 (f7-1 f7-2) (let ((v2 (setq b 723149855))) 25620))) (max b (%f7 b 2))))) (vals '(1439719153)) (v1 (apply (compile nil fn1) vals)) (v2 (apply (compile nil fn2) vals))) (if (eql v1 v2) :good (list v1 v2))) :good) ;;; clisp optional argument bug: "SYMBOL-VALUE: 1 is not a SYMBOL" (deftest misc.126 (funcall (compile nil '(lambda () (declare (special *should-always-be-true*)) (labels ((%f10 (f10-1 &optional (f10-2 (cl:handler-bind nil (if *should-always-be-true* (progn 878) (should-never-be-called) ))) (f10-3 (cl:handler-case 10))) -15)) (%f10 -144))))) -15) (deftest misc.127 (funcall (compile nil '(lambda (a c) (flet ((%f10 (f10-1 f10-2) 10)) (flet ((%f4 (&optional (f4-1 (ldb (byte 10 6) (* 828 (+ 30 (dpb c (byte 9 30) (%f10 1918433 34107))) ))) (f4-2 (setq a 0))) 2)) (%f4 -5))))) 0 0) 2) ;;; cmucl (22 Oct 2003 build) bug ;;; The assertion (EQ (C::COMPONENT-KIND C:COMPONENT) :INITIAL) failed. (deftest misc.128 (flet ((%f14 (f14-1 f14-2 &optional (f14-3 (unwind-protect 13059412)) (f14-4 452384) (f14-5 -6714)) -1)) (%f14 -2 1 1279896 589726354 -11)) -1) (deftest misc.129 (labels ((%f17 (f17-1 f17-2 &optional (f17-3 (unwind-protect 178))) 483633925)) -661328075) -661328075) (deftest misc.130 (let* ((fn1 '(lambda (a c) (flet ((%f10 (&optional (f10-1 -6489) (f10-2 (+ c))) a)) (multiple-value-call #'%f10 (values -178858 a))))) (fn2 '(lambda (a c) (declare (notinline values +) (optimize (speed 0) (debug 0))) (flet ((%f10 (&optional (f10-1 -6489) (f10-2 (+ c))) a)) (multiple-value-call #'%f10 (values -178858 a))))) (vals '(-13649921 -1813684177409)) (v1 (apply (compile nil fn1) vals)) (v2 (apply (compile nil fn2) vals))) (if (eql v1 v2) :good (list v1 v2))) :good) (deftest misc.131 (let* ((fn1 '(lambda (a b) (max (block b7 (abs (ignore-errors (if (ldb-test (byte 33 15) (return-from b7 a)) b b))))))) (fn2 '(lambda (a b) (declare (notinline abs max)) (declare (optimize (speed 0))) (declare (optimize (debug 0))) (max (block b7 (abs (ignore-errors (if (ldb-test (byte 33 15) (return-from b7 a)) b b))))))) (vals '(-823894140303 -3)) (v1 (apply (compile nil fn1) vals)) (v2 (apply (compile nil fn2) vals))) (if (eql v1 v2) :good (list v1 v2))) :good) ;;; cmucl (22 Oct 2003) ;;; The assertion (EQ C::ENV ;;; (C::LAMBDA-ENVIRONMENT ;;; (C::LAMBDA-VAR-HOME C::THING))) failed. (deftest misc.132 (funcall (compile nil '(lambda (b c) (declare (type (integer -3358662 7782429) b)) (declare (type (integer -513018 12740) c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (labels ((%f9 (&optional (f9-1 (labels ((%f5 (f5-1 f5-2) (floor (ignore-errors f5-1) (min -67 (if (equal -56 c) -11197265 f5-2))))) c)) (f9-2 -439518) (f9-3 -2840573)) f9-1)) (%f9 -193644 b 1368)))) 10 20) -193644) (deftest misc.132a (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 0) (safety 0) (debug 2) (compilation-speed 0))) (labels ((%f1 () 0)) (if t 0 (dotimes (iv1 5 (if (%f1) 0 0)) (catch 'ct1 0))))))) 0) ;;; cmucl (22 Oct 2003) Default for optional parameter is improperly chosen (deftest misc.133 (funcall (compile nil '(lambda (a b c) (declare (notinline values)) (declare (optimize (speed 0) (debug 0))) (flet ((%f15 (&optional (f15-5 c)) f15-5)) (multiple-value-call #'%f15 (values -2688612))))) 1 2 3) -2688612) ;;; ACL 6.2 (x86 linux trial) bugs ;;; With optional flet/labels parameters, there's a very high frequency bug ;;; causing the compiler error "Error: `:INFERRED' is not of the expected ;;; type `NUMBER'". The following tests show this bug. (deftest misc.134 (funcall (compile nil '(lambda (b) (labels ((%f5 (f5-1 f5-2 f5-3 &optional (f5-4 0) (f5-5 (flet ((%f13 (f13-1) (return-from %f13 b))) b))) 900654472)) 183301))) 13775799184) 183301) (deftest misc.135 (funcall (compile nil '(lambda (a b) (labels ((%f4 (&optional (f4-1 (labels ((%f17 nil a)) b))) -14806404)) 190134))) 1783745644 268410629) 190134) (deftest misc.136 (funcall (compile nil '(lambda (c) (flet ((%f17 (&optional (f17-1 (flet ((%f9 nil c)) 73574919))) 643)) 1039017546))) 0) 1039017546) ;;; And these caused segfaults (deftest misc.137 (funcall (compile nil '(lambda () (declare (optimize (speed 3))) (declare (optimize (safety 1))) (flet ((%f16 (&optional (f16-2 (lognor -3897747 (if nil -1 -127228378)))) 10)) 20)))) 20) (deftest misc.138 (funcall (compile nil '(lambda (c) (declare (type (integer 2996 39280) c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (if (zerop (labels ((%f8 (&optional (f8-2 (logorc2 c -161957))) 2176)) 3)) c c))) 3000) 3000) ;;; Lispworks 4.2 (x86 linux personal edition) failures (deftest misc.139 (let* ((fn1 '(lambda (c) (declare (optimize (speed 3))) (logior (labels ((%f1 (f1-1 &optional (f1-2 (setq c 7))) f1-1)) (%f1 774 3616592)) c))) (fn2 '(lambda (c) (logior (labels ((%f1 (f1-1 &optional (f1-2 (setq c 7))) f1-1)) (%f1 774 3616592)) c))) (vals '(-3)) (v1 (apply (compile nil fn1) vals)) (v2 (apply (compile nil fn2) vals))) (if (eql v1 v2) :good (list v1 v2))) :good) (deftest misc.140 (funcall (compile nil '(lambda (a) (ldb (byte 24 20) (labels ((%f12 (&optional (f12-1 149) (f12-2 -3894159)) 34068)) (let* ((v4 (%f12))) a))))) -1) 16777215) ;;; In Lispworks 4.2 (x86 linux personal edition) ;;; 'Error: *** Ran out of patterns in (MOVE) for (edi NIL)' (deftest misc.141 (funcall (compile nil '(lambda () (labels ((%f11 (&optional (f11-3 (restart-case 0))) f11-3)) (%f11 1))))) 1) (deftest misc.142 (funcall (compile nil '(lambda () (labels ((%f15 (&optional (f15-3 (block b1 (+ 1 (return-from b1 -10))))) f15-3)) (%f15))))) -10) ;;; cmucl (22 Oct 2003): NIL is not of type C::REF (deftest misc.143 (block b2 (max (return-from b2 1) (let ((v3 (unwind-protect (let* ((v1 (ignore-errors -254))) 1)))) -2))) 1) ;;; (was) The assertion (NOT (C::BLOCK-DELETE-P BLOCK)) failed. ;;; (now) The assertion (NOT (MEMBER C::KIND '(:DELETED :OPTIONAL :TOP-LEVEL))) failed. (deftest misc.144 (funcall (compile nil '(lambda (a b c) (declare (type (integer 9739325 14941321) c)) (labels ((%f7 (f7-1 f7-2 f7-3 &optional (f7-4 b)) (return-from %f7 f7-4))) (if (= -76482 c) (if (>= c 10986082) (%f7 a b (%f7 -8088 c -147106 2)) -10502) (%f7 509252 b b))))) -200 17 10000000) 17) (deftest misc.145 (funcall (compile nil '(lambda (a b c) (declare (optimize (safety 3))) (block b5 (return-from b5 (logior (if (or c t) b (load-time-value -61)) (return-from b5 -3)))))) 1 2 3) -3) ;;; cmucl: order of evaluation error (deftest misc.146 (funcall (compile nil '(lambda (b) (declare (optimize (speed 3))) (flet ((%f14 (&optional (f14-1 301917227) (f14-2 (setq b 995196571))) f14-1)) (%f14 b (block b3 (%f14 -64)))))) 10) 10) ;;; cmucl (22 Oct 2003): NIL is not of type C::CLEANUP (deftest misc.147 (flet ((%f11 () (if nil (ignore-errors -19884254) (unwind-protect -2)))) :good) :good) ;;; The assertion (C::CONSTANT-CONTINUATION-P C::CONT) failed. (deftest misc.148 (block b2 (logior (return-from b2 484) (restart-case (ignore-errors 1737021)))) 484) ;;; Argument X is not a NUMBER: NIL. (deftest misc.149 (funcall (compile nil '(lambda (b) (block b1 (- (logand 0 -34 1026491) (ignore-errors (return-from b1 b)))))) 0) 0) (deftest misc.149a (funcall (compile nil '(lambda (a) (block b1 (- a (ignore-errors (return-from b1 1)))))) 0) 1) ;;; cmucl (11 2003 image) "NIL is not of type C::CONTINUATION" (deftest misc.150 (funcall (compile nil '(lambda (a b c) (flet ((%f17 (&optional (f17-4 (labels ((%f13 (f13-1 &optional (f13-2 (multiple-value-prog1 b))) -4)) (%f13 b (%f13 190))))) -157596)) (labels ((%f6 () (%f17))) c)))) 10 20 30000) 30000) (deftest misc.150a (funcall (compile nil '(lambda () (declare (optimize (speed 3) (space 2) (safety 3) (debug 3) (compilation-speed 2))) (catch 'ct6 (apply (constantly 0) (list)))))) 0) (deftest misc.150b (funcall (compile nil '(lambda (a) (declare (type integer a)) (declare (optimize (speed 3) (space 0) (safety 3) (debug 2) (compilation-speed 3))) (if (= a 0) 0 (truncate a)))) 0) 0) (deftest misc.150c (funcall (compile nil '(lambda (a b) (declare (optimize (speed 1) (space 3) (safety 2) (debug 3) (compilation-speed 3))) (labels ((%f4 (f4-1) 0)) (labels ((%f15 (f15-1 f15-2 &optional (f15-3 (apply #'%f4 0 nil)) (f15-4 0) (f15-5 (%f4 (%f4 (if (/= 0 0) a 0))))) 0)) (labels ((%f13 (f13-1) (%f15 b 0 0 0))) 0))))) 1 2) 0) (deftest misc.150d (funcall (compile nil '(lambda (a b) (declare (type (integer 4146834609223 16403344221223) a)) (declare (type (integer -35470308180 3523580009) b)) (declare (optimize (speed 1) (space 3) (safety 3) (debug 0) (compilation-speed 0))) (catch 'ct1 (logand b a 0)))) 4146834609223 10) 0) ;;; cmucl (11 2003 x86 linux) "NIL is not of type C::ENVIRONMENT" (deftest misc.151 (funcall (compile nil '(lambda (b c) (declare (type (integer -249 97) b)) (declare (type (integer 3565969 6559088) c)) (let* ((v7 (if (not (= 1030 4)) c (logand (if (/= b c) b 34945725) (unwind-protect -12443701))))) 5520737))) -24 5657943) 5520737) (deftest misc.151a (funcall (compile nil '(lambda () (declare (optimize (speed 3) (space 3) (safety 1) (debug 1) (compilation-speed 0))) (case 0 ((-12 -9 -12 -2 -5 -2 15) (catch 'ct7 (throw 'ct7 0))) (t 0))))) 0) ;;; sbcl bug (0.8.5.19) ;;; "The value NIL is not of type SB-C::REF." (deftest misc.152 (funcall (compile nil '(lambda (a) (block b5 (let ((v1 (let ((v8 (unwind-protect 9365))) 8862008))) (* (return-from b5 (labels ((%f11 (f11-1) f11-1)) (%f11 87246015))) (return-from b5 (setq v1 (labels ((%f6 (f6-1 f6-2 f6-3) v1)) (dpb (unwind-protect a) (byte 18 13) (labels ((%f4 () 27322826)) (%f6 -2 -108626545 (%f4)))))))))))) -6) 87246015) (deftest misc.153 (funcall (compile nil '(lambda (a) (if (logbitp 3 (case -2 ((-96879 -1035 -57680 -106404 -94516 -125088) (unwind-protect 90309179)) ((-20811 -86901 -9368 -98520 -71594) (let ((v9 (unwind-protect 136707))) (block b3 (setq v9 (let ((v4 (return-from b3 v9))) (- (ignore-errors (return-from b3 v4)))))))) (t -50))) -20343 a))) 0) -20343) ;;; Bug in ecl (cvs head, 4 Nov 2003) ;;; "/tmp/ecl04Coiwc0V.c:48: `lex0' undeclared (first use in this function)" (deftest misc.154 (funcall (compile nil '(lambda (b) (labels ((%f8 nil -39011)) (flet ((%f4 (f4-1 f4-2 &optional (f4-3 (%f8)) (f4-4 b)) (%f8))) (%f4 -260093 -75538 -501684 (let ((v9 (%f8))) -3)))))) 0) -39011) ;;; "/tmp/ecl1572CbKzu.c:16: too many arguments to function `APPLY'" (deftest misc.155 (funcall (compile nil '(lambda (a b c) (labels ((%f6 (f6-1 f6-2) c)) (multiple-value-call #'%f6 (values a c))))) 0 10 20) 20) ;;; "The function C::LDB1 is undefined." (deftest misc.156 (funcall (compile nil '(lambda () (let ((v6 (ldb (byte 30 1) 1473))) (let ((v8 v6)) 2395))))) 2395) ;;; "/tmp/ecl9CEiD1RL5.c:36: `lex0' undeclared (first use in this function)" (deftest misc.157 (funcall (compile nil ' (lambda (c) (labels ((%f11 nil 1)) (flet ((%f9 (f9-1 f9-2) (case 17466182 ((-12) (%f11)) (t c)))) (%f9 -9913 c))))) 17) 17) ;;; SBCL (0.8.5.24) bug: "bogus operands to XOR" (deftest misc.158 (funcall (compile nil '(lambda (a b c) (declare (type (integer 79828 2625480458) a)) (declare (type (integer -4363283 8171697) b)) (declare (type (integer -301 0) c)) (if (equal 6392154 (logxor a b)) 1706 (let ((v5 (abs c))) (logand v5 (logior (logandc2 c v5) (common-lisp:handler-case (ash a (min 36 22477))))))))) 100000 0 0) 0) ;;; sbcl (0.8.5.24) The value NIL is not of type SB-C::CTRAN. (deftest misc.159 (funcall (compile nil '(lambda () (let ((v8 70696)) (if (equal v8 -536145083) (let ((v2 (setq v8 v8))) (flet ((%f9 (f9-1 f9-2) 309257)) (multiple-value-call #'%f9 (values v2 v2)))) 100))))) 100) ;;; sbcl (0.8.5.37) The value NIL is not of type SB-C::CTRAN. (deftest misc.159a (funcall (compile nil '(lambda (a b) (declare (type (integer -105680 2104974) a)) (declare (type (integer -1881 -1134) b)) (declare (ignorable a b)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (block b5 (let ((v2 (if (or (>= 34 a) 108361696) (return-from b5 -1) (lognand b -16023672)))) (flet ((%f10 (f10-1 &optional (f10-2 (if (eql -30 v2) v2 -5)) (f10-3 v2) (f10-4 14)) (if (equal a f10-2) f10-4 380663047))) (flet ((%f6 (f6-1 f6-2 f6-3) f6-1)) (multiple-value-call #'%f6 (values a (%f10 -37243) -47691)))))))) 100 -1200) -1) ;;; gcl (9 Nov 2003) bug ;;; Error in FUNCALL [or a callee]: Caught fatal error [memory may be damaged] (deftest misc.160 (funcall (compile nil '(lambda (c) (declare (notinline + funcall)) (+ (labels ((%f1 () -14)) (funcall #'%f1)) (flet ((%f2 () (floor c))) (funcall #'%f2))))) 0) -14) ;;; cmucl (9 Nov 2003) ;;; The assertion (NOT (MEMBER C::KIND '(:DELETED :OPTIONAL :TOP-LEVEL))) failed. (deftest misc.161 (funcall (compile nil '(lambda (a b c) (flet ((%f17 (f17-1 f17-2 f17-3) (flet ((%f2 (f2-1 f2-2 &optional (f2-3 (return-from %f17 f17-1)) (f2-4 (return-from %f17 -57))) b)) (multiple-value-call #'%f2 (values c -588 55101157))))) (if nil (let* ((v6 (%f17 102136 3096194 a))) b) c)))) -511 -2269809964 250738) 250738) (deftest misc.161a (funcall (compile nil '(lambda (a) (declare (optimize (speed 3) (space 2) (safety 3) (debug 0) (compilation-speed 0))) (progn (abs 0) (- a) 0))) 1) 0) ;;; cmucl (9 Nov 2003) Incorrect result at SPEED 0. (deftest misc.162 (let* ((fn `(lambda (a c) (declare (notinline funcall) (optimize (speed 0) (debug 0))) (labels ((%f17 (f17-1 &optional (f17-4 c)) (return-from %f17 (if f17-4 f17-1 49572640)))) (funcall #'%f17 15128425 a))))) (funcall (compile nil fn) 1 3)) 15128425) ;;; gcl (12 Nov 2003) ;;; C compiler failure during compilation (duplicate case value) (deftest misc.163 (funcall (compile nil '(lambda (b) (declare (type (integer -15716 3947) b)) (case b ((-7 -6 -6) :good) ((-5 -6) :bad) ))) -6) :good) ;;; gcl (13 Nov 2003) ;;; Error in FUNCALL [or a callee]: Caught fatal error [memory may be damaged] (deftest misc.164 (funcall (compile nil '(lambda (a) (labels ((%f6 (f6-1 f6-2) (cl:handler-case (labels ((%f2 nil (logior a))) (if (eql (%f2) (%f2)) 2829254 -10723)) (error (c) (error c)) ))) (funcall #'%f6 10 20) ))) 0) 2829254) ;;; sbcl failures ;;; The value NIL is not of type SB-C::NODE. (deftest misc.165 (funcall (compile nil '(lambda (a b c) (block b3 (flet ((%f15 (f15-1 f15-2 f15-3 &optional (f15-4 (flet ((%f17 (f17-1 f17-2 f17-3 &optional (f17-4 185155520) (f17-5 c) (f17-6 37)) c)) (%f17 -1046 a 1115306 (%f17 b -146330 422) -337817))) (f15-5 a) (f15-6 -40)) (return-from b3 -16))) (multiple-value-call #'%f15 (values -519354 a 121 c -1905)))))) 0 0 -5) -16) ;;; failed AVER: ;;; "(NOT ;;; (AND (NULL (BLOCK-SUCC B)) ;;; (NOT (BLOCK-DELETE-P B)) ;;; (NOT (EQ B (COMPONENT-HEAD #)))))" (deftest misc.166 (funcall (compile nil '(lambda (a b c) (labels ((%f4 (f4-1 f4-2 &optional (f4-3 b) (f4-4 c) (f4-5 -170)) (let ((v2 (flet ((%f3 (f3-1 &optional (f3-2 28476586) (f3-3 c) (f3-4 -9240)) (return-from %f4 1))) (multiple-value-call #'%f3 (values -479909 19843799 f4-5 -463858))))) b))) c))) 0 0 -223721124) -223721124) (deftest misc.167 (funcall (compile nil '(lambda (a b c) (flet ((%f5 (f5-1 f5-2) (return-from %f5 604245664))) (flet ((%f12 (f12-1 f12-2 &optional (f12-3 c) (f12-4 -579456) (f12-5 (labels ((%f9 (f9-1 &optional (f9-2 (%f5 1 (let ((v4 (%f5 30732606 a))) b))) (f9-3 -29) (f9-4 (block b4 (labels ((%f14 () (labels ((%f18 (&optional (f18-1 (locally 592928)) (f18-2 -3) (f18-3 (return-from b4 a))) f18-1)) (%f18 74214190 a)))) (%f14))))) -1)) (flet ((%f17 (f17-1 f17-2 &optional (f17-3 -136045032)) -38655)) (%f17 43873 -138030706 -1372492))))) (return-from %f12 -15216677))) (%f12 (%f5 b 2329383) a))))) 1 2 3) -15216677) (deftest misc.168 (funcall (compile nil '(lambda (a b c) (block b3 (flet ((%f11 (f11-1 f11-2 &optional (f11-3 (block b6 (labels ((%f11 (f11-1 &optional (f11-2 c) (f11-3 (return-from b6 -1806))) (return-from b3 -28432))) (apply #'%f11 (list -114)))))) (return-from %f11 f11-2))) (%f11 b c (labels ((%f10 (f10-1 f10-2 &optional (f10-3 a) (f10-4 (%f11 -3931 170))) -1704759)) c)))))) 1 2 3) 3) (deftest misc.169 (funcall (compile nil '(lambda (a b c) (if t -21705 (flet ((%f15 (f15-1 f15-2) b)) (block b4 (%f15 -11112264 (labels ((%f2 (f2-1 &optional (f2-2 (if b -5485340 -1534)) (f2-3 -6)) (return-from b4 f2-1))) (return-from b4 (if b (%f2 c -320813) (%f2 b a a)))))))))) 1 2 3) -21705) ;;; sbcl (0.8.5.26) ;;; failed AVER: "(FUNCTIONAL-LETLIKE-P CLAMBDA)" (deftest misc.170 (funcall (compile nil '(lambda (b) (flet ((%f14 (f14-1 f14-2) (if (if (eql b -7) nil nil) (labels ((%f10 (f10-1 f10-2 f10-3) 7466)) (return-from %f14 (min (multiple-value-call #'%f10 (values 0 492 f14-1)) (max 11 f14-1) (multiple-value-call #'%f10 (values 439171 f14-2 0))))) 1))) (let ((v6 (%f14 (logcount b) -386283))) 56211)))) 17) 56211) (deftest misc.170a (funcall (compile nil '(lambda (a b) (declare (type (integer -281 30570) a)) (declare (type (integer -4247786 -199821) b)) (declare (optimize (speed 3) (space 0) (safety 0) (debug 2) (compilation-speed 1))) (flet ((%f14 (f14-1 f14-2) (coerce 0 'integer))) (labels ((%f3 (f3-1 f3-2 f3-3) (if (if (typep (%f14 -864 -10620) '(integer -11672107617 -2)) t (typep (imagpart (lcm 2120258 0 (logandc2 -6222 -1057382553))) '(integer * -113))) (dotimes (iv3 5 (flet ((%f11 (f11-1 f11-2 f11-3) b)) (multiple-value-call #'%f11 (values a a f3-3)))) 0) 0))) (case (%f3 a a 0) (t 0)))))) 22087 -1787181) 0) ;;; The value NIL is not of type SB-C::NODE. (deftest misc.171 (funcall (compile nil '(lambda (b) (block b6 (flet ((%f11 (f11-1 f11-2 &optional (f11-3 -2369157) (f11-4 409468)) (return-from b6 1))) (block b2 (flet ((%f10 (f10-1 f10-2 &optional (f10-3 (return-from b6 (return-from b6 -3)))) -8)) (%f10 (multiple-value-call #'%f11 (values -5945959 1654846427 -22)) (return-from b2 b) (return-from b2 31258361)))))))) 10) 1) ;;; segmentation violation at #XA4A0B59 (deftest misc.172 (funcall (compile nil '(lambda (a b c) (declare (notinline list apply)) (declare (optimize (safety 3))) (declare (optimize (speed 0))) (declare (optimize (debug 0))) (labels ((%f12 (f12-1 f12-2) (labels ((%f2 (f2-1 f2-2) (flet ((%f6 () (flet ((%f18 (f18-1 &optional (f18-2 a) (f18-3 -207465075) (f18-4 a)) (return-from %f12 b))) (%f18 -3489553 -7 (%f18 (%f18 150 -64 f12-1) (%f18 (%f18 -8531) 11410) b) 56362666)))) (labels ((%f7 (f7-1 f7-2 &optional (f7-3 (%f6))) 7767415)) f12-1)))) (%f2 b -36582571)))) (apply #'%f12 (list 774 -4413))))) 0 1 2) 774) ;;; In sbcl 0.8.5.37 ;;; "Unreachable code is found or flow graph is not properly depth-first ordered." (deftest misc.173 (funcall (compile nil '(lambda (a b c) (declare (notinline values)) (declare (optimize (safety 3))) (declare (optimize (speed 0))) (declare (optimize (debug 0))) (flet ((%f11 (f11-1 f11-2 &optional (f11-3 c) (f11-4 7947114) (f11-5 (flet ((%f3 (f3-1 &optional (f3-2 b) (f3-3 5529)) 8134)) (multiple-value-call #'%f3 (values (%f3 -30637724 b) c))))) (setq c 555910))) (if (and nil (%f11 a a)) (if (%f11 a 421778 4030 1) (labels ((%f7 (f7-1 f7-2 &optional (f7-3 (%f11 -79192293 (%f11 c a c -4 214720) b b (%f11 b 985))) (f7-4 a)) b)) (%f11 c b -25644)) 54) -32326608)))) 1 2 3) -32326608) ;;; In sbcl 0.8.5.37 ;;; The value NIL is not of type SB-C:COMPONENT. (deftest misc.174 (funcall (compile nil '(lambda (a b c) (declare (type (integer 10292971433 14459537906) b)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (if (and (and (/= -51885 b) nil) (case (1+ b) ((4 4 3 -4) (let* ((v1 (flet ((%f16 (f16-1) -1858366)) (apply #'%f16 b (list))))) -1602321)) (t 3))) 19 c))) 0 11000000000 0) 0) (deftest misc.174a (funcall (compile nil '(lambda (a b) (declare (type (integer 23 365478242977) a)) (declare (type (integer -38847 268231) b)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (if (not (if (/= b 7) t (not (not a)))) (case (setq b -5880) ((8382 3401 2058 39167 62228) (flet ((%f7 (f7-1 f7-2 f7-3) f7-1)) (multiple-value-call #'%f7 (values -135629 a -410168200)))) (t a)) 15173))) 30 0) 15173) (deftest misc.174b (funcall (compile nil '(lambda (a b) (declare (type (integer -8688 2170) a)) (declare (type (integer -9938931470 1964967743) b)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (if (and (if (if (equal b 9) nil t) nil (not (logbitp 5 (labels ((%f5 (f5-1 f5-2 f5-3) 4057223)) (let ((v9 (%f5 -42 -27504 45026809))) 15011))))) (if (or a (labels ((%f16 (f16-1) 61)) (apply #'%f16 275 (list)))) a t)) (setq a -4803) (rem a (max 47 b))))) 0 0) 0) ;;; In sbcl 0.8.5.37 ;;; "Unreachable code is found or flow graph is not properly depth-first ordered." (deftest misc.175 (funcall (compile nil '(lambda (a b c) (declare (notinline list apply values signum funcall)) (declare (optimize (safety 3))) (declare (optimize (speed 0))) (declare (optimize (debug 0))) (labels ((%f4 (f4-1 f4-2 f4-3) (labels ((%f1 (f1-1 f1-2 f1-3) 2)) (labels ((%f11 (f11-1 &optional (f11-2 (return-from %f4 (labels ((%f8 (f8-1 f8-2 f8-3 &optional (f8-4 -35) (f8-5 f4-2)) f4-1)) (funcall #'%f8 53 b f4-1))))) (return-from %f4 a))) (signum (let ((v4 (flet ((%f8 (f8-1 f8-2 f8-3 &optional (f8-4 b) (f8-5 -560367)) f8-4)) (%f8 -27 35395 c -69)))) (%f11 (multiple-value-call #'%f11 (values (%f1 (%f11 b (%f11 v4 f4-3)) f4-3 77936) 1628490976)) (return-from %f4 (%f1 -9432 f4-1 f4-1))))))))) (flet ((%f7 (f7-1 f7-2 f7-3) (%f4 b f7-3 f7-3))) (flet ((%f14 (f14-1) (apply #'%f7 -252 -56169265 -7322946 (list)))) (%f14 a)))))) -70313091 577425217 28052774417) -70313091) (deftest misc.175a (funcall (compile nil '(lambda (a b) (declare (notinline values list apply logior)) (declare (optimize (safety 3))) (declare (optimize (speed 0))) (declare (optimize (debug 0))) (if nil (logior (flet ((%f5 (f5-1) b)) (%f5 56288)) (flet ((%f17 (f17-1 f17-2 &optional (f17-3 (let () 6857)) (f17-4 (labels ((%f3 (f3-1 f3-2 f3-3 &optional (f3-4 a) (f3-5 877)) 139)) (apply #'%f3 (list -33052082 b a 1572))))) b)) (multiple-value-call #'%f17 (values 31 b a b)))) 392))) 0 0) 392) (deftest misc.175b (funcall (compile nil '(lambda (a b) (declare (type (integer -1185422977 2286472818) a)) (declare (type (integer -211381289038 74868) b)) (declare (ignorable a b)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (lognor (unwind-protect -1248) (flet ((%f7 (&optional (f7-1 (flet ((%f1 (f1-1 f1-2 f1-3) 121426)) (%f1 b 2337452 (%f1 61767 b a)))) (f7-2 (block b8 (logandc1 (labels ((%f10 (f10-1 f10-2 f10-3) 323734600)) (%f10 (%f10 323734600 323734600 -10165) -607741 (ignore-errors 971588))) (if (>= b -27) (return-from b8 -2) (ignore-errors 237138926)))))) f7-2)) (apply #'%f7 (list 761316125 b)))))) 1792769319 -60202244870) 5) ;;; sbcl 0.8.5.37 ;;; failed AVER: "(FUNCTIONAL-LETLIKE-P CLAMBDA)" (deftest misc.176 (funcall (compile nil '(lambda (a b c) (declare (type (integer 162180298 184143783) a)) (declare (type (integer 702599480988 725878356286) b)) (declare (type (integer 168 80719238530) c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (block b6 (flet ((%f10 (f10-1 f10-2) (labels ((%f6 (f6-1 f6-2) f6-1)) (let ((v2 (flet ((%f1 (f1-1 f1-2 f1-3) f1-3)) (let ((v8 (%f1 -11350578 (%f6 10414199 13) -58931837))) -239755)))) 323)))) (labels ((%f4 (f4-1 &optional (f4-2 204) (f4-3 -1) (f4-4 (flet ((%f2 (f2-1) (if t (return-from b6 c) a))) (logorc2 (multiple-value-call #'%f2 (values 1)) (let* ((v5 (floor (%f2 -1260)))) (case (abs (logxor 185664 a)) ((-2 5975) (if (or (< b v5) nil) (return-from b6 (let ((v10 (%f2 c))) 0)) (multiple-value-call #'%f10 (values -3 a)))) (t b))))))) 1503938)) (multiple-value-call #'%f4 (values -1 a 1853966))))))) 173549795 725346738048 993243799) 993243799) ;;; different results (sbcl 0.8.5.37) ;;; May be that setq side effects bug again? (deftest misc.177 (let* ((form '(flet ((%f11 (f11-1 f11-2) (labels ((%f4 () (round 200048 (max 99 c)))) (logand f11-1 (labels ((%f3 (f3-1) -162967612)) (%f3 (let* ((v8 (%f4))) (setq f11-1 (%f4))))))))) (%f11 -120429363 (%f11 62362 b)))) (vars '(a b c)) (vals '(6714367 9645616 -637681868)) (fn1 `(lambda ,vars (declare (type (integer 804561 7640697) a)) (declare (type (integer -1 10441401) b)) (declare (type (integer -864634669 55189745) c)) (declare (ignorable a b c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) ,form)) (fn2 `(lambda ,vars (declare (notinline list apply logand max round)) (declare (optimize (safety 3))) (declare (optimize (speed 0))) (declare (optimize (debug 0))) ,form)) (compiled-fn1 (compile nil fn1)) (compiled-fn2 (compile nil fn2)) (results1 (multiple-value-list (apply compiled-fn1 vals))) (results2 (multiple-value-list (apply compiled-fn2 vals)))) (if (equal results1 results2) :good (values results1 results2))) :good) ;;; sbcl 0.8.5.37 ;;; The value NIL is not of type INTEGER. (deftest misc.178 (funcall (compile nil '(lambda (a b c) (declare (ignorable a b c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (let ((v9 (flet ((%f9 (f9-1 f9-2 f9-3 &optional (f9-4 -40538) (f9-5 (flet ((%f10 (f10-1 f10-2) (labels ((%f11 (f11-1 f11-2) (labels ((%f10 (f10-1 f10-2) -1422)) (if (< b (%f10 (%f10 28262437 95387) f10-2)) -1562 f10-2)))) (let* ((v6 (%f11 59 b))) (return-from %f10 (apply #'%f11 f10-1 (list (return-from %f10 2029647)))))))) (apply #'%f10 -3067 3854883 (list))))) 64066)) (%f9 a 2774 0 c)))) (flet ((%f18 (f18-1 f18-2 &optional (f18-3 66) (f18-4 b)) -6939342)) (%f18 1274880 (%f18 b a 46746370 -1)))))) 0 0 0) -6939342) ;;; sbcl 0.8.5.37 ;;; failed AVER: "(FUNCTIONAL-LETLIKE-P CLAMBDA)" (deftest misc.179 (funcall (compile nil '(lambda (a b) (declare (type (integer 1135 16722) a)) (declare (type (integer -640723637053 -9049) b)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (block b3 (return-from b3 (flet ((%f17 (f17-1 &optional (f17-2 b) (f17-3 b)) (+ (if t (return-from b3 -64796) a)))) (case (%f17 -3908648 -7026139 a) ((41771 -113272 -48004 -39699 50691 -13222) (multiple-value-call #'%f17 (values -1963404294 -105))) (t -7026139))))))) 2000 -10000) -64796) (deftest misc.180 (funcall (compile nil '(lambda (a b) (declare (type (integer 41 484) a)) (declare (type (integer -2546947 1008697961708) b)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (if (and (ldb-test (byte 30 10) b) nil) (labels ((%f7 (f7-1 f7-2 &optional (f7-3 -508405733)) 390004056)) (let* ((v4 (multiple-value-call #'%f7 (values b (%f7 b b))))) (multiple-value-call #'%f7 (values (%f7 80199 a) (%f7 (%f7 a (let* ((v6 (%f7 -226 250))) a)) (abs (ceiling v4))))))) -6001))) 50 0) -6001) ;;; sbcl 0.8.5.37 ;;; The value NIL is not of type SB-C::TAIL-SET. (deftest misc.181 (funcall (compile nil '(lambda (a b) (declare (type (integer -74233251043 -16478648860) a)) (declare (type (integer 0 960962) b)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (flet ((%f14 () (if 1 (return-from %f14 a) (labels ((%f10 (f10-1 f10-2 f10-3 &optional (f10-4 (let* ((v7 a)) 915))) -1268205049)) (labels ((%f18 (f18-1) (multiple-value-call #'%f10 (values f18-1 (%f10 (%f10 -1495 (%f10 -384 -84 (%f10 -1 48052 58909027 -35812) -114) (%f10 -391646964 -28131299 f18-1 (%f10 b 368193 a))) (%f10 f18-1 -1415811 f18-1 267932407) 174) -58 320)))) (let* ((v3 (let ((v7 (return-from %f14 (%f18 -418731)))) (%f10 104871 -1196 -21 a)))) (labels ((%f1 () (%f18 (%f18 -794761)))) (return-from %f14 b)))))))) (if (%f14) b 887481)))) -51967629256 809047) 809047) (deftest misc.181a (funcall (compile nil '(lambda (a b) (declare (type (integer -982285129 -90) a)) (declare (type (integer 1 82987) b)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (labels ((%f1 (f1-1 &optional (f1-2 -34) (f1-3 3318057) (f1-4 117)) (let ((v9 (let ((v9 (if t (return-from %f1 f1-2) 606042))) f1-1))) (flet ((%f16 (f16-1 f16-2) 292)) (labels ((%f2 (f2-1 f2-2 f2-3 &optional (f2-4 f1-3) (f2-5 f1-4) (f2-6 -418207187)) (%f16 2099 (%f16 f1-2 1157)))) (return-from %f1 (%f2 f1-4 -12066040 v9 122107))))))) (flet ((%f5 (f5-1 &optional (f5-2 (labels ((%f13 (f13-1 f13-2 f13-3 &optional (f13-4 a) (f13-5 b)) 1054213657)) (%f13 b 166441 -3))) (f5-3 20102220) (f5-4 (labels ((%f11 (f11-1 f11-2 f11-3) (%f1 -110148 (%f1 -12336576 f11-1 -61)))) (let ((v1 (apply #'%f11 -29706 a b (list)))) a)))) b)) (labels ((%f17 (f17-1 f17-2 f17-3 &optional (f17-4 -107566292) (f17-5 63) (f17-6 -2)) 105656)) (%f5 (%f17 185703492 a a -511 (%f1 b b -218142 (%f17 -240978 2923208 22 (%f5 1542 68917407 a) b))) -2018 -1)))))) -100 1) 1) ;;; sbcl 0.8.5.40 ;;; Different results from exprs containing ROUND (deftest misc.182 (let* ((form '(labels ((%f14 (f14-1 f14-2) (labels ((%f16 (f16-1 f16-2 &optional (f16-3 (setq f14-1 (ash f14-1 (min 77 b))))) (logandc2 c -100))) (return-from %f14 (* 2 (gcd f14-1 (%f16 c f14-1))))))) (round (%f14 c c) (max 83 (%f14 (multiple-value-call #'%f14 (values 0 2)) 0))))) (fn1 `(lambda (a b c) (declare (type (integer 5628 8762) a)) (declare (type (integer 778 33310188747) b)) (declare (type (integer -6699 4554) c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) ,form)) (fn2 `(lambda (a b c) (declare (notinline values max round gcd * logandc2 min ash)) (declare (optimize (safety 3))) (declare (optimize (speed 0))) (declare (optimize (debug 0))) ,form)) (vals '(7395 1602862793 -2384)) (cfn1 (compile nil fn1)) (cfn2 (compile nil fn2)) (result1 (multiple-value-list (apply cfn1 vals))) (result2 (multiple-value-list (apply cfn2 vals)))) (if (equal result1 result2) :good (values result1 result2))) :good) ;;; sbcl 0.8.5.42 ;;; failed AVER: "(NOT POPPING)" ;;; Also occurs in cmucl (11/2003 snapshot) (deftest misc.183 (funcall (compile nil '(lambda (a b c) (declare (type (integer -368154 377964) a)) (declare (type (integer 5044 14959) b)) (declare (type (integer -184859815 -8066427) c)) (declare (ignorable a b c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (block b7 (flet ((%f3 (f3-1 f3-2 f3-3) 0)) (apply #'%f3 0 (catch 'foo (return-from b7 (%f3 0 b c))) c nil))))) 0 6000 -9000000) 0) (deftest misc.183a (let () (apply #'list 1 (list (catch 'a (throw 'a (block b 2)))))) (1 2)) ;;; sbcl 0.8.5.42 ;;; failed AVER: "(FUNCTIONAL-LETLIKE-P CLAMBDA)" (deftest misc.184 (funcall (compile nil '(lambda (a b c) (declare (type (integer 867934833 3293695878) a)) (declare (type (integer -82111 1776797) b)) (declare (type (integer -1432413516 54121964) c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (if nil (flet ((%f15 (f15-1 &optional (f15-2 c)) (labels ((%f1 (f1-1 f1-2) 0)) (%f1 a 0)))) (flet ((%f4 () (multiple-value-call #'%f15 (values (%f15 c 0) (%f15 0))))) (if nil (%f4) (flet ((%f8 (f8-1 &optional (f8-2 (%f4)) (f8-3 0)) f8-3)) 0)))) 0))) 3040851270 1664281 -1340106197) 0) ;;; sbcl 0.8.5.42 ;;; invalid number of arguments: 1 ;;; ("XEP for LABELS CL-TEST::%F10" ... (deftest misc.185 (funcall (compile nil '(lambda (a b c) (declare (type (integer 5 155656586618) a)) (declare (type (integer -15492 196529) b)) (declare (type (integer 7 10) c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (flet ((%f3 (f3-1 f3-2 f3-3 &optional (f3-4 a) (f3-5 0) (f3-6 (labels ((%f10 (f10-1 f10-2 f10-3) 0)) (apply #'%f10 0 a (- (if (equal a b) b (%f10 c a 0)) (catch 'ct2 (throw 'ct2 c))) nil)))) 0)) (%f3 (%f3 (%f3 b 0 0 0) a 0) a b b b c)))) 5 0 7) 0) (deftest misc.185a (funcall (compile nil '(lambda (a b c) (declare (type (integer -1304066 1995764) a)) (declare (type (integer -52262604195 5419515202) b)) (declare (type (integer -13 94521) c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (flet ((%f13 (f13-1 f13-2 f13-3) 0)) (apply #'%f13 (%f13 b 0 0) (catch 'ct1 0) (catch 'ct2 (throw 'ct2 c)) nil)))) 0 0 0) 0) ;;; sbcl 0.8.5.42 ;;; Different results (deftest misc.186 (let* ((form '(labels ((%f3 (f3-1 f3-2) f3-1)) (apply #'%f3 b (catch 'ct8 (throw 'ct8 (logeqv (%f3 c 0)))) nil))) (vars '(b c)) (fn1 `(lambda ,vars (declare (type (integer -2 19) b) (type (integer -1520 218978) c) (optimize (speed 3) (safety 1) (debug 1))) ,form)) (fn2 `(lambda ,vars (declare (notinline logeqv apply) (optimize (safety 3) (speed 0) (debug 0))) ,form)) (cf1 (compile nil fn1)) (cf2 (compile nil fn2)) (result1 (multiple-value-list (funcall cf1 2 18886))) (result2 (multiple-value-list (funcall cf2 2 18886)))) (if (equal result1 result2) :good (values result1 result2))) :good) ;;; cmucl (11/2003 snapshot) ;;; The assertion (NOT (EQ (C::FUNCTIONAL-KIND C::LEAF) :ESCAPE)) failed. (deftest misc.187 (apply (eval '(function (lambda (a b c) (declare (notinline)) (declare (optimize (safety 3))) (declare (optimize (speed 0))) (declare (optimize (debug 0))) (flet ((%f7 (&optional (f7-1 (catch (quote ct7) 0)) (f7-2 0)) c)) (let ((v8 (flet ((%f14 (f14-1 &optional (f14-2 (%f7 b))) 0)) 0))) (%f7 b)))))) '(2374299 70496 -6321798384)) -6321798384) ;;; ecl bug ;;; Segmentation violation (deftest misc.188 (funcall (compile nil '(lambda (a b c) (declare (notinline floor min funcall)) (declare (optimize (safety 3) (speed 0) (debug 0))) (floor (flet ((%f10 (f10-1 f10-2) b)) (%f10 (%f10 0 0) a)) (min -37 (labels ((%f6 (f6-1 f6-2 f6-3) b)) (funcall #'%f6 b b b)))))) 7187592 -3970792748407 -14760) 1 0) ;;; Wrong number of arguments passed to an anonymous function (deftest misc.189 (funcall (compile nil '(lambda (a b c) (declare (optimize (speed 3) (safety 1) (debug 1))) (let* ((v7 (labels ((%f13 (f13-1 f13-2 f13-3) 0)) (multiple-value-call #'%f13 (values a a a))))) (flet ((%f10 nil v7)) (%f10))))) 1733 3000 1314076) 0) ;;; gcl bug ;;; Error in FUNCALL [or a callee]: # is not of type NUMBER. (deftest misc.190 (let* ((form '(flet ((%f15 () (labels ((%f4 (f4-1) 0)) (flet ((%f6 (&optional (f6-2 (logand (apply #'%f4 (list (%f4 0))) (round (* a))))) -284)) (%f6))))) (funcall #'%f15))) (fn `(lambda (a b c) (declare (notinline values equal abs isqrt < >= byte mask-field funcall + * logcount logand logior round list apply min)) (declare (optimize (safety 3))) (declare (optimize (speed 0))) (declare (optimize (debug 0))) ,form)) (vals '(538754530150 -199250645748 105109641))) (apply (compile nil fn) vals)) -284) ;;; gcl ;;; Error in COMPILER::CMP-ANON [or a callee]: 0 is not of type FUNCTION. (deftest misc.191 (funcall (compile nil '(lambda (a b c) (declare (optimize (speed 3) (safety 1))) (labels ((%f1 nil c)) (flet ((%f12 (f12-1) (labels ((%f9 (f9-1 f9-2 f9-3) (%f1))) (apply #'%f9 (%f9 a b 0) a 0 nil)))) (apply #'%f12 0 nil))))) 0 0 0) 0) ;;; acl 6.2 (trial, x86) ;;; Returns incorrect value (deftest misc.192 (funcall (compile nil '(lambda (a b) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (flet ((%f8 (f8-1 f8-2 f8-3) f8-2)) (catch 'ct6 (%f8 0 b (catch 'ct6 (throw 'ct6 a))))))) 1 2) 2) (deftest misc.193 (let* ((form '(if (if (<= a (truncate c (min -43 b))) (logbitp 0 0) (logbitp 0 -1)) 0 -36223)) (fn1 `(lambda (a b c) (declare (type (integer -3 15350342) a)) (declare (type (integer -4357 -1555) b)) (declare (type (integer 5389300879793 6422214587951) c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) ,form)) (fn2 `(lambda (a b c) (declare (notinline logbitp min truncate <=)) (declare (optimize (safety 3))) (declare (optimize (speed 0))) (declare (optimize (debug 0))) ,form)) (vals '(7792101 -1615 6070931814551)) (result1 (multiple-value-list (apply (compile nil fn1) vals))) (result2 (multiple-value-list (apply (compile nil fn2) vals)))) (if (equal result1 result2) :good (values result1 result2))) :good) ;;; cmucl (4 Nov 2003 snapshot) ;;; The assertion (EQ (C::TN-ENVIRONMENT C:TN) C::TN-ENV) failed. (deftest misc.194 (funcall (compile nil '(lambda (a b c) (declare (notinline funcall)) (declare (optimize (safety 3) (speed 0) (debug 3))) (flet ((%f14 (f14-1 f14-2 &optional (f14-3 0) (f14-4 (catch 'ct8 0)) (f14-5 (unwind-protect c))) 0)) (funcall #'%f14 0 0)))) 1 2 3) 0) ;;; incorrect value (in cmucl) (deftest misc.195 (funcall (compile nil '(lambda (a b) (declare (type (integer -5906488825 254936878485) a)) (declare (type (integer -350857549 -11423) b)) (declare (ignorable a b)) (declare (optimize (speed 3) (safety 1) (debug 1))) (block b8 (labels ((%f6 (f6-1 &optional (f6-2 0) (f6-3 0) (f6-4 0)) 0)) (multiple-value-call #'%f6 (values 0)))))) 100 -100000) 0) ;;; NIL is not of type C::ENVIRONMENT (deftest misc.196 (funcall (compile nil '(lambda (a b) (declare (type (integer 1 46794484349) a)) (declare (type (integer -627 -2) b)) (declare (ignorable a b)) (declare (optimize (speed 3) (safety 1) (debug 1))) (if (not (logbitp 0 0)) 0 (labels ((%f9 (f9-1 f9-2 f9-3) 0)) (%f9 (catch 'ct6 a) (catch 'ct4 0) 0))))) 1 -200) 0) ;;; The assertion (EQ (C::TN-ENVIRONMENT C:TN) C::TN-ENV) failed. (deftest misc.197 (funcall (compile nil '(lambda (a b) (declare (notinline logcount)) (declare (optimize (safety 3) (speed 0) (debug 3))) (labels ((%f5 (&optional (f5-1 b) (f5-2 0) (f5-3 (catch (quote ct2) 0))) (prog1 (logcount (block b1 f5-1))))) (if (%f5 0 0 0) (%f5 a) 0)))) 1 2) 1) ;;; gcl bug (30-11-2003) ;;; Different results ;;; These tests appear to be for the same bug. (deftest misc.198 (let* ((form '(min (catch 'ct4 (throw 'ct4 (setq c 29119897960))) c)) (fn1 `(lambda (c) (declare (type (integer -70450 39128850560) c)) (declare (optimize (speed 3) (safety 1))) ,form))) (funcall (compile nil fn1) 3512352656)) 29119897960) (deftest misc.199 (let* ((fn '(lambda (b) (declare (type (integer 3352138624 13120037248) b)) (declare (optimize (speed 3) (safety 1) (space 1))) (progn (catch 'ct1 (progn (setq b 11159349376) (throw 'ct1 0))) b)))) (funcall (compile nil fn) 4108962100)) 11159349376) ;;; sbcl ;;; "The value 0 is not of type REAL." (???) (deftest misc.200 (funcall (compile nil '(lambda () (declare (optimize (speed 1) (space 0) (safety 3) (debug 3) (compilation-speed 1))) (ceiling (ceiling (flet ((%f16 () 0)) (%f16))))))) 0 0) ;;; ecl 5 Dec 2003 ;;; Wrong number of arguments passed to an anonymous function (deftest misc.201 ;; form to be evaluated (funcall (compile nil '(lambda (a b) (declare (optimize (speed 1) (space 0) (safety 0) (debug 2) (compilation-speed 1))) (flet ((%f10 (f10-1) (return-from %f10 a))) (multiple-value-call #'%f10 (values b))))) 10 -100) ;; expected return value 10) ;;; Does not terminate? (deftest misc.202 (funcall (compile nil '(lambda (a b c) (declare (type (integer -363953100 5324773015552) a)) (declare (type (integer -5744998440960 59520311) b)) (declare (type (integer -1864645998 -14608) c)) (declare (ignorable a b c)) (declare (optimize (speed 3) (space 0) (safety 2) (debug 0) (compilation-speed 2))) (flet ((%f1 (f1-1 f1-2) (labels ((%f1 (f1-1 f1-2) 0)) (%f1 a f1-2)))) (%f1 0 c)))) 10 20 -20000) 0) ;;; # (deftest misc.203 (funcall (compile nil '(lambda (a) (declare (optimize (speed 3) (space 1) (safety 2) (debug 0) (compilation-speed 0))) (labels ((%f18 (f18-1 f18-2 &optional (f18-3 a) (f18-4 a)) f18-2)) (multiple-value-call #'%f18 (values a 0))))) 100) 0) ;;; `env0' undeclared (first use in this function) (deftest misc.204 (funcall (compile nil '(lambda (a b) (declare (type (integer -4801373 -50300) a)) (declare (type (integer -62 -28) b)) (declare (ignorable a b)) (declare (optimize (speed 1) (space 3) (safety 3) (debug 2) (compilation-speed 2))) (flet ((%f12 (f12-1) 0)) (labels ((%f3 (f3-1 f3-2 f3-3 &optional (f3-4 b) (f3-5 b) (f3-6 (labels ((%f9 nil b)) (apply #'%f12 (%f9) nil)))) (%f12 0))) (%f3 b 0 a))))) -2224841 -54) 0) ;;; # is not of type INTEGER. (deftest misc.205 (funcall (compile nil '(lambda (a b) (declare (optimize (speed 3) (space 1) (safety 1) (debug 0) (compilation-speed 3))) (labels ((%f1 nil b)) (flet ((%f11 (f11-1 f11-2 f11-3) 0)) (apply #'%f11 a (logand (%f1)) (flet ((%f13 (f13-1 f13-2) b)) (apply #'%f13 0 0 nil)) nil))))) 100 200) 0) ;;; # is not of type INTEGER. (deftest misc.206 (funcall #'(lambda (a b) (declare (notinline mask-field byte)) (declare (optimize (speed 1) (space 1) (safety 2) (debug 1) (compilation-speed 2))) (mask-field (byte 0 0) (block b3 (labels ((%f14 nil (return-from b3 a))) (%f14))))) 1 2) 0) ;;; # is not of type INTEGER (deftest misc.207 (funcall (compile nil '(lambda (a) (declare (optimize (speed 3) (space 2) (safety 0) (debug 1) (compilation-speed 0))) (labels ((%f3 (f3-1) a)) (labels ((%f10 (f10-1 f10-2) a)) (apply #'%f10 0 (logior (%f3 0)) nil))))) -10000) -10000) ;;; `env0' undeclared (first use in this function) (deftest misc.208 (funcall (compile nil '(lambda (b) (declare (optimize (speed 3) (space 2) (safety 3) (debug 3) (compilation-speed 0))) (flet ((%f6 (f6-1 f6-2 f6-3) f6-3)) (labels ((%f8 (f8-1) (let* ((v1 (%f6 0 0 0))) 0))) (apply #'%f6 b b (%f8 b) nil))))) 10) 0) ;;; Wrong value computed (deftest misc.209 (funcall (compile nil '(lambda (b) (declare (optimize (speed 3) (space 2) (safety 3) (debug 3) (compilation-speed 3))) (max (catch 'ct4 (throw 'ct4 (setq b 0))) b))) 6353) 0) ;;; Wrong value computed (deftest misc.210 (funcall (compile nil '(lambda (c) (declare (type (integer 3 65500689) c)) (declare (optimize (speed 2) (space 1) (safety 3) (debug 3) (compilation-speed 2))) (catch 'ct6 (let ((v10 (truncate (integer-length (throw 'ct6 0))))) c)))) 100) 0) (deftest misc.210a (funcall (compile nil '(lambda (a) (declare (type (integer -55982525 -1) a)) (declare (optimize (speed 1) (space 2) (safety 1) (debug 2) (compilation-speed 1))) (flet ((%f11 (f11-1 f11-2 f11-3) a)) (let ((v6 0)) (flet ((%f12 (f12-1) v6)) (if (<= 0) (%f11 v6 0 0) (multiple-value-call #'%f11 (values 0 0 (%f11 0 0 (apply #'%f12 0 nil)))))))))) -100) -100) ;;; Segmentation violation (deftest misc.211 (funcall (compile nil '(lambda (a b c) (declare (type (integer -1439706333184 1191686946816) a)) (declare (type (integer -28 282229324) b)) (declare (type (integer -108149896 38889958912) c)) (declare (optimize (speed 3) (space 1) (safety 2) (debug 1) (compilation-speed 3))) (let ((v4 (labels ((%f8 (f8-1 &optional (f8-2 0) (f8-3 b)) 0)) (logior (%f8 0) (%f8 0 0))))) (truncate (labels ((%f4 (&optional (f4-1 (ceiling c))) a)) (%f4 v4)) (max 38 (labels ((%f8 (f8-1 &optional (f8-2 (+ c a))) 0)) (apply #'%f8 a nil))))))) -979021452526 138874383 21099308459) -25763722434 -34) ;;; Wrong value returned (deftest misc.212 (funcall #'(lambda () (declare (optimize (speed 2) (space 0) (safety 3) (debug 2) (compilation-speed 0))) (let* ((v9 (unwind-protect 0))) v9))) 0) ;;; segmentation violation (deftest misc.213 (funcall (compile nil '(lambda (a b) (declare (type (integer -2 -1) b)) (declare (optimize (speed 1) (space 0) (safety 1) (debug 1) (compilation-speed 3))) (max (labels ((%f15 (f15-1) b)) (if (< 0 (%f15 a)) 0 0)) (labels ((%f11 (f11-1 f11-2 f11-3) b)) (apply #'%f11 0 0 0 nil))))) 0 -2) 0) (deftest misc.213a (funcall (compile nil '(lambda (a) (declare (optimize (speed 3) (space 3) (safety 0) (debug 1) (compilation-speed 3))) (max (labels ((%f7 (f7-1) a)) (%f7 0)) (flet ((%f12 (f12-1 f12-2) (if a f12-2 0))) (apply #'%f12 0 a nil))))) 123) 123) ;;; Wrong value (deftest misc.214 (funcall (compile nil '(lambda (a) (declare (optimize (speed 3) (space 1) (safety 2) (debug 0) (compilation-speed 2))) (flet ((%f8 nil (setq a 0))) (max a (%f8))))) 100) 100) ;;; Wrong value (deftest misc.215 (funcall (compile nil '(lambda () (declare (optimize (speed 3) (space 3) (safety 3) (debug 0) (compilation-speed 2))) (ldb (byte 26 6) -1252)))) 67108844) (deftest misc.215a (funcall (compile nil '(lambda () (declare (optimize (speed 3) (space 2) (safety 2) (debug 1) (compilation-speed 2))) (ldb (byte 30 0) -407020740)))) 666721084) ;;; Floating point exception (deftest misc.216 (truncate 0 -2549795210) 0 0) (deftest misc.217 (ceiling 0 -2549795210) 0 0) (deftest misc.218 (floor 0 -2549795210) 0 0) ;;; Infinite loop (deftest misc.219 (funcall (compile nil '(lambda () (labels ((%f (a b) (labels ((%f (c d) 0)) (%f 1 2)))) (%f 3 4))))) 0) ;;; #\^E is not of type NUMBER. (deftest misc.220 (funcall (compile nil '(lambda (a b) (declare (type (integer -3218770816 9386121) a)) (declare (type (integer -1 13) b)) (declare (ignorable a b)) (declare (optimize (speed 2) (space 1) (safety 1) (debug 0) (compilation-speed 1))) (labels ((%f18 (f18-1 f18-2 f18-3) a)) (apply #'%f18 0 a (%f18 b (- (labels ((%f11 (f11-1 f11-2 f11-3) a)) (%f11 0 0 0))) a) nil)))) -468614602 3) -468614602) ;;; Floating point exception (deftest misc.221 (truncate 0 3006819284014656913408) 0 0) (deftest misc.222 (ceiling 0 3006819284014656913408) 0 0) (deftest misc.223 (floor 0 3006819284014656913408) 0 0) ;;; clisp (10 Dec 2003 cvs head) ;;; *** - SYMBOL-VALUE: 2 is not a SYMBOL (deftest misc.224 (funcall (compile nil '(lambda (a b c) (declare (optimize (speed 2) (space 3) (safety 0) (debug 1) (compilation-speed 0))) (flet ((%f14 (f14-1 f14-2 &optional (f14-3 c) (f14-4 (if (not nil) (labels ((%f9 nil 0)) (%f9)) a))) (flet ((%f17 (f17-1 f17-2) f14-1)) (%f17 0 f14-3)))) (%f14 (%f14 0 a) 0 b a)))) 248000 5409415 227923) 0) ;;; Wrong values (deftest misc.225 (funcall (compile nil '(lambda () (values (values 'a 'b))))) a) ;;; clisp (12 Dec 2003, 2:30AM CST cvs head) ;;; SYMBOL-VALUE: 1 is not a SYMBOL (deftest misc.226 (funcall (compile nil '(lambda (a) (flet ((%f (&optional (x (setq a 1)) (y (setq a 2))) 0)) (%f 0 0)))) 0) 0) (deftest misc.227 (funcall (compile nil '(lambda (b) (flet ((%f (&optional x (y (setq b 1))) x)) (%f 0)))) 0) 0) ;;; acl (x86 linux 6.2, patched 12 Dec 2003) ;;; No from-creg to move to... (deftest misc.228 (funcall (compile nil '(lambda (a b c) (declare (optimize (speed 1) (space 2) (safety 0) (debug 2) (compilation-speed 2))) (catch 'ct2 (case 0 ((-56087 86404 -94716) (signum (labels ((%f7 (f7-1 f7-2 f7-3) f7-2)) 0))) ((12986) (let ((v3 (catch 'ct2 (throw 'ct2 0)))) (labels ((%f14 (f14-1 f14-2) 0)) (%f14 b c)))) (t 0))))) -3847091255 -13482 -7577750) 0) (deftest misc.228a (funcall (compile nil '(lambda (a b c) (declare (type (integer -249606 2) a)) (declare (type (integer 125 511) b)) (declare (type (integer -2 1) c)) (declare (ignorable a b c)) (declare (optimize (speed 2) (space 2) (safety 1) (debug 3) (compilation-speed 3))) (catch 'ct4 (rational (case b ((350 244 1059) (prog2 (numerator c) 0)) ((1705 493) (unwind-protect (throw 'ct4 c) (loop for lv2 below 2 count (logbitp 0 c)))) (t a)))))) 0 200 -1) 0) (deftest misc.228b (funcall (compile nil '(lambda (c) (declare (type (integer -1 412413109) c)) (declare (optimize (speed 1) (space 2) (safety 2) (debug 1) (compilation-speed 3))) (catch 'ct2 (logior (* (progn (if c 0 (throw 'ct2 0)) 0) (catch 'ct2 (throw 'ct2 0))) (complex c 0) )))) 62151) 62151) ;;; Error: `T' is not of the expected type `INTEGER' (deftest misc.229 (funcall (compile nil '(lambda nil (declare (optimize (speed 2) (space 1) (safety 1) (debug 2) (compilation-speed 3))) (labels ((%f15 (f15-1) 0)) (let ((v4 0)) (catch 'ct5 (%f15 (gcd (catch 'ct5 (let* ((v5 (throw 'ct5 0))) 0)) v4)))))))) 0) ;;; ecl ;;; Wrong result (order of evaluation problem) (deftest misc.230 (funcall (compile nil '(lambda (a) (declare (type (integer -6527559920 -247050) a)) (declare (optimize (speed 1) (space 3) (safety 0) (debug 0) (compilation-speed 3))) (labels ((%f10 (&optional (f10-1 0) (f10-2 (setq a -4456327156))) 0)) (logxor a (%f10 a))))) -3444248334) -3444248334) ;;; cmucl ;;; Wrong value (deftest misc.231 (funcall (compile nil '(lambda (b) (declare (type (integer -5209401 3339878) b)) (declare (optimize (speed 1) (space 2) (safety 0) (debug 2) (compilation-speed 3))) (flet ((%f3 (f3-1 f3-2) f3-1)) (apply #'%f3 0 (logxor (catch 'ct2 b) (catch 'ct5 (throw 'ct5 0))) nil)))) -2179757) 0) ;;; Invalid number of arguments: 1 (deftest misc.232 (funcall (compile nil '(lambda (a b) (declare (type (integer 197447754 495807327) a)) (declare (type (integer -125379462 1863191461) b)) (declare (optimize (speed 2) (space 2) (safety 2) (debug 1) (compilation-speed 2))) (flet ((%f8 (&optional (f8-1 (max (catch (quote ct4) 0) (catch (quote ct6) (throw (quote ct6) 0))))) b)) (flet ((%f16 (f16-1 f16-2 f16-3) 0)) (apply #'%f16 a 0 (%f8) nil))))) 348270365 28780966) 0) ;;; The assertion (EQ C::CHECK :SIMPLE) failed. (deftest misc.233 (funcall (compile nil '(lambda (a b) (declare (type (integer -2333758327203 -321096206070) a)) (declare (type (integer -2842843403569 258395684270) b)) (declare (optimize (speed 2) (space 0) (safety 1) (debug 2) (compilation-speed 2))) (flet ((%f18 (f18-1) (the integer (labels ((%f9 (f9-1 f9-2) (* (- -1 -210032251) (1+ (floor (labels ((%f11 (f11-1 f11-2) -96773966)) (%f11 b -3440758))))))) (flet ((%f2 (f2-1 f2-2 f2-3 &optional (f2-4 (%f9 -429204 -63)) (f2-5 (- (%f9 b 17) a)) (f2-6 (multiple-value-call #'%f9 (values (let () 7127585) (flet ((%f1 (f1-1 f1-2 f1-3) (catch 'ct6 -569234))) (macrolet () 13)))))) 1027)) (if nil (%f2 b a f18-1 69968 4 -217193265) (catch 'ct1 129548688))))))) (max (apply #'%f18 (list 0)))))) -2067244683733 143879071206) 129548688) ;;; NIL is not of type C::TAIL-SET (deftest misc.234 (funcall (compile nil '(lambda (b) ;; (a b) (declare (type (integer -13583709 -3876310) b)) (declare (optimize (speed 1) (space 2) (safety 3) (debug 3) (compilation-speed 1))) (flet ((%f14 (f14-1 f14-2 f14-3) (flet ((%f2 (f2-1 &optional (f2-2 0) (f2-3 0) (f2-4 (block b8 (if (ldb-test (byte 0 0) 0) (* 0 f14-2) 0)))) 0)) (%f2 b f14-2)))) (%f14 0 0 (%f14 0 0 0))))) ;; -155589 -5694124) 0) ;;; sbcl 0.8.6.34 ;;; Wrong value (deftest misc.235 (funcall (compile nil '(lambda (b) (declare (notinline not)) (declare (optimize (speed 1) (space 0) (safety 0) (debug 2) (compilation-speed 3))) (multiple-value-prog1 0 (catch 'ct2 (if (not nil) (throw 'ct2 b) 0))))) :wrong) 0) (deftest misc.236 (funcall (compile nil '(lambda (a b) (declare (optimize (speed 1) (space 0) (safety 3) (debug 0) (compilation-speed 1))) (flet ((%f8 (f8-1) 0)) (labels ((%f18 (f18-1 f18-2 &optional (f18-3 0)) (%f8 (catch 'ct7 (throw 'ct7 f18-1))))) (multiple-value-prog1 (catch 'ct7 a) 0 (multiple-value-call #'%f18 (values 0 (%f8 b)))))))) :good :bad) :good) (deftest misc.237 (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 2) (safety 3) (debug 3) (compilation-speed 1))) (multiple-value-prog1 0 (catch 'ct7 (logandc1 (block b7 0) (throw 'ct7 -908543))))))) 0) ;;; cmucl (11 2003 snapshot) ;;; NIL is not of type C::CONTINUATION (deftest misc.238 (funcall (compile nil '(lambda (a) (declare (type (integer -77145797 -1) a)) (declare (optimize (speed 1) (space 1) (safety 3) (debug 3) (compilation-speed 1))) (flet ((%f5 (f5-1) a)) (%f5 (unwind-protect 0 (logand (- (catch 'ct5 0)))))))) -100) -100) (deftest misc.238a (funcall (compile nil '(lambda () (declare (optimize (speed 3) (space 2) (safety 3) (debug 0) (compilation-speed 0))) (min (load-time-value 0)) 0))) 0) ;;; (in C::MAYBE-LET-CONVERT) (deftest misc.239 (funcall (compile nil '(lambda (a) (declare (type (integer -2315418108387 111852261677) a)) (declare (optimize (speed 2) (space 0) (safety 2) (debug 2) (compilation-speed 1))) (labels ((%f4 () (labels ((%f16 (f16-1 f16-2) 0)) (flet ((%f9 () 0)) (%f16 0 (%f16 (%f9) a)))))) (flet ((%f10 (f10-1 f10-2 f10-3) (flet ((%f15 (f15-1 &optional (f15-2 (%f4)) (f15-3 0)) f15-3)) 0))) 0)))) 100) 0) (deftest misc.239a (funcall (compile nil '(lambda () (declare (optimize speed safety)) (LET ((x (PROG1 0 (ROUND 18916)))) (catch 'ct4 0))))) 0) (deftest misc.240 (funcall (compile nil '(lambda (b) (declare (type (integer 4 7) b)) (declare (optimize (speed 2) (space 3) (safety 3) (debug 1) (compilation-speed 3))) (unwind-protect 0 (common-lisp:handler-case (max (let ((*s1* b)) (declare (special *s1*)) (+ 0 *s1*))))))) 5) 0) ;;; clisp (12 Dec 2003 cvs head) ;;; *** - Compiler bug!! Occurred in ASSEMBLE-LAP at ILLEGAL INSTRUCTION. (deftest misc.241 (funcall (compile nil '(lambda () (declare (optimize (speed 3) (space 3) (safety 0) (debug 0) (compilation-speed 2))) (labels ((%f17 (f17-1 f17-2) (multiple-value-prog1 0 0 0 (return-from %f17 0)))) (%f17 0 0))))) 0) (deftest misc.242 (funcall (compile nil '(lambda (a) (block b6 (multiple-value-prog1 a (return-from b6 0))))) :wrong) 0) (deftest misc.243 (funcall (compile nil '(lambda () (block b3 (return-from b3 (multiple-value-prog1 0 (return-from b3 0))))))) 0) ;;; lispworks 4.3 (personal edition) (deftest misc.244 (funcall (compile nil '(lambda (b) (declare (optimize (speed 3) (space 1) (safety 2) (debug 3) (compilation-speed 2))) (catch 'ct8 (labels ((%f4 (&optional (f4-1 0) (f4-2 (throw 'ct8 0))) f4-1)) (%f4 b))))) :wrong) 0) (deftest misc.245 (funcall (compile nil '(lambda (a) (declare (optimize (speed 2) (space 0) (safety 0) (debug 2) (compilation-speed 1))) (catch 'ct2 (labels ((%f11 (&optional (f11-1 (throw 'ct2 0))) a)) (apply #'%f11 0 nil))))) 20) 20) ;;; ecl (cvs head, 18 Dec 2003) (deftest misc.246 (let ((x (unwind-protect 0))) x) 0) (deftest misc.247 (let ((x (dotimes (i 0 10)))) x) 10) ;;; acl 6.2 trial ;;; "Error: Attempt to access the plist field of 0 which is not a symbol." (deftest misc.248 (funcall (compile nil '(lambda () (dotimes (i 0 0) 0)))) 0) ;;; sbcl ;;; # ;;; not found in ;;; # (deftest misc.249 (funcall (compile nil '(lambda (a b) (declare (notinline <=)) (declare (optimize (speed 2) (space 3) (safety 0) (debug 1) (compilation-speed 3))) (if (if (<= 0) nil nil) (labels ((%f9 (f9-1 f9-2 f9-3) (ignore-errors 0))) (dotimes (iv4 5 a) (%f9 0 0 b))) 0))) 1 2) 0) ;;; cmucl 11/2003 (deftest misc.250 (funcall (compile nil '(lambda (a) (declare (type (integer -12 14) a)) (declare (optimize (speed 1) (space 2) (safety 1) (debug 1) (compilation-speed 3))) (let ((v6 0)) (flet ((%f11 (f11-1 &optional (f11-2 (case (catch 'ct7 0) (t (let* ((v2 (ignore-errors a))) v6))))) 0)) (%f11 0 0))))) 5) 0) ;;; NIL is not of type C::CONTINUATION ;;; (C::MAYBE-CONVERT-TO-ASSIGNMENT ;;; # ;;; WHERE-FROM= :DEFINED ;;; VARS= (F3-1 F3-2 F3-3)>) (deftest misc.251 (funcall (compile nil '(lambda (a b) (declare (type (integer -186585769 -7483) a)) (declare (type (integer -550 524) b)) (declare (optimize (speed 2) (space 1) (safety 1) (debug 2) (compilation-speed 3))) (flet ((%f3 (f3-1 f3-2 f3-3) 0)) (%f3 0 0 (flet ((%f13 (f13-1 f13-2) 0)) (if (/= b a) b (deposit-field (%f3 0 b 0) (byte 0 0) (%f3 0 0 (%f13 0 0))))))))) -10000 0) 0) ;;; 8061593093 is not of type (INTEGER -2147483648 4294967295) (deftest misc.252 (funcall (compile nil '(lambda (b) (declare (type (integer -43443 9126488423) b)) (declare (optimize (speed 3) (space 1) (safety 1) (debug 3) (compilation-speed 0))) (logand (setq b 8061593093) (min b 0)))) 0) 0) (deftest misc.252a (funcall (compile nil '(lambda (a b) (declare (type (integer -30189 -6047) a)) (declare (type (integer -10 16391481067) b)) (declare (optimize (speed 3) (space 1) (safety 2) (debug 3) (compilation-speed 0))) (if (<= 0 (let ((*s1* (setq b 12204309028))) (declare (special *s1*)) (truncate b))) a 0))) -12618 16130777867) -12618) ;;; # fell through ETYPECASE expression. ;;; Wanted one of (C::BASIC-COMBINATION C::EXIT C::CRETURN C::CSET C::CIF ;;; (OR C::REF C:BIND)). ;;; [Condition of type CONDITIONS::CASE-FAILURE] ;;;[...] ;;; (C::SUBSTITUTE-CONTINUATION # #) (deftest misc.253 (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 2) (safety 3) (debug 3) (compilation-speed 2))) (flet ((%f17 (f17-1) 0)) (%f17 (logandc1 0 (catch 'ct2 0))))))) 0) (deftest misc.253a (funcall (compile nil '(lambda (c) (declare (optimize (speed 1) (space 1) (safety 3) (debug 2) (compilation-speed 1))) (labels ((%f1 (f1-1 f1-2) (isqrt (abs (complex f1-1 0))))) (progn (/ (multiple-value-call #'%f1 (values (1- (restart-bind nil 1416182210)) 123337746)) 1) (tagbody) c)))) -34661) -34661) ;;; Wrong return value (deftest misc.254 (funcall (compile nil '(lambda (a) (declare (type (integer -5241 -1159) a)) (declare (optimize (speed 3) (space 2) (safety 0) (debug 3) (compilation-speed 1))) (gcd a (let ((*misc.254* (setq a -4929))) ;; special variable (declare (special *misc.254*)) 0)))) -3000) 3000) (deftest misc.255 (funcall (compile nil '(lambda (b) (declare (type (integer -3474321 15089206) b)) (declare (optimize (speed 3) (space 3) (safety 3) (debug 3) (compilation-speed 0))) (- b (block b3 (setq b 9367613) 0)))) 10) 10) ;;; clisp (20 Dec 2003) ;;; Bug involving tagbody and go in lexical function (deftest misc.256 (funcall (compile nil '(lambda () (declare (optimize (speed 3) (space 0) (safety 3) (debug 0) (compilation-speed 0))) (tagbody (flet ((%f6 () (go 18))) (%f6)) 18)))) nil) ;;; clisp (22 Dec 2003) ;;; *** - Compiler bug!! Occurred in ACCESS-IN-STACK at STACKZ-END. (deftest misc.257 (funcall (compile nil '(lambda () (declare (optimize (speed 1) (space 2) (safety 3) (debug 3) (compilation-speed 1))) (declare (special b)) (tagbody (flet ((%f1 (f1-1) (flet ((%f9 (&optional (f9-1 b) (f9-2 (go tag2)) (f9-3 0)) 0)) (%f9 0 0 0)))) (%f1 0)) tag2)))) nil) ;;; clisp (26 Dec 2003) ;;; PROGV binding is not having the correct effect in compiled code (deftest misc.258 (funcall (compile nil '(lambda () (declare (optimize (speed 1) (space 2) (safety 1) (debug 1) (compilation-speed 0))) (let ((*s4* :right)) (declare (special *s4*)) (progv '(*s4*) (list :wrong1) (setq *s4* :wrong2)) *s4*)))) :right) ;;; sbcl 0.8.7.5 ;;; The value 215067723 is not of type (INTEGER 177547470 226026978). (deftest misc.259 (funcall (compile nil '(lambda (a) (declare (type (integer 177547470 226026978) a)) (declare (optimize (speed 3) (space 0) (safety 0) (debug 0) (compilation-speed 1))) (logand a (* a 438810)))) 215067723) 13739018) (deftest misc.260 (funcall (compile nil '(lambda (a) (declare (type (integer 43369342 45325981) a)) (declare (optimize (speed 2) (space 0) (safety 2) (debug 0) (compilation-speed 3))) (logand 0 (* 5459177 a)))) 44219966) 0) (deftest misc.261 (funcall (compile nil '(lambda (b) (declare (type (integer 379442022 806547932) b)) (declare (optimize (speed 2) (space 0) (safety 0) (debug 3) (compilation-speed 2))) (logand b (* 227 b)))) 551173513) 545263625) (deftest misc.262 (funcall (compile nil '(lambda (a) (declare (type (integer 515644 54674673) a)) (declare (optimize (speed 3) (space 2) (safety 3) (debug 0) (compilation-speed 1))) (mask-field (byte 0 0) (* 613783109 a)))) 28831407) 0) (deftest misc.263 (funcall (compile nil '(lambda (a) (declare (type (integer 862944 60462138) a)) (declare (optimize (speed 3) (space 3) (safety 0) (debug 1) (compilation-speed 1))) (logandc2 0 (* a 18094747)))) 36157847) 0) (deftest misc.264 (funcall (compile nil '(lambda (a) (declare (type (integer 896520522 1249309734) a)) (declare (optimize (speed 3) (space 3) (safety 1) (debug 1) (compilation-speed 2))) (lognand 0 (* a 1381212086)))) 1202966173) -1) ;;; sbcl 0.8.7.6 ;;; Lisp error during constant folding: ;;; The function SB-VM::%LEA-MOD32 is undefined. (deftest misc.265 (funcall (compile nil '(lambda (a) (declare (type (integer -19621 11895) a)) (declare (optimize (speed 3) (space 2) (safety 3) (debug 3) (compilation-speed 3))) (* 0 a 103754))) 1) 0) ;;; ecl (10 jan 2004) ;;; A bug was found in the compiler. Contact worm@arrakis.es. ;;; Broken at C::C2GO. (deftest misc.266 (funcall (compile nil '(lambda () (tagbody (flet ((%f (x) :bad)) (multiple-value-call #'%f (go done))) done)))) nil) (deftest misc.266a (funcall (compile nil '(lambda (b) (declare (type (integer -14356828946432 -24266) b)) (declare (optimize (speed 3) (space 1) (safety 1) (debug 3) (compilation-speed 2))) (progn (tagbody (unwind-protect 0 (go 3)) 3) b))) -30000) -30000) ;;; Broken at C::C2VAR. (deftest misc.266b (funcall (compile nil '(lambda (b) (declare (optimize (speed 2) (space 3) (safety 2) (debug 0) (compilation-speed 0))) (unwind-protect 0 (catch 'ct7 (prog1 b 0))))) 1) 0) ;;; Incorrect return value (deftest misc.267 (locally (declare (special *s5*)) (let ((v8 (progv '(*s5*) (list 0) (if t *s5* *s5*)))) v8)) 0) (deftest misc.267a (let ((x (progv nil nil 0))) x) 0) (deftest misc.268 (funcall (compile nil '(lambda () (declare (optimize (speed 1) (space 1) (safety 3) (debug 2) (compilation-speed 2))) (catch 'ct7 (rationalize (let ((v9 (1+ (throw 'ct7 0)))) 48955)))))) 0) (deftest misc.269 (funcall (compile nil '(lambda (a) (declare (type (integer -1 20) a)) (declare (optimize (speed 3) (space 1) (safety 2) (debug 2) (compilation-speed 3))) (if (if a (logbitp 34 a) nil) 0 -230678))) 14) -230678) (deftest misc.270 (let ((*s3* (dotimes (iv4 0 10) (if t iv4 8)))) (declare (special *s3*)) *s3*) 10) (deftest misc.271 (let ((v2 (unwind-protect 0))) v2) 0) ;;; wrong number of values passed to anonymous function (deftest misc.272 (funcall (compile nil '(lambda () (declare (optimize (speed 3) (space 1) (safety 0) (debug 3) (compilation-speed 2))) (flet ((%f17 (f17-1) 1)) (multiple-value-call #'%f17 (values (floor 0))))))) 1) ;;; clisp (10 jan 2004) ;;; Improper handling of a jump to an exit point from unwind-protect ;;; (see CLHS section 5.2) (deftest misc.273 (funcall (compile nil '(lambda (d) (declare (optimize (speed 3) (space 0) (safety 3) (debug 2) (compilation-speed 0))) (gcd 39 (catch 'ct2 (block b7 (throw 'ct2 (unwind-protect (return-from b7 17) (return-from b7 (progv '(*s6*) (list 31) d)) ))))))) 65) 13) ;;; sbcl 0.8.7.13 ;;; Lexical unwinding of UVL stack is not implemented. (deftest misc.274 (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 2) (safety 1) (debug 2) (compilation-speed 0))) (multiple-value-prog1 (ignore-errors 0) 0 (catch 'ct7 0) (catch 'ct1 (catch 'ct4 (complex (throw 'ct4 (dotimes (iv4 0 0) (throw 'ct1 0))) 0))))))) 0) (deftest misc.274a (funcall (compile nil '(lambda () (declare (optimize (speed 3) (space 1) (safety 3) (debug 1) (compilation-speed 3))) (dotimes (iv4 3 0) (apply (constantly 0) 0 (catch 'ct2 (throw 'ct2 (rem 0 (max 46 0)))) nil))))) 0) ;;; failed AVER: "SUCC" (deftest misc.275 (funcall (compile nil '(lambda (b) (declare (notinline funcall min coerce)) (declare (optimize (speed 1) (space 2) (safety 2) (debug 1) (compilation-speed 1))) (flet ((%f12 (f12-1) (coerce (min (if f12-1 (multiple-value-prog1 b (return-from %f12 0)) 0)) 'integer))) (funcall #'%f12 0)))) -33) 0) (deftest misc.275a (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 0) (safety 2) (debug 1) (compilation-speed 1))) (block b4 (coerce (logcount (if t 0 (multiple-value-prog1 (identity 0) (return-from b4 0)))) 'integer))))) 0) ;;; clisp (28 Jan 2004) ;;; Different return values (deftest misc.276 (funcall (compile nil `(lambda (b) (declare (optimize (speed 2) (space 0) (safety 0) (debug 3) (compilation-speed 3))) (labels ((%f2 () (let ((v10 (progn (dotimes (iv2 0 0) iv2) b))) (unwind-protect b (labels ((%f6 ())) (%f6)) )))) (%f2)))) :good) :good) ;;; Lispworks 4.3 linux (personal edition) ;;; Error: In - of (1 NIL) arguments should be of type NUMBER (deftest misc.277 (funcall (compile nil '(lambda () (declare (optimize (speed 3) (space 1) (safety 0) (debug 3) (compilation-speed 0))) (labels ((%f15 (&optional (f15-3 (tagbody (labels ((%f6 () (go tag1))) (%f6)) tag1))) 0)) (%f15))))) 0) ;;; incorrect return value (deftest misc.278 (funcall (compile nil '(lambda () (declare (optimize (speed 1) (space 0) (safety 2) (debug 3) (compilation-speed 0))) (catch 'ct5 (flet ((%f2 (&optional (f2-4 (throw 'ct5 0))) 1)) (%f2 (%f2 0))))))) 1) ;;; incorrect return value (deftest misc.279 (funcall (compile nil '(lambda () (declare (optimize (speed 1) (space 1) (safety 3) (debug 0) (compilation-speed 3))) (flet ((%f10 () (if (< 0 (dotimes (iv2 1 -501162))) 0 -14))) (%f10))))) -14) ;;; incorrect return value (may be same bug as misc.278) (deftest misc.280 (funcall (compile nil '(lambda (a) (declare (optimize (speed 1) (space 3) (safety 1) (debug 3) (compilation-speed 2))) (catch 'ct6 (labels ((%f12 () (labels ((%f14 (&optional (f14-3 (return-from %f12 5))) 4)) (funcall (constantly 3) (let ((v2 (%f14))) 2) (throw 'ct6 1) )))) (%f12) a)))) :good) :good) ;;; incorrect return value (deftest misc.281 (funcall (compile nil '(lambda (c) (declare (optimize (speed 3) (space 3) (safety 3) (debug 2) (compilation-speed 3))) (ldb (byte 24 0) c))) -227016367797) 12919115) ;;; gcl: Error in COMPILER::CMP-ANON [or a callee]: The function COMPILER::LDB1 is undefined. (deftest misc.282 (funcall (compile nil '(lambda () (declare (optimize safety)) (ldb (byte 13 13) 43710)))) 5) ;;; gcl (2/28/2004) ;;; Error in COMPILER::CMP-ANON [or a callee]: T is not of type INTEGER. (deftest misc.283 (funcall (compile nil '(lambda (b d) (declare (optimize (speed 2) (space 2) (safety 1) (compilation-speed 3))) (expt (logxor (progn (tagbody (multiple-value-prog1 0 (go 7)) 7) 0) 0 b (rational d)) 0))) 2 4) 1) ;;; Error in COMPILER::CMP-ANON [or a callee]: 3 is not of type FUNCTION. ;;; (possibly the same bug as misc.283) (deftest misc.284 (funcall (compile nil '(lambda (c) (declare (optimize (speed 1) (space 1) (safety 2) (debug 3) (compilation-speed 2))) (progn (tagbody (multiple-value-prog1 0 (go tag2)) 0 tag2) (funcall (constantly 0) (apply (constantly 0) (signum c) nil))))) 3) 0) ;;; ecl 29 Feb 2004 ;;; Incorrect constant propagation (deftest misc.285 (funcall (compile nil '(lambda (a) (declare (optimize (speed 2) (space 0) (safety 0) (debug 2) (compilation-speed 3))) (block b7 (let* ((v1 (* (return-from b7 0) a))) -4359852)))) 1) 0) (deftest misc.286 (let ((v4 (dotimes (iv4 0 18494910) (progn 0)))) v4) 18494910) ;;; gcl (found by Camm) ;;; Error in COMPILER::CMP-ANON [or a callee]: The function NIL is undefined. (deftest misc.287 (funcall (compile nil '(lambda (e) (declare (optimize (speed 1) (space 3) (safety 3) (debug 3) (compilation-speed 1))) (flet ((%f11 (f11-2) 0)) (%f11 (unwind-protect e (tagbody (let* ((v4 (unwind-protect (go 0)))) 0) 0) (logand (handler-bind () 0))))))) 10) 0) #| ecl (6 Mar 2004) (LAMBDA (C::LOC1 C::LOC2) (IF (AND (CONSP C::LOC1) (EQ (CAR C::LOC1) 'FIXNUM) (CONSP (CADR C::LOC1)) (EQ (CAADR C::LOC1) 'C::FIXNUM-VALUE) (EQ (CADR (CADR C::LOC1)) 2)) (PROGN (C::WT1 "(1<<(") (C::WT1 C::LOC2) (C::WT1 "))")) (PROGN (C::WT1 "fixnum_expt(") (C::WT1 C::LOC1) (C::WT1 #\,) (C::WT1 C::LOC2) (C::WT1 #\))))) is not of type STRING. Broken at C::WT-C-INLINE-LOC. |# (deftest misc.288 (funcall (compile nil '(lambda () (declare (optimize (speed 1) (space 2) (safety 3) (debug 3) (compilation-speed 2))) (let ((v2 (integer-length (expt 0 0)))) (dotimes (iv4 0 0) (logand v2)))))) 0) ;;; cmucl ;;; wrong return value (deftest misc.289 (funcall (compile nil '(lambda (b) (declare (optimize (speed 3) (space 1) (safety 1) (debug 2) (compilation-speed 2))) (multiple-value-prog1 (apply (constantly 0) b 0 0 nil) (catch 'ct8 (throw 'ct8 -2))))) 1) 0) ;;; sbcl (0.8.8.23.stack.1) ;;; failed AVER: "(TAILP BLOCK2-STACK BLOCK1-STACK)" (deftest misc.290 (funcall (compile nil '(lambda () (declare (optimize (speed 3) (space 3) (safety 1) (debug 2) (compilation-speed 0))) (apply (constantly 0) (catch 'ct2 0) 0 (catch 'ct2 0) nil)))) 0) (deftest misc.290a (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 1) (safety 0) (debug 0) (compilation-speed 0))) (boole boole-nor (expt (let ((v2 (expt (catch 'ct7 0) 0))) 0) 0) (expt (apply (constantly 0) 0 0 (catch 'ct6 0) nil) 0))))) -2) ;; Allegro CL 6.2 (14 Mar 2004) interpreter bug ;; Error: Cannot go to TAG, its body has been exited. (deftest misc.291 (funcall #'(lambda (a) (declare (notinline numerator)) (declare (optimize (speed 2) (space 3) (safety 2) (debug 0) (compilation-speed 2))) (tagbody (tagbody (progn a) tag) (go tag) tag)) 17) nil) ;;; sbcl 0.8.8.23.stack.2 ;;; The value -1 is not of type (MOD 536870911). (deftest misc.292 (funcall (compile nil '(lambda (a b c) (declare (optimize (speed 3) (space 2) (safety 3) (debug 0) (compilation-speed 1))) (flet ((%f15 (f15-1 f15-2 f15-3) (apply (constantly 0) 0 0 (ignore-errors (let ((v10 (apply (constantly 0) b a (max 0 c) nil))) 0)) nil))) (flet ((%f14 (f14-1 &optional (f14-2 b) (f14-3 0) (f14-4 0)) (%f15 0 0 b))) (%f14 0 c))))) 1 2 3) 0) (deftest misc.292a (funcall (compile nil '(lambda (a b) (declare (optimize (speed 2) (space 0) (safety 3) (debug 1) (compilation-speed 2))) (apply (constantly 0) a 0 (catch 'ct6 (apply (constantly 0) 0 0 (let* ((v1 (let ((*s7* 0)) b))) 0) 0 nil)) 0 nil))) 1 2) 0) ;;; failed AVER: "(NOT (MEMQ PUSH END-STACK))" (deftest misc.293 (funcall (compile nil '(lambda (a) (declare (optimize (speed 2) (space 1) (safety 3) (debug 3) (compilation-speed 3))) (let ((v6 (labels ((%f9 (f9-1) (multiple-value-prog1 0 (return-from %f9 0) a))) (let ((*s4* (%f9 0))) 0)))) 0))) 1) 0) (deftest misc.293a (funcall (compile nil '(lambda (a b c) (declare (optimize (speed 2) (space 3) (safety 1) (debug 2) (compilation-speed 2))) (block b6 (multiple-value-prog1 0 b 0 (catch 'ct7 (return-from b6 (catch 'ct2 (complex (cl::handler-bind nil -254932942) 0)))))))) 1 2 3) -254932942) (deftest misc.293b (funcall (compile nil '(lambda () (declare (notinline complex)) (declare (optimize (speed 1) (space 0) (safety 1) (debug 3) (compilation-speed 3))) (flet ((%f () (multiple-value-prog1 0 (return-from %f 0)))) (complex (%f) 0))))) 0) (deftest misc.293c (funcall (compile nil '(lambda (a b) (declare (type (integer -6556 -33) a)) (declare (type (integer -1973908574551 1125) b)) (declare (ignorable a b)) (declare (optimize (compilation-speed 0) (space 2) (safety 0) (debug 2) (speed 0) #+sbcl (sb-c:insert-step-conditions 0) )) (block b4 (multiple-value-prog1 0 (catch 'ct7 (return-from b4 (catch 'ct6 (if a 0 b)))) 0 0)))) -237 -1365751422718) 0) (deftest misc.293d (funcall (compile nil '(lambda () (declare (optimize (debug 3) (safety 0) (space 2) (compilation-speed 2) (speed 2))) (block b4 (multiple-value-prog1 0 (catch 'ct8 (return-from b4 (catch 'ct2 (progn (tagbody) 0))))))))) 0) ;;; failed AVER: "(SUBSETP START START-STACK)" (deftest misc.294 (funcall (compile nil '(lambda (a b c) (declare (notinline /=)) (declare (optimize (speed 2) (space 0) (safety 1) (debug 0)(compilation-speed 1))) (catch 'ct1 (flet ((%f1 (f1-1 f1-2 f1-3) (throw 'ct1 (if (/= 0) 0 (multiple-value-prog1 0 (throw 'ct1 a) c))))) (let ((*s3* (%f1 a a 0))) 0))))) 1 2 3) 0) (deftest misc.294a (funcall (compile nil '(lambda (a b c) (declare (notinline expt)) (declare (optimize (speed 1) (space 2) (safety 3) (debug 0) (compilation-speed 0))) (catch 'ct2 (expt (catch 'ct2 (throw 'ct2 (if a 0 (multiple-value-prog1 0 (throw 'ct2 c) 0)))) 0)))) 1 2 3) 1) ;;; The value NIL is not of type SB-C::IR2-BLOCK. (deftest misc.295 (funcall (compile nil '(lambda (a b c) (declare (type (integer -2858 1050811) a)) (declare (type (integer -419372 1395833) b)) (declare (type (integer -4717708 795706) c)) (declare (ignorable a b c)) (declare (optimize (speed 1) (space 0) (safety 2) (debug 1) (compilation-speed 2))) (multiple-value-prog1 (the integer (catch 'ct8 (catch 'ct5 (catch 'ct7 (flet ((%f3 (f3-1 f3-2 &optional (f3-3 a) (f3-4 c)) b)) (labels ((%f13 (f13-1 f13-2 f13-3) (let* ((*s4* (return-from %f13 (flet ((%f18 (f18-1 f18-2) (apply #'%f3 (progv nil nil f13-2) (list (%f3 -460 f18-1 10095 352819651))))) (flet ((%f5 () (funcall #'%f3 f13-2 (flet ((%f14 (f14-1 f14-2 &optional (f14-3 f13-2) (f14-4 -15)) 160080387)) -196377) (isqrt (abs (if (/= 117 (%f18 -14 -46574)) (return-from %f13 (ignore-errors (flet ((%f12 (f12-1 f12-2 &optional (f12-3 740148786) (f12-4 -20) (f12-5 -35261)) f12-3)) (%f3 (%f3 b (%f12 c b f13-3 f13-1 -1124)) 0 -1003264058 f13-1)))) (block b3 (labels ((%f15 () f13-2)) -4858377))))) (%f3 793 f13-2 f13-3 a)))) f13-3))))) (* -420793 (%f3 (%f3 f13-1 f13-3 f13-3 f13-2) 0 8604 f13-1))))) (lognor (progv nil nil (if (< -16 c) 15867134 (- (throw 'ct5 (prog1 7 (floor (max (%f13 -4862 -888 -53824112) a -17974 1540006) (min -74 -473379))))))) (progv nil nil (prog1 b 22 c a))))))))) (catch 'ct1 (throw 'ct1 0)) 0))) 794801 211700 -1246335) 7) ;;; Tests added by Camm for gcl (deftest misc.296 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -2016726144 234357120) a)) (declare (type (integer -10569521299456 -1307998945280) b)) (declare (type (integer -45429002240 -17228484608) c)) (declare (type (integer 228451840 1454976512) d)) (declare (type (integer -4797 -2609) e)) (declare (type (integer -21 36300536) f)) (declare (type (integer -15983530 31646604) g)) (declare (type (integer -208720272 -357) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 1) (space 3) (safety 3) (debug 0) (compilation-speed 3))) (expt (labels ((%f14 (f14-1 f14-2) (progn (tagbody (+ (unwind-protect (labels ((%f1 (f1-1) (go tag1))) (let ((*s6* (%f1 d))) 0)))) tag1 (+ (cl::handler-bind () (if (<= -11215713 -819) (integer-length (floor (conjugate f14-1) (max 12 (ceiling (block b2 (catch 'ct2 (ignore-errors (flet ((%f13 (f13-1) (logior 87 f14-2))) f14-1)))))))) (progv '(*s8*) (list 472865632) *s8*))))) 0))) (%f14 0 0)) 0))) -28594854 -3859203606860 -40757449218 894599577 -4163 11621230 29558853 -92216802) 1) (deftest misc.297 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -4354712743936 666241234) a)) (declare (type (integer -23496787232 13342697120) b)) (declare (type (integer -6834570 6274788) c)) (declare (type (integer -1988742 -250650) d)) (declare (type (integer 10523345 10868247) e)) (declare (type (integer -489185 -46267) f)) (declare (type (integer -627627253760 226529) g)) (declare (type (integer -1039260485 -22498) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 1) (space 3) (safety 2) (debug 2) (compilation-speed 0))) (labels ((%f7 (f7-1 f7-2 f7-3 &optional (f7-4 0) (f7-5 0) (f7-6 (labels ((%f6 (f6-1) (labels ((%f9 (f9-1) 0)) (progn (tagbody (unwind-protect (if (%f9 (go tag4)) 0 0)) tag4 (cl::handler-case 0)) h)))) (apply #'%f6 0 nil)))) 0)) (%f7 0 d 0 f d)))) -4319330882538 -3195059121 -2799927 -1466395 10630639 -224479 -502579707077 -985908422) 0) (deftest misc.298 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer 1296736620544 1680954654720) a)) (declare (type (integer -2 -2) b)) (declare (type (integer 1 42303) c)) (declare (type (integer -38881008000 1333202563072) d)) (declare (type (integer -435684 1289298) e)) (declare (type (integer -164302654464 -10150328832) f)) (declare (type (integer 30759259904 38429537792) g)) (declare (type (integer -1628949299200 -47724342) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 3) (space 1) (safety 0) (debug 0) (compilation-speed 1))) (progn (tagbody (let ((v9 (unwind-protect (go 0)))) 0) 0 (numerator (funcall (constantly 0) (logorc2 0 0) 0))) 0))) 1451922002679 -2 285 1067997670626 1115209 -37445463114 36530345360 -80501559891) 0) (deftest misc.299 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -1814 3348) a)) (declare (type (integer -32239015 12) b)) (declare (type (integer 128412 101411593) c)) (declare (type (integer -329076792320 -22) d)) (declare (type (integer 77651198 86069496) e)) (declare (type (integer -4616 3453771) f)) (declare (type (integer -14889981824 53610580608) g)) (declare (type (integer -1049733788 46605484288) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 2) (space 1) (safety 3) (debug 2) (compilation-speed 2))) (conjugate (progn (tagbody (flet ((%f3 nil 0)) (unwind-protect (flet ((%f10 (f10-1) (let ((*s6* (%f3))) (go 6)))) (funcall #'%f10 f)))) 6 (let ((*s1* (restart-bind () (labels ((%f1 (f1-1) 3136)) (let () (progv '(*s5* *s1*) (list (labels ((%f2 nil (catch 'ct8 -11))) -70941710) (if nil (%f1 -1) 87)) (progn (tagbody (%f1 *s1*) 3 (block b2 (progn a)) tag3) h))))))) 0)) 0)))) 1555 -22062210 85224215 -161218251003 78463284 730073 33930166854 37839245921) 0) (deftest misc.300 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -29429 -3320) a)) (declare (type (integer -407874593 279639852) b)) (declare (type (integer -542849760256 3344389718016) c)) (declare (type (integer -2 12012755) d)) (declare (type (integer -248 -228) e)) (declare (type (integer 5 15636824592) f)) (declare (type (integer 21039 21595) g)) (declare (type (integer -1867743555584 -1621183025152) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 1) (space 3) (safety 1) (debug 2) (compilation-speed 3))) (labels ((%f12 (f12-1 f12-2 f12-3) 0)) (labels ((%f17 (f17-1) (progn (tagbody (max (apply (constantly 0) (list (%f12 (unwind-protect (go tag1)) 0 d) 0 f))) tag1 (dpb (realpart (expt (round (return-from %f17 (restart-bind () (complex e 0))) (max 40 0)) 0)) (byte 0 0) 0)) 0))) (%f12 0 (%f17 0) 0))))) -6416 -274982013 2946309248013 1724720 -228 5782683458 21484 -1681168611256) 0) (deftest misc.301 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -1814 3348) a)) (declare (type (integer -32239015 12) b)) (declare (type (integer 128412 101411593) c)) (declare (type (integer -329076792320 -22) d)) (declare (type (integer 77651198 86069496) e)) (declare (type (integer -4616 3453771) f)) (declare (type (integer -14889981824 53610580608) g)) (declare (type (integer -1049733788 46605484288) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 2) (space 1) (safety 3) (debug 2) (compilation-speed 2))) (conjugate (progn (tagbody (flet ((%f3 nil 0)) (unwind-protect (flet ((%f10 (f10-1) (let ((*s6* (%f3))) (go 6)))) (funcall #'%f10 f)))) 6 (let ((*s1* (restart-bind () (labels ((%f1 (f1-1) 3136)) (let () (progv '(*s5* *s1*) (list (labels ((%f2 nil (catch 'ct8 -11))) -70941710) (if nil (%f1 -1) 87)) (progn (tagbody (%f1 *s1*) 3 (block b2 (progn a)) tag3) h))))))) 0)) 0)))) 1555 -22062210 85224215 -161218251003 78463284 730073 33930166854 37839245921) 0) (deftest misc.302 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -206837809920 -126404559104) a)) (declare (type (integer -277874608640 -63724432) b)) (declare (type (integer -2 0) c)) (declare (type (integer -5992710 9946878) d)) (declare (type (integer -4345390743552 -76504514048) e)) (declare (type (integer -330 3826137) f)) (declare (type (integer -517792898560 -1193868) g)) (declare (type (integer 2018 98092396) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 2) (space 2) (safety 2) (debug 1) (compilation-speed 1))) (flet ((%f12 (f12-1 f12-2 &optional (f12-3 0) (f12-4 (progn (tagbody (unwind-protect (go tag6)) tag6) (flet ((%f1 (f1-1 f1-2) 0)) (apply #'%f1 0 0 (list)))))) 0)) (%f12 0 e)))) -195379170409 -30212852077 -1 -2082141 -1686846623470 360505 -324299330279 37218064) 0) (deftest misc.303 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -55724018 0) a)) (declare (type (integer -4929718 2777256) b)) (declare (type (integer 18939493568 24064422528) c)) (declare (type (integer -13157393 112210531) d)) (declare (type (integer -75775 -4883) e)) (declare (type (integer 5071 1584913674240) f)) (declare (type (integer -1 -1) g)) (declare (type (integer -100 7017454141440) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 1) (space 3) (safety 3) (debug 1) (compilation-speed 1))) (labels ((%f7 (f7-1 &optional (f7-2 0) (f7-3 0) (f7-4 0)) 0)) (progn (denominator (progn (let ((*s6* (progn (tagbody (unwind-protect (%f7 0 0 (go tag6) d)) tag6 (restart-case 0)) 0))) 0) 0)) 0)))) -23410726 -4342503 20297113275 80145634 -17664 937086103773 -1 2923877584757) 0) (deftest misc.304 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -11679 1672) a)) (declare (type (integer -359757 -216048) b)) (declare (type (integer -46345706880 -1824) c)) (declare (type (integer -18 18) d)) (declare (type (integer -70852138 427028370944) e)) (declare (type (integer -428904547840 535369082368) f)) (declare (type (integer -4372225 83) g)) (declare (type (integer -2 0) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 2) (space 1) (safety 3) (debug 0) (compilation-speed 1))) (labels ((%f1 (f1-1 f1-2 f1-3) 0)) (rationalize (%f1 (progn (tagbody (let ((v3 (%f1 (unwind-protect (go tag2)) b 0))) 0) tag2) 0) h (cl::handler-case 0)))))) -7209 -223767 -42093806027 -9 132172281069 138363461574 -3751010 0) 0) (deftest misc.305 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -438 247) a)) (declare (type (integer -93662232 112841) b)) (declare (type (integer 8769 2766606) c)) (declare (type (integer -33007133760 32531429568) d)) (declare (type (integer 419 3712) e)) (declare (type (integer 1628 20513914304) f)) (declare (type (integer -1347290 47) g)) (declare (type (integer -12 3030073088) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 3) (space 3) (safety 0) (debug 3) (compilation-speed 0))) (flet ((%f5 (f5-1 f5-2 &optional (f5-3 0) (f5-4 0) (f5-5 0)) (progn (tagbody (unwind-protect (go tag1)) tag1) (coerce (let* ((*s4* (flet ((%f1 nil (let* ((v7 (dpb 0 (byte 0 0) c))) a))) (progv '(*s6* *s7*) (list (%f1) 0) g)))) c) 'integer)))) (if (%f5 d 0 e 0 0) h 0)))) -58 -22237190 2055343 -8144832891 1213 19038103159 -1009345 929619162) 929619162) (deftest misc.306 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer 261 234565) a)) (declare (type (integer -1454263719936 -3279802168) b)) (declare (type (integer -1251120498 -49518770) c)) (declare (type (integer 0 369) d)) (declare (type (integer -12465203856 -45) e)) (declare (type (integer -94321486 -91941853) f)) (declare (type (integer -16528338864 11322249648) g)) (declare (type (integer -1230549 -1143976) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 2) (space 1) (safety 0) (debug 0) (compilation-speed 0))) (denominator (progn (tagbody (unwind-protect (go tag7)) tag7) (logxor f (multiple-value-bind (*s4*) (logxor 0 (expt -2 1)) (truncate 0))))))) 130724 -736795298357 -1221747467 326 -9775240900 -94105708 -2273680158 -1156846) 1) (deftest misc.307 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -2903632 1282236) a)) (declare (type (integer 7 10741) b)) (declare (type (integer -249635 214804) c)) (declare (type (integer -50422 10469) d)) (declare (type (integer -52337314 10771161) e)) (declare (type (integer 0 5333060) f)) (declare (type (integer -1 0) g)) (declare (type (integer 1595835 4577573) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 1) (space 3) (safety 3) (debug 3) (compilation-speed 1))) (flet ((%f11 (f11-1 f11-2) 0)) (%f11 0 (unwind-protect e (progn (tagbody (let* ((v4 (progn (unwind-protect (go 0)) 0))) 0) 0) (logand (cl::handler-bind () (logand -15 -2 32578787 10349 e -24781944 -8))))))))) 60336 1625 124302 -33193 -8095855 4995857 0 4572381) 0) (deftest misc.308 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -2806612475904 8750665416704) a)) (declare (type (integer -3 10) b)) (declare (type (integer -94336824 116591592) c)) (declare (type (integer 456813135872 903636350976) d)) (declare (type (integer -2364199833600 -172353318912) e)) (declare (type (integer 717 1760915) f)) (declare (type (integer -21 105) g)) (declare (type (integer -3579048169472 -346272903168) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 2) (space 1) (safety 0) (debug 0) (compilation-speed 0))) (labels ((%f7 (f7-1) (multiple-value-prog1 0 0 (return-from %f7 (mask-field (byte 0 0) 0))))) (unwind-protect (%f7 0))))) 1951007924893 10 -49879990 614214833752 -1808568999586 1282634 99 -2783010573143) 0) (deftest misc.309 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -521338 12) a)) (declare (type (integer -1787856009216 1182078822400) b)) (declare (type (integer -3313 28535137344) c)) (declare (type (integer -38914612 -25121536) d)) (declare (type (integer 403073126400 2632230309888) e)) (declare (type (integer -39663606528 -1238304) f)) (declare (type (integer -103560 -70383) g)) (declare (type (integer -894 -227) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 3) (space 1) (safety 1) (debug 3) (compilation-speed 2))) (block b8 (multiple-value-prog1 (logand (logior 0 (if (logbitp 0 0) 0 (multiple-value-bind (v2) 0 0)))) (gcd (let* ((*s4* 0)) (logior 0 (return-from b8 (let ((*s8* 0)) (round 0)))))) 0 0)))) -275760 -565946697213 9650536069 -37585973 1536165173011 -12895970021 -102192 -534) 0 0) (deftest misc.310 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -2016726144 234357120) a)) (declare (type (integer -10569521299456 -1307998945280) b)) (declare (type (integer -45429002240 -17228484608) c)) (declare (type (integer 228451840 1454976512) d)) (declare (type (integer -4797 -2609) e)) (declare (type (integer -21 36300536) f)) (declare (type (integer -15983530 31646604) g)) (declare (type (integer -208720272 -357) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 1) (space 3) (safety 3) (debug 0) (compilation-speed 3))) (expt (labels ((%f14 (f14-1 f14-2) (progn (tagbody (+ (unwind-protect (labels ((%f1 (f1-1) (go tag1))) (let ((*s6* (%f1 d))) 0)))) tag1 (+ (cl::handler-bind () (if (<= -11215713 -819) (integer-length (floor (conjugate f14-1) (max 12 (ceiling (block b2 (catch 'ct2 (ignore-errors (flet ((%f13 (f13-1) (logior 87 f14-2))) f14-1)))))))) (progv '(*s8*) (list 472865632) *s8*))))) 0))) (%f14 0 0)) 0))) -28594854 -3859203606860 -40757449218 894599577 -4163 11621230 29558853 -92216802) 1) (deftest misc.311 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -1203392327680 -3017953) a)) (declare (type (integer -34222 -1) b)) (declare (type (integer -871294987 19) c)) (declare (type (integer 717979131904 3341735845888) d)) (declare (type (integer -7521858 3) e)) (declare (type (integer -52 49) f)) (declare (type (integer 18 43) g)) (declare (type (integer -503567246 -46) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 1) (space 3) (safety 1) (debug 2) (compilation-speed 2))) (labels ((%f2 (f2-1 f2-2 f2-3 &optional (f2-4 (let ((*s6* (progn (tagbody (flet ((%f17 (f17-1 f17-2 f17-3) (go 6))) (%f17 0 b 0)) 6) 0))) (complex (progn (tagbody (labels ((%f18 (f18-1 f18-2 &optional (f18-3 0) (f18-4 f)) 0)) (apply #'%f18 g 0 0 (list))) 0) 0) 0))) (f2-5 0) (f2-6 0)) 0)) (%f2 0 0 f)))) -738307241633 -25016 -846570136 2181696281793 -983259 24 36 -185316211) 0) (deftest misc.312 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -18334222 14354736) a)) (declare (type (integer 11163582 6421184978944) b)) (declare (type (integer -13690431913984 -64765792960) c)) (declare (type (integer -12750925 31112834) d)) (declare (type (integer -5188669232 2246825616) e)) (declare (type (integer -31235593088 -134) f)) (declare (type (integer -1 -1) g)) (declare (type (integer -647589424 12392126736) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 3) (space 2) (safety 1) (debug 1) (compilation-speed 1))) (let ((*s4* (if (progn (tagbody (unwind-protect (go 2)) 2) 0) (numerator (let* ((v1 (let ((*s6* 0)) (logand b (rationalize (coerce 0 'integer)))))) 0)) 0))) 0))) 7112398 3547401482305 -12827294644277 23312291 -444957551 -5443955020 -1 4998457143) 0) (deftest misc.313 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer 55474 401001) a)) (declare (type (integer -8359558987776 8684176949248) b)) (declare (type (integer -54332 116292) c)) (declare (type (integer 0 0) d)) (declare (type (integer -609311104000 959776553984) e)) (declare (type (integer -2031580 3834807) f)) (declare (type (integer -10955 2549) g)) (declare (type (integer -8362590032 -210369) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 1) (space 3) (safety 1) (debug 0) (compilation-speed 1))) (dotimes (iv1 3 0) (labels ((%f6 (f6-1 f6-2 f6-3 &optional (f6-4 (flet ((%f3 (f3-1 f3-2 f3-3 &optional (f3-4 0)) (flet ((%f11 nil 0)) (ash (progn (tagbody (labels ((%f3 (f3-1 &optional (f3-2 (go tag4))) 0)) (%f3 0)) tag4) 0) (min 42 (conjugate (coerce (conjugate (let ((v9 (%f11))) f3-1)) 'integer))))))) (%f3 c 0 a))) (f6-5 0)) 0)) (apply #'%f6 0 0 h nil))))) 93287 3146418586486 -51786 0 -63479145888 1935918 -10058 -2033798238) 0) (deftest misc.314 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -176150296 698) a)) (declare (type (integer -62799871488 -56234210816) b)) (declare (type (integer -1 1) c)) (declare (type (integer 31 215808) d)) (declare (type (integer -3 -1) e)) (declare (type (integer -3 3387651) f)) (declare (type (integer -14370846720 -56648624) g)) (declare (type (integer -8316238784 -6221617344) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 1) (space 1) (safety 1) (debug 2) (compilation-speed 2))) (progn (tagbody (unwind-protect (let ((v10 (let* ((v7 (if (go tag6) 0 0))) 0))) 0)) tag6 (let ((v7 (flet ((%f11 nil 0)) (flet ((%f13 (f13-1 f13-2 f13-3) f13-2)) (funcall #'%f13 0 a (%f11)))))) 0)) 0))) -90583503 -61289371485 -1 175888 -3 3257970 -3264725617 -6816839328) 0) ;;; (misc.315 deleted) ;;; ACL 6.2 interpreter bugs ;;; Error: `NIL' is not of the expected type `NUMBER' ;;; (in COMP::IA-RESOLVE-REFS) (deftest misc.316 (funcall (compile nil '(lambda (a c) (declare (optimize (speed 2) (space 3) (safety 2) (debug 2) (compilation-speed 0))) (unwind-protect 0 (progn (tagbody (bit #*000000111 (min 8 (max 0 a))) tag5 (flet ((%f17 (f17-1 f17-2 f17-3) (complex (numerator (go tag4)) 0))) c) tag4) c)))) 1 2) 0) ;;; ecl failures (12 April 2004) ;;; wrong value returned (deftest misc.317 (funcall (compile nil '(lambda () (declare (optimize (speed 1) (space 1) (safety 3) (debug 0) (compilation-speed 3))) (catch 'ct4 (elt '(40760) (min 0 (max 0 (let* ((v3 (* (throw 'ct4 0) 0))) 0)))))))) 0) ;;; seg fault (deftest misc.318 (funcall (compile nil '(lambda (a b c) (declare (type (integer -2050548150 4917) a)) (declare (type (integer -4 1) b)) (declare (type (integer 99335934976 442465125376) c)) (declare (ignorable a b c)) (declare (optimize (speed 1) (space 1) (safety 1) (debug 0) (compilation-speed 0))) (if (rationalize (labels ((%f12 (f12-1) (if c 0 (bit #*101010011000011 (min 14 (max 0 0)))))) (if (> 0 c) 0 (%f12 0)))) (progn (expt (flet ((%f18 (f18-1 f18-2 &optional (f18-3 0) (f18-4 c) (f18-5 b)) 0)) (apply #'%f18 b b 0 0 nil)) 0) a) 0))) 10 1 99335934976) 10) ;;; seg fault (deftest misc.319 (funcall (compile nil '(lambda (a b c) (declare (type (integer -626615938 3649977016320) a)) (declare (type (integer -3615553 6013683) b)) (declare (type (integer -746719 1431737508) c)) (declare (ignorable a b c)) (declare (optimize (speed 3) (space 1) (safety 2) (debug 3) (compilation-speed 3))) (if (logbitp 0 (flet ((%f10 (f10-1 f10-2 f10-3) b)) (flet ((%f4 (f4-1 f4-2) (apply #'%f10 (%f10 0 a 0) 0 c nil))) (complex (%f4 0 0) 0)))) 0 0))) 2378435476701 1646880 246794654) 0) ;;; sbcl 0.8.9.35 ;;; failed AVER: "(EQL (LAMBDA-COMPONENT FUNCTIONAL) *CURRENT-COMPONENT*)" (deftest misc.320 (funcall (compile nil '(lambda () (declare (optimize (speed 3) (space 0) (safety 2) (debug 2) (compilation-speed 0))) (catch 'ct2 (elt '(102) (flet ((%f12 () (rem 0 -43))) (multiple-value-call #'%f12 (values)))))))) 102) (deftest misc.320a (funcall (compile nil '(lambda (b) (declare (optimize (speed 3) (space 0) (safety 2) (debug 2) (compilation-speed 0))) (reduce '* (list (elt '(10 20 30 40 50) b) (expt (reduce #'(lambda (lmv1 lmv3) (mod lmv3 15)) (vector 0 0)) 0) (rem 0 -71)) ))) 2) 0) (deftest misc.320b (funcall (compile nil '(lambda (a b c) (declare (type (integer -690191 -454473) a)) (declare (type (integer -459197 -62) b)) (declare (type (integer 445621505781 8489194559765) c)) (declare (ignorable a b c)) (declare (optimize (speed 1) (space 0) (safety 2) (debug 3) (compilation-speed 3))) (elt '(3327764 3386241) (min 1 (max 0 (reduce #'(lambda (lmv6 lmv5) (mod 0 (min -86 0))) (list 0 0))))))) -512398 -156405 1140919327630) 3327764) ;;; ecl ;;; Wrong value (deftest misc.321 (funcall (compile nil '(lambda (p) (declare (optimize (speed 1) (space 3) (safety 2) (debug 1) (compilation-speed 3))) (catch 'ct2 (let* ((v3 (- (if p (throw 'ct2 :good) 0)))) :bad)))) t) :good) ;;; segfault (deftest misc.322 (funcall (compile nil '(lambda (a) (declare (optimize (speed 2) (space 2) (safety 0) (debug 3) (compilation-speed 2))) (logorc2 (labels ((%f14 (f14-1) a)) (%f14 0)) (reduce #'(lambda (lmv1 lmv2) a) (list 0 0))))) 3151096069) -1) ;; #1# is undefined (deftest misc.323 (let* ((tail '(:from-end t)) (form `(lambda () (declare (optimize (speed 3) (space 1) (safety 2) (debug 2) (compilation-speed 2))) (eval '(reduce #'logior (vector (reduce #'logand (vector 0 0) . ,tail) 0) . ,tail))))) (funcall (compile nil form))) 0) ;;; Bad value (deftest misc.324 (funcall (compile nil '(lambda (a) (declare (optimize (speed 2) (space 2) (safety 3) (debug 2) (compilation-speed 3))) (labels ((%f6 (f6-1) (multiple-value-setq (a) 0))) (reduce #'(lambda (lmv4 lmv3) a) (list (%f6 0) 2))))) 1) 0) ;;; "A bug was found in the compiler. Contact worm@arrakis.es." ;;; Broken at C::C2MULTIPLE-VALUE-SETQ. (deftest misc.325 (funcall (compile nil '(lambda (a b) (declare (type (integer -1659358 3099614928896) a)) (declare (type (integer -492625 197903) b)) (declare (ignorable a b)) (declare (optimize (speed 3) (space 1) (safety 3) (debug 0) (compilation-speed 1))) (reduce #'(lambda (lmv5 lmv6) (multiple-value-setq (a) 2443855591508)) (vector b a 0 0) :from-end t))) 1 2) 2443855591508) ;;; wrong value (deftest misc.326 (funcall (compile nil '(lambda (b) (declare (type (integer 155 7955) b)) (declare (optimize (speed 3) (space 3) (safety 3) (debug 1) (compilation-speed 0))) (flet ((%f13 (f13-1) (shiftf b 3019))) (+ b (%f13 0))))) 200) 400) ;;; acl 6.2 (x86 linux trial edition, patched, 4/15/04) ;;; Error: `NIL' is not of the expected type `REAL' (deftest misc.327 (funcall (compile nil '(lambda (a b) (declare (type (integer -67668056 -55) a)) (declare (type (integer -586950907 -10945000) b)) (declare (ignorable a b)) (declare (optimize (speed 2) (space 0) (safety 2) (debug 2) (compilation-speed 1))) (labels ((%f15 (f15-1) (elt #(1073730663 1073689230 596123606 1073713997 311527378 186184643 1073713230 1316881) (min 7 (max 0 (catch 'ct7 (reduce #'min (list 0 b (catch 'ct7 (throw 'ct7 f15-1)) 0) :start 1 :from-end t))))))) (%f15 0)))) -38276611 -11001852) 1073730663) ;;; wrong return value: T (deftest misc.327a (funcall (compile nil '(lambda (a b c d e) (declare (notinline max vector reduce)) (declare (optimize (speed 1) (space 2) (safety 1) (debug 1) (compilation-speed 2))) (reduce #'(lambda (lmv6 lmv3) lmv3) (vector 0 (max 0) 0 0 (catch 'ct2 (catch 'ct2 (throw 'ct2 0))) 0 e 0) :end 2 :from-end t))) 68664683637 328245 881497115 -303855 311427) 0) ;;; Bugs from abcl ;;; Debugger invoked on condition of type TYPE-ERROR: ;;; The value org.armedbear.lisp.Symbol@54 is not of type integer. (deftest misc.328 (funcall (compile nil '(lambda (a b) (declare (type (integer -11368047588 14412128900) a)) (declare (type (integer -10 0) b)) (declare (ignorable a b)) (declare (optimize (speed 3) (space 1) (safety 3) (debug 0) (compilation-speed 0))) (if (logbitp 0 (if (or t nil) (setf a -2616861879) 0)) 0 0))) -4836700955 -1) 0) ;;; Incorrect value (deftest misc.329 (funcall (compile nil '(lambda (a b) (declare (type (integer -725661427 405092) a)) (declare (type (integer 84176291516 98216856233) b)) (declare (ignorable a b)) (declare (optimize (speed 3) (space 3) (safety 0) (debug 0) (compilation-speed 0))) (let ((*s2* (case b ((53651 62711 29537 25305 62250) 0) (t 0)))) (declare (special *s2*)) (setq a -688292831)))) -406606203 84436335326) -688292831) (deftest misc.330 (funcall (compile nil '(lambda (a b) (declare (type (integer -12816761394938 -8706928710678) a)) (declare (type (integer -3683497948554 427) b)) (declare (ignorable a b)) (declare (optimize (speed 3) (space 0) (safety 0) (debug 3) (compilation-speed 2))) (lcm (block b8 (signum (return-from b8 a)))))) -12715609319989 -582329850697) 12715609319989) (deftest misc.331 (funcall (compile nil '(lambda (a b) (declare (type (integer -777352478 239900) a)) (declare (type (integer -63500163479 -8671) b)) (declare (ignorable a b)) (declare (optimize (speed 3) (space 0) (safety 0) (debug 2) (compilation-speed 3))) (if (if (>= 0) t t) (setq b -25319949896) b))) 0 -10000) -25319949896) ;;; Debugger invoked on condition of type TYPE-ERROR: ;;; The value 0 is not of type org.armedbear.lisp.Symbol@80f563d8. (deftest misc.332 (funcall (compile nil '(lambda (a b) (declare (notinline max logorc1 numerator rem)) (declare (optimize (speed 3) (space 1) (safety 1) (debug 1) (compilation-speed 2))) (rem (progn (tagbody (numerator (logorc1 0 (go tag5))) tag5) 0) (max 93 0)))) -801 17641908) 0) ;;; Debugger invoked on condition of type TYPE-ERROR: ;;; The value # is not of type org.armedbear.lisp.Symbol@80f563d8. (deftest misc.333 (funcall (compile nil '(lambda () (declare (notinline logxor)) (declare (optimize (speed 3) (space 0) (safety 0) (debug 3) (compilation-speed 3))) (logxor (progn (tagbody (let* ((*s4* (progn (go 1) 0))) 0) 1) 0))))) 0) ;;; Debugger invoked on condition of type PROGRAM-ERROR: ;;; Wrong number of arguments for EXPT. (deftest misc.334 (funcall (compile nil '(lambda (a b c) (declare (type (integer 1892675246514 8763564964618) a)) (declare (type (integer -1353 -456) b)) (declare (type (integer 2010840649 2119165101) c)) (declare (ignorable a b c)) (declare (optimize (speed 3) (space 2) (safety 0) (debug 2) (compilation-speed 1))) (+ (block b6 (expt (return-from b6 b) 0))))) 3966745735633 -1123 2030094113) -1123) ;;; The value NIL is not of type number. (deftest misc.335 (let ((c 10)) (denominator (progn (tagbody (realpart (loop for lv4 below 2 sum (go 0))) 0) c))) 1) (deftest misc.336 (prog2 (progn (tagbody (- (common-lisp:handler-case (go tag2))) tag2) 0) 0) 0) ;;; Incorrect return value (deftest misc.337 (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 2) (safety 2) (debug 0) (compilation-speed 0))) (imagpart (block b8 (logior (block b7 (return-from b8 225480400)))))))) 0) ;;; Inconsistent stack height 1 != 2 (deftest misc.338 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (c) (conjugate (block b8 (max (if c (return-from b8 0) 0)))))) 10)) 0) ;;; Inconsistent stack height 4 != 0 (deftest misc.339 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda () (declare (optimize (speed 1) (space 3) (safety 3) (debug 0) (compilation-speed 0))) (block b1 (reduce #'min (list (return-from b1 0)) :end 1 :start 0 :from-end t )))))) 0) ;;; The value INTEGER is not of type sequence. (deftest misc.340 (funcall (compile nil '(lambda (a b c) (declare (type (integer -4379340 -1962) a)) (declare (type (integer 1304043 3225940) b)) (declare (type (integer -3229571579853 -180689150012) c)) (declare (ignorable a b c)) (declare (optimize (speed 3) (space 1) (safety 0) (debug 2) (compilation-speed 2))) (coerce (rationalize (progn (tagbody (reduce #'logand (list b 0 (go tag3)) :from-end t) tag3) 0)) 'integer))) -1625211 3052955 -2091182035681) 0) ;;; Inconsistent stack height 1 != 2 (deftest misc.341 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (c) (declare (optimize (speed 2) (space 1) (safety 1) (debug 2) (compilation-speed 3))) (logeqv (block b6 (logeqv (case 0 ((45293 29462 60403) (return-from b6 0)) (t c))))))) 10)) 10) ;;; Inconsistent stack height 0 != 1 (deftest misc.342 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (optimize (speed 1) (space 0) (safety 2) (debug 1) (compilation-speed 2))) (progn (tagbody (imagpart (dotimes (iv3 0 a) (go 4))) 4) 0))) 1)) 0) ;;; Expecting to find object/array on stack (deftest misc.343 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 3) (safety 2) (debug 3) (compilation-speed 2))) (mask-field (byte 0 0) (block b8 (reduce 'logior (list (return-from b8 0) 0 0) :end 3 :start 0 :from-end t))))))) 0) ;;; Wrong value (deftest misc.344 (funcall (compile nil '(lambda (a) (declare (type (integer -3464434 12316202) a)) (declare (optimize (speed 1) (space 0) (safety 0) (debug 0) (compilation-speed 2))) (progn (tagbody (gcd (expt (setf a -2612809) 0) (go 5)) 5) a))) 1891348) -2612809) ;;; Stack size too large (deftest misc.345 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a b c) (declare (type (integer -1968 -1759) a)) (declare (type (integer 91 2293818743282) b)) (declare (type (integer -843793650839 -2) c)) (declare (ignorable a b c)) (declare (optimize (speed 3) (space 2) (safety 3) (debug 0) (compilation-speed 3))) (max (block b1 (conjugate (dotimes (iv3 0 (bit #*010 (min 2 (max 0 (return-from b1 0))))) (progn 0)))) (sbit #*0001011010010 (min 12 (max 0 0)))))) -1957 523078358699 -634832888815)) 0) (deftest misc.345a (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (c) (declare (type (integer -3011346550 1630587670) c)) (declare (optimize (speed 1) (space 1) (safety 0) (debug 3) (compilation-speed 1))) (progn (tagbody (dotimes (iv2 0 (- 0 (go 7))) (progn 0)) 7 (progn (mask-field (byte 0 0) 0) c)) 0))) 1)) 0) ;;; wrong return value (deftest misc.346 (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 2) (safety 2) (debug 2) (compilation-speed 2))) (bit #*011100 (min 5 (max 0 (block b8 (aref #(122010971004 126555236004) (min 1 (max 0 (progn (return-from b8 191438621) 0))))))))))) 0) ;;; The value 8 is not of type FUNCTION. (deftest misc.347 (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 2) (safety 3) (debug 2) (compilation-speed 1))) (complex (* (block b2 (boole boole-xor (logxor (return-from b2 0)) 0))) 0)))) 0) ;;; Wrong result (deftest misc.348 (funcall (compile nil '(lambda (a c) (declare (optimize (speed 1) (space 0) (safety 2) (debug 3) (compilation-speed 1))) (max (conjugate (setq a -4178265097)) (if (> c 0) 0 a)))) -2408319173 -4307532101272) -4178265097) (deftest misc.349 (funcall (compile nil '(lambda () (declare (optimize (speed 3) (space 1) (safety 1) (debug 1) (compilation-speed 2))) (mod (let ((*s7* (block b7 (logandc2 (+ (return-from b7 0)) 0)))) -10) (max 26 0))))) 16) ;;; Inconsistent stack height 0 != 1 (deftest misc.350 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 3) (safety 1) (debug 2) (compilation-speed 3))) (progn (tagbody (complex (- 0 (if (and t) 0 (go tag1))) 0) tag1) 0))))) 0) (deftest misc.351 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (c) (declare (type (integer -598962457711 -2902) c)) (declare (optimize (speed 1) (space 0) (safety 1) (debug 0) (compilation-speed 3))) (lognor c (block b1 (loop for lv3 below 1 sum (if (/= 0) (return-from b1 0) c)))))) -392248104420)) 392248104419) (deftest misc.352 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda () (declare (optimize (speed 1) (space 3) (safety 3) (debug 3) (compilation-speed 1))) (progn (tagbody (+ 0 (if (< 0) (go 5) 0)) 5) 0))))) 0) (deftest misc.353 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a b) (declare (type (integer -8 -2) a)) (declare (type (integer -67321 14697029362) b)) (declare (optimize (speed 3) (space 1) (safety 3) (debug 1) (compilation-speed 2))) (expt (block b2 (loop for lv1 below 3 sum (prog2 b 0 (expt (case 0 ((-13960 -57685 -37843 -34222 -14273 -40931 -2688) (return-from b2 0)) (t a)) 0)))) 0))) -7 772373806)) 1) ;;; Incorrect return value (deftest misc.354 (funcall (compile nil '(lambda (a b c) (declare (type (integer -1309 67082465417) a)) (declare (type (integer -7824641338734 -832606641) b)) (declare (type (integer 7473698771 3542216118742) c)) (declare (ignorable a b c)) (declare (optimize (speed 3) (space 2) (safety 1) (debug 3) (compilation-speed 2))) (+ 0 (progn (tagbody (if (if (>= b (go 3)) nil t) a c) 3) 0)))) 29329060987 -4964942044116 512158612507) 0) (deftest misc.355 (funcall (compile nil '(lambda (c) (declare (type (integer -1390043946499 -115168466439) c)) (declare (optimize (speed 2) (space 0) (safety 0) (debug 1) (compilation-speed 2))) (+ 0 (coerce (progn (tagbody (if (<= -1 (go tag1)) 0 c) tag1) 0) 'integer)))) -115168466439) 0) (deftest misc.356 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 2) (safety 1) (debug 0) (compilation-speed 3))) (let ((*s7* 0)) (dotimes (iv2 0 0) (block b3 (block b3 (block b3 (setq *s7* (return-from b3 0))))))))))) 0) (deftest misc.357 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (b) (declare (type (integer -1750881587721 -327383867) b)) (declare (optimize (speed 1) (space 0) (safety 2) (debug 3) (compilation-speed 3))) (denominator (block b2 (let* ((*s8* 0)) (setq *s8* (case 0 ((-26733 -244 -26253 -50028) 0) (t (return-from b2 b))))))))) -1153135130306)) 1) (deftest misc.358 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 0) (safety 0) (debug 3) (compilation-speed 1))) (rationalize (let* ((*s1* 0)) (block b3 (conjugate (let* ((v10 (if (ldb-test (byte 0 0) 0) (return-from b3 *s1*) 0))) (setq *s1* (return-from b3 0))))))))))) 0) (deftest misc.359 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a b) (declare (type (integer -477801566869 432060432661) a)) (declare (type (integer 366578392 525704751) b)) (declare (optimize (speed 3) (space 3) (safety 1) (debug 1) (compilation-speed 1))) (max (case b ((0 -3 -2 -2 -3) (progn (tagbody (loop for lv1 below 2 count (let* ((*s1* a)) (setq *s1* (go 4)))) 4) 0)) (t 0))))) 287358622300 400248608)) 0) ;;; Wrong return value (deftest misc.360 (let ((c :good)) (tagbody (dotimes (j 1 (setf c :bad)) (go done)) done) c) :good) ;;; sbcl bugs (0.8.10.4) ;;; failed AVER: "(SUBSETP END END-STACK)" (deftest misc.361 (funcall (compile nil '(lambda (a b c) (declare (notinline boole values denominator list)) (declare (optimize (speed 2) (space 0) (safety 1) (debug 0) (compilation-speed 2))) (catch 'ct6 (progv '(*s8*) (list 0) (let ((v9 (ignore-errors (throw 'ct6 0)))) (denominator (progv nil nil (values (boole boole-and 0 v9))))))))) 1 2 3) 0) ;;; sbcl (0.8.10.15) ;;; Wrong return value: SB-KERNEL:*HANDLER-CLUSTERS* (deftest misc.362 (funcall (compile nil '(lambda (b g h) (declare (optimize (speed 3) (space 3) (safety 2) (debug 2) (compilation-speed 3))) (catch 'ct5 (unwind-protect (labels ((%f15 (f15-1 f15-2 f15-3) (rational (throw 'ct5 0)))) (%f15 0 (apply #'%f15 0 h (progn (progv '(*s2* *s5*) (list 0 (%f15 0 g 0)) b) 0) nil) 0)) (common-lisp:handler-case 0))))) 1 2 3) 0) ;;; Wrong value: NIL (deftest misc.363 (funcall (compile nil '(lambda (a) (declare (type (integer -17286401550789 15753784105886) a)) (declare (optimize (speed 2) (space 2) (safety 2) (debug 0) (compilation-speed 3))) (if (not (>= 0 (shiftf a 110236462073))) 0 (elt '(30 101 13 2 10 52 89 57) (min 7 (max 0 a)))))) -3647332298473) 57) ;;; "full call to SB-KERNEL:DATA-VECTOR-REF" (deftest misc.364 (dotimes (iv1 2 0) (if (> iv1 iv1) (svref #(2002 3778 1998 3466 530 3279 2033 521 4085) (min 8 (max 0 iv1))) 0)) 0) ;;; OpenMCL/darwin bug (12 May 2004) (deftest misc.365 (let* ((fn1 '(lambda (a b c) (declare (type (integer -2 21) a)) (declare (type (integer -5651364356 4324101092) b)) (declare (type (integer -30766087 28182568) c)) (declare (ignorable a b c)) (declare (optimize (speed 3) (space 1) (safety 3) (debug 0) (compilation-speed 1))) (coerce (logxor b -1) 'integer))) (fn2 '(lambda (a b c) (declare (notinline logxor coerce)) (declare (optimize (speed 3) (space 0) (safety 3) (debug 2) (compilation-speed 2))) (coerce (logxor b -1) 'integer))) (vals '(9 -328421075 -6406890)) (v1 (apply (compile nil fn1) vals)) (v2 (apply (compile nil fn2) vals))) (if (eql v1 v2) :good (list v1 v2))) :good) ;;; sbcl 0.8.10.24 ;;; Argument X is not a REAL: # (deftest misc.366 (funcall (compile nil '(lambda (a b c d e f g h i) (declare (type (integer 10 65866342) a)) (declare (type (integer 151 702748905609) b)) (declare (type (integer -60442925 167939283) c)) (declare (type (integer 7706 10562) d)) (declare (type (integer -97180326158 17496) e)) (declare (type (integer -73249 -51989) f)) (declare (type (integer -12 2718) g)) (declare (type (integer -37832 591244) h)) (declare (type (integer -2579781276 2108461452) i)) (declare (ignorable a b c d e f g h i)) (declare (optimize (speed 3) (space 0) (safety 0) (debug 2) (compilation-speed 2))) (elt '(11751 8554 7393 1924 3418) (min 4 (max 0 (block b4 (numerator (flet ((%f5 (f5-1 f5-2 f5-3 &optional (f5-4 (prog1 0 (return-from b4 0) 0)) (f5-5 d) (f5-6 0)) 0)) (numerator (apply (constantly 0) 0 0 (rationalize (unwind-protect (%f5 0 c (%f5 0 c (%f5 0 0 0 h (%f5 0 0 0) i) a)) (ignore-errors 0))) 0 nil)))))))))) 21956127 524275646496 101890987 8762 -88607922426 -55959 2177 147174 38469170) 11751) ;;; The value # ;;; is not of type RATIONAL. (deftest misc.367 (funcall (compile nil '(lambda (a b) (declare (type (integer 11557968 115977463) a)) (declare (type (integer -89510 -20616) b)) (declare (optimize (speed 2) (space 3) (safety 1) (debug 0) (compilation-speed 1))) (rational (flet ((%f17 (f17-1 f17-2) 0)) (%f17 (numerator (%f17 (denominator (catch 'ct5 (apply (constantly 0) 0 (unwind-protect (catch 'ct2 (throw 'ct5 (progn (%f17 a b) a)))) nil))) 0)) (%f17 0 a)))))) 112475717 -25829) 0) ;;; sbcl 0.8.10.25 ;;; "The value -3 is not of type (INTEGER -5 -2)." (deftest misc.368 (funcall (compile nil '(lambda (a) (declare (type (integer -5 -2) a)) (declare (ignorable a)) (declare (optimize (speed 2) (space 3) (safety 1) (debug 1) (compilation-speed 1))) (if (and (not (not (> a (numerator (setf a -4))))) (logbitp 0 (conjugate a))) 0 0))) -3) 0) ;;; acl 6.2 (x86 linux trial edition, patched, 4/15/04) ;;; Error: `T' is not of the expected type `NUMBER' (deftest misc.369 (funcall (compile nil '(lambda (a b c d e) (declare (type (integer -15256078323 33828721319) a)) (declare (type (integer -44368 22872) b)) (declare (type (integer -7623 -7522) c)) (declare (type (integer -53 289) d)) (declare (type (integer -1853649832248 2196352552304) e)) (declare (ignorable a b c d e)) (declare (optimize (speed 1) (space 2) (safety 0) (debug 0) (compilation-speed 3))) (flet ((%f2 (f2-1 &optional &key (key1 0) (key2 e)) (labels ((%f5 (f5-1 f5-2 f5-3 &optional &key (key1 (aref #(397) (min 0 (max 0 (let ((v7 (make-array nil :initial-element d))) (reduce #'(lambda (lmv5 lmv6) key1) (vector f2-1 0) :start 0)))))) &allow-other-keys) 0)) 0))) b))) -2821485338 -35420 -7622 135 9592294022) -35420) ;;; Lispworks personal edition 4.3 (x86 linux) ;;; Inconsistent return value (deftest misc.370 (funcall (compile nil '(lambda (a b c) (declare (type (integer -3070433 6) a)) (declare (type (integer -5 -3) b)) (declare (type (integer -4433759745778 -1) c)) (declare (ignorable a b c)) (declare (optimize (speed 3) (space 1) (safety 0) (debug 2) (compilation-speed 3))) (flet ((%f15 (f15-1 f15-2 &optional (f15-3 0) (f15-4 (denominator (setq c -4214677583716))) (f15-5 0) &key (key1 c) &allow-other-keys) (progv '(*s1* *s5* *s7*) (list f15-2 0 f15-1) key1))) (%f15 0 (%f15 c 0) 0)))) -1233959 -4 -2643533316361) -4214677583716) ;;; Armed Bear CL ;;; inconsistent stack height (deftest misc.371 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a b c) (declare (type (integer -7288 10764) a)) (declare (type (integer -7 24) b)) (declare (type (integer 7951930344 11209871544) c)) (declare (ignorable a b c)) (declare (optimize (speed 2) (space 2) (safety 0) (debug 0) (compilation-speed 0))) (rationalize (block b1 (if b (return-from b1 (progn (tagbody (return-from b1 (let* ((*s1* (cons (go tag3) 0))) (declare (dynamic-extent *s1*)) 0)) tag3) 0)) 0))))) -5566 9 10557204445)) 0) ;;; 0 is not of type LIST (deftest misc.372 (funcall (compile nil '(lambda (a b c) (declare (type (integer -738508 627) a)) (declare (type (integer -100241328874 104421) b)) (declare (type (integer -71651668566 4932238952300) c)) (declare (ignorable a b c)) (declare (optimize (speed 3) (space 2) (safety 1) (debug 3) (compilation-speed 2))) (sbit #*0 (min 0 (max 0 (multiple-value-bind (v1) (cons c (truncate 0 (min -42 0))) (cdr v1))))))) -657195 -10801112339 -4291316763) 0) ;;; inconsistent stack height (deftest misc.373 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a b c) (declare (type (integer 0 179061) a)) (declare (type (integer -15793 42532) b)) (declare (type (integer -2 0) c)) (declare (ignorable a b c)) (declare (optimize (speed 3) (space 0) (safety 2) (debug 1) (compilation-speed 0))) (reduce 'logxor (list 0 b 0 0 a 0 0 0 (block b6 (let* ((v6 (cons (if c (return-from b6 0) 0) b))) 0)) 0) :end 6 :from-end t))) 141814 1445 -2)) 142419) (deftest misc.374 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a b) (declare (type (integer -99 4) a)) (declare (type (integer 35621436 36172433) b)) (declare (ignorable a b)) (declare (optimize (speed 2) (space 1) (safety 3) (debug 1) (compilation-speed 0))) (lognand (let ((v6 0)) (declare (dynamic-extent v6)) v6) (block b6 (let* ((v10 (cons (expt (case 0 ((30207) (return-from b6 0)) (t b)) 0) 0))) (declare (dynamic-extent v10)) 0))))) -57 35725118)) -1) ;;; abcl (23 May 2004) ;;; 0 is not of type LIST (deftest misc.375 (funcall (compile nil '(lambda (a b c d e f) (declare (type (integer -3172868 25583841) a)) (declare (type (integer -8176159 1565888775976) b)) (declare (type (integer -2601325109 147819602) c)) (declare (type (integer -502316251909 515874281072) d)) (declare (type (integer 174 2604648) e)) (declare (type (integer 1627646459 3124243119) f)) (declare (ignorable a b c d e f)) (declare (optimize (speed 3) (space 0) (safety 3) (debug 2) (compilation-speed 2))) (let* ((*s6* (make-array nil :initial-element 0 :adjustable t))) (if (logbitp 0 (denominator (prog2 (truncate (dotimes (iv3 0 0) (progn 0))) (multiple-value-bind (*s7*) (cons d 0) (cdr *s7*))))) 0 0)))) 12851164 182468232812 -2243976802 309299185674 2538150 1855615980) 0) ;;; abcl (25 May 2004) ;;; 0 is not of type LIST (deftest misc.376 (funcall (compile nil '(lambda () (declare (optimize (speed 1) (space 1) (safety 2) (debug 1) (compilation-speed 0))) (dotimes (iv4 3 (multiple-value-bind (*s6*) (cons 0 0) (progn (cdr *s6*) 0))) (floor (rational (let ((*s2* (rational (common-lisp:handler-case 0)))) 0))))))) 0) (deftest misc.377 (funcall (compile nil '(lambda (e) ; (a b c d e) (declare (type (integer -46778182694 512) e)) (declare (optimize (speed 3) (space 3) (safety 2) (debug 2) (compilation-speed 3))) (if (block b3 (numerator (progn (tagbody (truncate (dotimes (iv3 0 0) (block b3 0))) (multiple-value-bind (*s5*) (cons 0 e) (rationalize (cdr *s5*)))) 0))) 0 0))) 10) 0) (deftest misc.378 (funcall (compile nil '(lambda (c) (declare (optimize (speed 1) (space 0) (safety 1) (debug 3) (compilation-speed 2))) (dotimes (iv4 3 0) (restart-case (round (multiple-value-bind (*s6*) (cons c 0) (car *s6*))))))) 1) 0) (deftest misc.379 (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 0) (safety 2) (debug 2) (compilation-speed 1))) (values (floor 0) (multiple-value-bind (v3) (cons 0 0) (car v3)))))) 0 0) ;;; gcl (31 May 2004, cvs head) ;;; Error in APPLY [or a callee]: Expected a FIXNUM ;;; Also fails in cmucl 1/2003 (deftest misc.380 (funcall (compile nil '(lambda (a) (declare (type (integer -1397457 1846252) a)) (declare (optimize (speed 2) (space 2) (safety 1) (debug 3) (compilation-speed 3))) (let ((v9 (make-array nil :initial-element 0))) (declare (dynamic-extent v9)) (block b8 (let ((*s1* 0)) (let ((*s4* (let ((*s1* (return-from b8 (rational (setf (aref v9) (deposit-field -5 (byte 20 30) a)))))) 0))) (let ((*s8* (cons 0 0))) 0))))))) 399997) 1125898833500797) ;; This also fails in cmucl (11/2003 image). This case has not been fully ;; pruned for cmucl. ;; ;; Error in function LISP::ASSERT-ERROR: The assertion (NOT C::WIN) failed. (deftest misc.381 (funcall (compile nil '(lambda (a) (declare (type (integer -1397457 1846252) a)) (declare (optimize (speed 2) (space 2) (safety 1) (debug 3) (compilation-speed 3))) (let ((v9 (make-array nil :initial-element 0))) (declare (dynamic-extent v9)) (block b8 (let ((s1 0)) (let ((s4 (let ((s1 (return-from b8 (rational (setf (aref v9) (deposit-field -5 (byte 20 30) a)))))) 0))) (let ((s8 (cons 0 0))) 0))))))) 399997) 1125898833500797) ;;; gcl (31 May 2004, cvs head) ;;; Error in SYSTEM:ASET [or a callee]: Expected a FIXNUM (deftest misc.382 (funcall (compile nil '(lambda (b) (declare (type (integer -65822755520 31689335872) b)) (declare (optimize (speed 2) (space 2) (safety 3) (debug 0) (compilation-speed 1))) (let ((s8 (make-array nil :initial-element (catch 'ct4 (complex (dotimes (iv1 1 0) (rational (throw 'ct4 b))) 0))))) (elt '(13423701584) (min 0 (max 0 (rational (let ((s3 (make-array nil :initial-element 0))) (if (ldb-test (byte 0 0) (shiftf (aref s8) (aref s8))) 0 0))))))))) -38169486910) 13423701584) ;;; cmucl 11/2003 ;;; Wrong value (deftest misc.383 (funcall (compile nil '(lambda (a b c) (declare (type (integer -93650 118967004056) a)) (declare (type (integer -429173946 -3892) b)) (declare (type (integer -229669685 -50537386) c)) (declare (ignorable a b c)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (speed 3) (space 1) (safety 0) (debug 3) (compilation-speed 2))) (logorc2 (let* ((*s3* (cons 0 a))) (declare (dynamic-extent *s3*)) (shiftf c -124766263)) 411942919))) 79909316946 -347537841 -210771963) -142606339) ;;; abcl 7 Jun 2004 ;;; catch-throw now enabled in the abcl compiler ;;; Inconsistent stack height (deftest misc.384 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda () (catch 'ct8 (throw 'ct8 (catch 'ct7 0))))))) 0) (deftest misc.385 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda () (values 1 (catch 'ct2 2)))))) 1 2) (deftest misc.386 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda () (values (rationalize (catch 'ct1 1)) 2))))) 1 2) (deftest misc.387 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda () (block b1 (catch 'ct1 (throw 'ct1 (return-from b1 0)))))))) 0) ;;; ecl (cvs head, 13 June 2004) ;;; Problems with multiple-value-setq ; NIL cannot be coerced to a C int. (deftest misc.388 (funcall (compile nil '(lambda (a b c) (declare (type (integer 200077 60836768) a)) (declare (type (integer 339831915 371006999) b)) (declare (type (integer -13 5553) c)) (declare (ignorable a b c)) (declare (optimize (speed 2) (space 1) (safety 0) (debug 0) (compilation-speed 0))) (dotimes (iv4 2 0) (multiple-value-setq (c) 4212)))) 8959928 366395687 5048) 0) ;;; wrong return value (deftest misc.389 (funcall (compile nil '(lambda (a b c) (declare (type (integer -49972981888 -48068810368) a)) (declare (type (integer -452283089 -27620701) b)) (declare (type (integer -24815 15089) c)) (declare (ignorable a b c)) (declare (optimize (speed 2) (space 1) (safety 2) (debug 1) (compilation-speed 0))) (multiple-value-setq (c) 8015))) -49966124671 -68547159 12944) 8015) ;;; Evaluation order bug (deftest misc.390 (funcall (compile nil '(lambda (a b c) (declare (type (integer -257 -140) a)) (declare (type (integer -1 1069496658) b)) (declare (type (integer -4 2001960914944) c)) (declare (ignorable a b c)) (declare (optimize (speed 2) (space 0) (safety 1) (debug 0) (compilation-speed 1))) (labels ((%f12 (f12-1 &optional (f12-2 (setq b 63838027)) &key (key1 0) (key2 0)) b)) (boole boole-orc2 b (let ((*s3* (%f12 0))) -14))))) -173 1028908375 1289968133290) 1028908383) ;;; sbcl 0.8.14.14 ;;; "The value NIL is not of type SB-C::LVAR" (deftest misc.391 (funcall (compile nil '(lambda (a b) (declare (optimize (speed 2) (space 0) (safety 0) (debug 1) (compilation-speed 3))) (let* ((v5 (cons b b))) (declare (dynamic-extent v5)) a))) 'x 'y) x) ;;; sbcl 0.8.14.18 ;;; "The value # ;;; is not of type SB-C::REF." (deftest misc.392 (funcall (compile nil '(lambda (a b) (declare (notinline /=)) (declare (optimize (speed 1) (space 2) (safety 1) (debug 3) (compilation-speed 3))) (prog2 0 0 (loop for lv4 below 3 count (or b (/= b)))))) 1 2) 0) ;;; cmucl (2004-09 snapshot) ;;; "Error in function C::CORE-CALL-TOP-LEVEL-LAMBDA: ;;; Unresolved forward reference." ;;; (in C::CORE-CALL-TOP-LEVEL-LAMBDA) (deftest misc.393 (funcall (compile nil '(lambda (a b) (declare (type (integer -995205 1035654) a)) (declare (type (integer 473 114804994247) b)) (declare (ignorable a b)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (debug 3) (speed 2) (compilation-speed 0) (space 3) (safety 3))) (labels ((%f7 (f7-1 f7-2 f7-3 &optional (f7-4 (lcm (if (>= b a) 0 a))) (f7-5 0) &key) 0)) (progn (%f7 (%f7 b a a b) b 0) 0)))) 447930 66120263479) 0) (deftest misc.393a (funcall (compile nil '(lambda (a b) (declare (type (integer -76 86) a)) (declare (type (integer -13771285280 109) b)) (declare (ignorable a b)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (safety 3) (space 1) (debug 2) (compilation-speed 3) (speed 3))) (dotimes (iv1 2 0) (case (min -3693810 a iv1) ((26 -4) (ldb (byte 13 0) a)) (t b))))) 56 -1579426331) 0) ;;; cmucl (2004-09 snapshot) ;;; Wrong values (deftest misc.394 (funcall (compile nil '(lambda (a b) (declare (type (integer -76645001 98715919) a)) (declare (type (integer 0 856472753903) b)) (declare (ignorable a b)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (speed 2) (space 0) (debug 3) (compilation-speed 0) (safety 3))) (logeqv 0 b))) -34528661 843541658238) -843541658239) (deftest misc.395 (funcall (compile nil '(lambda (a b) (declare (type (integer 6429252570156 8761983588786) a)) (declare (type (integer -400378288 4971722) b)) (declare (ignorable a b)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (debug 3) (speed 3) (space 2) (safety 0) (compilation-speed 3))) (+ (shiftf a 8496033756259) (min 0 b)))) 8369430915156 -369704905) 8369061210251) ;;; "The assertion (EQ (CAR C::STACK) C::CONT) failed." (deftest misc.396 (funcall (compile nil '(lambda (a b) (declare (type (integer -1601 485) a)) (declare (type (integer -190428560464 -1444494) b)) (declare (ignorable a b)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (debug 0) (space 2) (speed 0) (safety 3) (compilation-speed 2))) (apply (constantly 0) 0 (list (signum b))))) -1365 -46960621335) 0) ;;; "The assertion (EQ (C::FUNCTIONAL-KIND (C::LAMBDA-HOME C::FUN)) ;;; :TOP-LEVEL) failed." (deftest misc.397 (funcall (compile nil '(lambda (a b) (declare (type (integer -168258525920 -2044) a)) (declare (type (integer -522 54) b)) (declare (ignorable a b)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (speed 0) (safety 3) (compilation-speed 1) (space 0) (debug 2))) (labels ((%f4 (f4-1 f4-2 &key) (flet ((%f7 (f7-1 f7-2 f7-3 &optional &key (key1 a)) (progv '(*s1* *s6* *s2*) (list a 0 key1) f4-1))) f4-2))) (apply #'%f4 (list a 0))))) -156882103995 -38) 0) ;;; "Error in function C::CLOSURE-POSITION: ;;; Can't find #>" (deftest misc.398 (funcall (compile nil '(lambda (a b) (declare (type (integer -319 7353) a)) (declare (type (integer 31751 4233916489) b)) (declare (ignorable a b)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (safety 3) (compilation-speed 1) (debug 1) (speed 0) (space 0))) (conjugate (if t (labels ((%f12 (f12-1 f12-2 f12-3) 0)) (%f12 0 b 0)) (dotimes (iv1 2 0) (catch 'ct2 a)))))) 4430 3476635674) 0) ;;; "NIL is not of type C::CONTINUATION" ;;; in C::FIND-PUSHED-CONTINUATIONS (deftest misc.399 (funcall (compile nil '(lambda (a) (declare (type (integer -3 1) a)) (declare (ignorable a)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (space 0) (debug 0) (speed 3) (compilation-speed 2) (safety 3))) (catch 'ct8 (logior a -457019 -1)))) 0) -1) ;;; Wrong value (deftest misc.400 (funcall (compile nil '(lambda (a) (declare (type (integer 3376 4762) a)) (declare (ignorable a)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (debug 0) (safety 0) (space 0) (compilation-speed 3) (speed 3))) (case (lognand 775 a) ((-7) 0) (t 4)))) 4182) 0) ;;; Invalid number of arguments: 1 (deftest misc.401 (funcall (compile nil '(lambda (a) (declare (type (integer 7299 257071514003) a)) (declare (ignorable a)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (compilation-speed 2) (space 1) (safety 2) (speed 1) (debug 2))) (logeqv (setq a 220250126156) 0))) 157474319912) -220250126157) ;;; "The assertion (EQ (CAR C::NEW-STACK) C::CONT) failed." (deftest misc.402 (funcall (compile nil '(lambda (a) (declare (type (integer -19116544 21344004) a)) (declare (ignorable a)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (space 1) (safety 3) (debug 1) (compilation-speed 0) (speed 0))) (dotimes (iv3 2 0) (progn (apply (constantly 0) (list (let* ((*s1* 0)) *s1*))) 0)))) 10) 0) ;;; "The assertion C::INDIRECT failed." (deftest misc.403 (funcall (compile nil '(lambda (a) (declare (type (integer -6456 -32) a)) (declare (ignorable a)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (space 3) (safety 1) (compilation-speed 1) (speed 0) (debug 0))) (dotimes (iv1 0 a) (loop for lv4 below 3 sum (catch 'ct8 0))))) -1648) -1648) ;;; From abcl (cvs, 15 Sept 2004) ;;; Inconsistent stack height (deftest misc.404 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a b) (declare (type (integer -77007578505 7500480849) a)) (declare (type (integer 211464 53140083) b)) (declare (ignorable a b)) (declare (optimize (compilation-speed 0) (speed 2) (debug 3) (safety 1) (space 3))) (progn (tagbody (let ((v3 (cons (case a ((13 5 -9 2 -13) (go tag8)) (t 0)) 0))) 0) tag8) a))) -1068524571 20786758)) -1068524571) (deftest misc.405 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a b) (declare (type (integer -82196 13938) a)) (declare (type (integer -44152792 -15846835) b)) (declare (ignorable a b)) (declare (optimize (compilation-speed 3) (safety 2) (speed 3) (space 0) (debug 0))) (block b5 (let ((*s7* (cons (if (position (if (eql 0 0) (return-from b5 (return-from b5 (let ((*s6* (cons b a))) 0))) b) #(23) :test-not 'eql) 0 0) b))) 0)))) -10305 -26691848)) 0) (deftest misc.406 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer -1 1412366903315) a)) (declare (ignorable a)) (declare (optimize (debug 3) (safety 3) (space 3) (compilation-speed 1) (speed 2))) (progn (tagbody (case 0 ((1 0 4) (values (go 1) 0)) (t 0)) 1) 0))) 251841706892)) 0) ;;; Incorrect binding (deftest misc.407 (funcall (compile nil '(lambda (a) (declare (type (integer -324 175) a)) (declare (ignorable a)) (declare (optimize (safety 0) (space 0) (speed 2) (debug 0) (compilation-speed 0))) (multiple-value-bind (v5) (cons (truncate 0) a) (cdr v5)))) -279) -279) ;;; Stack size too large (deftest misc.408 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer 0 0) a)) (declare (ignorable a)) (declare (optimize (compilation-speed 0) (safety 3) (speed 0) (debug 1) (space 0))) (progn (tagbody (dotimes (iv4 0 (let ((v5 (cons 0 (if (go 3) 0 0)))) 0)) (progn 0)) 3) (ash 0 (min 16 0))))) 0)) 0) ;;; ecl (07 Oct 2004) ;;; (0 . 0) is not of type REAL (deftest misc.409 (funcall (compile nil '(lambda (a b) (declare (type (integer -40524 53538) a)) (declare (type (integer -5967075 -235) b)) (declare (ignorable a b)) (declare (optimize (speed 2) (safety 1) (space 2) (compilation-speed 3) (debug 0))) (labels ((%f2 (f2-1 f2-2 &optional (f2-3 0) (f2-4 a)) 0)) (apply #'%f2 a (%f2 b (flet ((%f12 (f12-1 f12-2 f12-3 &optional &key (key1 0) (key2 0)) (%f2 0 0))) (reduce #'(lambda (lmv2 lmv1) (%f2 0 0 a)) (list 0 0 a 0 0 0 a) :end 7)) 0) nil)))) -7465 -3590953) 0) #| ;;; A bug was found in the compiler. Contact worm@arrakis.es. Broken at C::WT-MAKE-CLOSURE. |# (deftest misc.410 (funcall (compile nil '(lambda () (declare (optimize (safety 0) (space 1) (compilation-speed 0) (speed 2) (debug 0))) (let ((*s2* 0)) (declare (special *s2*)) (reduce #'(lambda (lmv1 lmv2) *s2*) (vector 0) :end 1 :start 0))))) 0) ;;; THROW: The catch CT2 is undefined. (deftest misc.411 (funcall (compile nil '(lambda () (declare (optimize (safety 2) (debug 0) (space 0) (compilation-speed 2) (speed 0))) (catch 'ct2 (values 0 (throw 'ct2 0))) 0))) 0) ;;; /tmp/eclDD7aumXi8.c: In function `LC3': ;;; /tmp/eclDD7aumXi8.c:9: `env0' undeclared (first use in this function) (deftest misc.412 (funcall (compile nil '(lambda (a b) (declare (type (integer -25409 1946) a)) (declare (type (integer -215956065 223815244) b)) (declare (ignorable a b)) (declare (optimize (compilation-speed 2) (space 3) (debug 2) (safety 1) (speed 3))) (complex (flet ((%f15 (f15-1 &optional &key (key1 0)) 0)) (reduce #'(lambda (lmv6 lmv1) (%f15 lmv1)) (list b 0))) 0))) -21802 -105983932) 0) ;;; Different resutls: #, 0 (deftest misc.413 (funcall (compile nil '(lambda (a b) (declare (type (integer -120206733 37762378) a)) (declare (type (integer 2777758072 5675328792) b)) (declare (ignorable a b)) (declare (optimize (compilation-speed 3) (space 3) (debug 3) (safety 0) (speed 1))) (labels ((%f8 (f8-1 f8-2 &optional &key (key1 0)) (let* ((v2 (ash f8-1 (min 63 a)))) 0))) (ignore-errors (logand (apply #'%f8 0 b nil) (unwind-protect 0 (ash (%f8 0 0) (min 48 (flet ((%f12 (f12-1 f12-2 &optional &key (key1 a) (key2 b) &allow-other-keys) 0)) b))))))))) -4794909 4095236669) 0) ;;; sbcl 0.8.14.28 ;;; Wrong value computed (deftest misc.414 (funcall (compile nil '(lambda (c) (declare (optimize (speed 1) (space 3) (compilation-speed 3) (debug 3) (safety 1))) (if (setq c 2) (case (shiftf c 1) ((2) c) (t 0)) 0))) 0) 1) ;;; cmucl ;;; Sept. 2004 snapshot ;;; Wrong return value (deftest misc.415 (funcall #'(lambda (a c) (catch 'ct2 (flet ((%f17 (&optional x &key) (let* ((y (cons (dotimes (iv3 0)) 0))) a))) c))) :bad :good) :good) ;;; Wrong value (deftest misc.416 (funcall (compile nil '(lambda (b) (declare (type (integer 12052668 22838464) b)) (declare (ignorable a b c)) (declare (optimize (compilation-speed 3) (debug 2) (speed 1) (space 0) (safety 3))) (min (mask-field (byte 2 18) b) 89582))) 13891743) 0) ;;; Invalid number of arguments: 3 (deftest misc.417 (funcall (compile nil '(lambda (c) (declare (type (integer 995 22565094) c)) (declare (optimize (safety 2) (debug 1) (space 0) (compilation-speed 2) (speed 1))) (numerator (floor (numerator (deposit-field 0 (byte 0 0) c)))))) 17190042) 17190042) ;;; Invalid number of arguments: # (deftest misc.418 (funcall (compile nil '(lambda (a b c) (declare (type (integer 1670923021 2536883848) a)) (declare (ignorable a b c)) (declare (optimize (safety 3) (compilation-speed 3) (speed 1) (debug 1) (space 2))) (if (logior (setf c 67) 0 a) a 0))) 2161404325 -1968715305 83) 2161404325) ;;; nil is not of type c::continuation ;;; (c::convert-type-check # ;;; ((nil # #))) (deftest misc.419 (funcall (compile nil '(lambda () (declare (optimize (safety 3) (speed 3) (compilation-speed 1) (space 1) (debug 2))) (boole boole-set 0 (case 2 ((0) 0) (t (numerator (catch 'ct2 0)))))))) -1) ;;; nil is not of type c::continuation ;;; (c::convert-type-check # ;;; ((nil # #))) (deftest misc.420 (funcall (compile nil '(lambda (a b) (declare (type (integer -65954801 6519292634236) a)) (declare (type (integer 5721249203 36508717226) b)) (declare (ignorable a b)) (declare (optimize (space 3) (compilation-speed 2) (safety 3) (speed 0) (debug 2))) (flet ((%f14 (f14-1 f14-2 &key) (prog2 0 f14-2 (min (catch 'ct4 (floor 120378948 (max 22 a))))))) (reduce #'(lambda (lmv6 lmv5) (%f14 0 0)) (vector 0 0 0) :start 0 :from-end t)))) 6313133774518 10840050742) 0) ;;; Invalid number of arguments: 1 (deftest misc.421 (funcall (compile nil '(lambda (a) (declare (optimize (debug 0) (space 2) (compilation-speed 1) (safety 0) (speed 0))) (imagpart (block b8 (logior (catch 'ct7 (return-from b8 a)) -1123785))))) -1021899) 0) ;;; Invalid number of arguments: 2 (deftest misc.422 (funcall (compile nil '(lambda (a) (declare (type (integer -13 -3) a)) (declare (optimize (space 2) (debug 1) (safety 1) (speed 2) (compilation-speed 1))) (logorc2 (sbit #*0010000011101010 (min 15 (max 0 0))) a))) -7) 6) ;;; nil is not of type c::continuation ;;; (c::convert-type-check # ;;; ((t # #))) (deftest misc.423 (funcall (compile nil '(lambda (a b) (declare (type (integer 0 1) a)) (declare (type (integer -8031148528 5509023941) b)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (space 2) (safety 3) (debug 1) (compilation-speed 3) (speed 2))) (min 0 (ignore-errors (logand 0 b 388))))) 0 4604112015) 0) ;;; Argument x is not a real: nil. ;;; (kernel:two-arg-> nil 0) (deftest misc.424 (funcall (compile nil '(lambda (a b) (declare (type (integer -24 15) a)) (declare (type (integer -99661829155 16) b)) (declare (ignorable a b)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (safety 3) (debug 1) (compilation-speed 1) (space 3) (speed 3))) (catch 'ct4 (logandc1 a (ignore-errors (let* ((v8 (complex (throw 'ct4 0) 0))) 0)))))) -18 -47519360453) 0) ;;; Different results (deftest misc.425 (funcall (compile nil '(lambda (a b) (declare (type (integer -394128 80657) a)) (declare (type (integer 13729431 14852298) b)) (declare (optimize (space 2) (compilation-speed 1) (safety 0) (debug 0) (speed 2))) (logorc1 (* a (logior b 0)) 0))) -80334 14527920) 1167085925279) ;;; Unable to display error condition (deftest misc.426 (funcall (compile nil '(lambda () #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (safety 3) (space 3) (speed 3) (debug 1) (compilation-speed 3))) (dotimes (iv3 1 0) (logxor iv3 1285775))))) 0) ;;; sbcl 0.8.15.13 ;;; NIL is not of type REAL ;;; (This appears to be related to DYNAMIC-EXTENT) (deftest misc.427 (funcall (compile nil '(lambda (a) (declare (notinline list reduce logior)) (declare (optimize (safety 2) (compilation-speed 1) ; #+sbcl (sb-c:insert-step-conditions 0) (speed 3) (space 2) (debug 2))) (logior (let* ((v5 (reduce #'+ (list 0 a)))) (declare (dynamic-extent v5)) (1- v5))))) 17) 16) (deftest misc.428 (funcall (compile nil '(lambda () (declare (notinline -)) (declare (optimize (compilation-speed 0) (safety 1) (speed 0) (debug 2) (space 3))) (let ((v10 (catch 'ct2 1))) (declare (dynamic-extent v10)) (- v10))))) -1) (deftest misc.429 (funcall (compile nil '(lambda () (declare (optimize (safety 1) (debug 1) (space 2) (speed 2) (compilation-speed 1))) (let ((v8 (let ((*s3* 0)) *s3*))) (declare (dynamic-extent v8)) (logandc1 v8 28))))) 28) ;;; poplog 15.53 ;;; Excess type specifier(s) in THE special form (deftest misc.430 (unwind-protect 0 (the integer 1)) 0) ;;; Wrong return values: T, 0 (deftest misc.431 (funcall (compile nil '(lambda (a) (declare (notinline > *)) (declare (optimize (compilation-speed 0) (safety 2) (speed 2) (debug 0) (space 3))) (catch 'ct1 (* a (throw 'ct1 (if (> 0) a 0)))))) 5445205692802) 5445205692802) ;;; Ste: stack empty (missing argument? missing result?) (deftest misc.432 (loop for x below 2 count (not (not (typep x t)))) 2) (deftest misc.433 (let ((a 1)) (if (not (/= a 0)) a 0)) 0) ;;; sbcl 0.8.16.13 ;;; # is not valid as the first argument to VOP: ;;; SB-VM::FAST-ASH-LEFT-MOD32/UNSIGNED=>UNSIGNED ;;; Primitive type: T ;;; SC restrictions: ;;; (SB-VM::UNSIGNED-REG) ;;; The primitive type disallows these loadable SCs: ;;; (SB-VM::UNSIGNED-REG) (deftest misc.434 (funcall (compile nil '(lambda (a b) (declare (type (integer -8431780939320 1571817471932) a)) (declare (type (integer -4085 0) b)) (declare (ignorable a b)) (declare (optimize (space 2) (compilation-speed 0) #+sbcl (sb-c:insert-step-conditions 0) (debug 2) (safety 0) (speed 3))) (let ((*s5* 0)) (dotimes (iv1 2 0) (let ((*s5* (elt '(1954479092053) (min 0 (max 0 (if (< iv1 iv1) (lognand iv1 (ash iv1 (min 53 iv1))) iv1)))))) 0))))) -7639589303599 -1368) 0) ;;; failed AVER: ;;; "(AND (EQ (CTRAN-KIND START) INSIDE-BLOCK) (NOT (BLOCK-DELETE-P BLOCK)))" (deftest misc.435 (funcall (compile nil '(lambda (a b c d) (declare (notinline aref logandc2 gcd make-array)) (declare (optimize (space 0) (safety 0) (compilation-speed 3) (speed 3) (debug 1) )) (progn (tagbody (let* ((v2 (make-array nil :initial-element (catch 'ct1 (go tag2))))) (declare (dynamic-extent v2)) (gcd (go tag2) (logandc2 (catch 'ct2 c) (aref v2)))) tag2) 0))) 3021871717588 -866608 -2 -17194) 0) ;;; In sbcl 0.8.16.18 ;;; # is not valid as the first argument to VOP: ;;; SB-VM::FAST-ASH-LEFT-MOD32/UNSIGNED=>UNSIGNED ;;; Primitive type: T ;;; SC restrictions: ;;; (SB-VM::UNSIGNED-REG) ;;; The primitive type disallows these loadable SCs: ;;; (SB-VM::UNSIGNED-REG) (deftest misc.436 (funcall (compile nil '(lambda (a b) (declare (type (integer -2917822 2783884) a)) (declare (type (integer 0 160159) b)) (declare (ignorable a b)) (declare (optimize (compilation-speed 1) (speed 3) (safety 3) (space 0) ; #+sbcl (sb-c:insert-step-conditions 0) (debug 0))) (if (oddp (loop for lv1 below 2 count (logbitp 0 (1- (ash b (min 8 (count 0 '(-10197561 486 430631291 9674068)))))))) b 0))) 1265797 110757) 0) ;;; The value NIL is not of type INTEGER. ;;; (in (SB-C::TN-SC-OFFSET 1 #)) (deftest misc.437 (funcall (compile nil '(lambda (a b c d e) (declare (notinline values complex eql)) (declare (optimize (compilation-speed 3) (speed 3) ; #+sbcl (sb-c:insert-step-conditions 0) (debug 1) (safety 1) (space 0))) (flet ((%f10 (f10-1 f10-2 f10-3 &optional (f10-4 (ignore-errors 0)) (f10-5 0) &key &allow-other-keys) (if (or (eql 0 0) t) 0 (if f10-1 0 0)))) (complex (multiple-value-call #'%f10 (values a c b 0 0)) 0)))) 80043 74953652306 33658947 -63099937105 -27842393) 0) ;;; # is not valid as the second argument to VOP: ;;; SB-VM::FAST-ASH-LEFT-MOD32/UNSIGNED=>UNSIGNED ;;; Primitive type: T ;;; SC restrictions: ;;; (SB-VM::UNSIGNED-REG) ;;; The primitive type disallows these loadable SCs: ;;; (SB-VM::UNSIGNED-REG) (deftest misc.438 (funcall (compile nil ' (lambda (a) (declare (type (integer 0 1696) a)) ; (declare (ignorable a)) (declare (optimize (space 2) (debug 0) (safety 1) (compilation-speed 0) (speed 1))) (if (logbitp 0 (ash (1- a) (min 11 a))) 0 0))) 805) 0) ;;; "The value -13589 is not of type (INTEGER -15205 18871)" (deftest misc.439 (funcall (compile nil '(lambda (a) (declare (type (integer -15205 18871) a)) (declare (ignorable a)) (declare (optimize (space 2) ; (sb-c:insert-step-conditions 0) (speed 1) (safety 1) (debug 1) (compilation-speed 3))) (if (<= a (- (setf a 10305))) a 0))) -13589) 10305) ;;; In ACL 7.0 (sparc, Solaris 8, 11 Nov 2004) ;;; Error: the value of (CAR EXCL::INTEGERS) is NIL, which is not of type INTEGER. (deftest misc.440 (funcall (compile nil '(lambda (a b c) (declare (notinline logior)) (declare (optimize (safety 3) (debug 1) (speed 0) (space 1) (compilation-speed 3))) (flet ((%f10 (&optional &key (key1 (logior (flet ((%f4 (f4-1 &optional &key (key1 0) (key2 b) &allow-other-keys) c)) (%f4 0)))) &allow-other-keys) 0)) (let ((*s8* (%f10))) (declare (special *s8*)) *s8*)))) 13524 4484529434427 8109510572804) 0) ;;; Error: the value of realpart is nil, which is not of type (or rational float). (deftest misc.441 (funcall (compile nil '(lambda (a b) (declare (notinline complex)) (declare (optimize (compilation-speed 1) (space 1) (speed 3) (safety 2) (debug 3))) (flet ((%f8 (f8-1 f8-2 &optional &key (key1 (labels ((%f9 nil a)) (complex (%f9) 0))) (key2 0) &allow-other-keys) 0)) (%f8 0 a)))) 1 2) 0) ;;; Error: the value of excl::x is nil, which is not of type integer. (deftest misc.442 (funcall (compile nil '(lambda (a b) (declare (notinline apply evenp)) (declare (optimize (speed 1) (space 1) (safety 1) (compilation-speed 0) (debug 0))) (labels ((%f18 (f18-1 &optional &key (key1 (flet ((%f8 nil b)) (if (evenp (%f8)) 0 a))) (key2 0)) 0)) (apply #'%f18 b nil)))) 505808341634 -39752189) 0) ;;; Error: No from-creg to move to <3:iparam2@(:iparam 2){4=c{s:<3>}}> before (move-throw-tag nil nil -> ({18}) ([18>>:frame :dfr])) (deftest misc.443 (funcall (compile nil '(lambda (a b c d e) (declare (type (integer -2310674 2) a)) (declare (type (integer -492505702625 -147091001460) b)) (declare (type (integer -27638568 52971156) c)) (declare (type (integer -151 203) d)) (declare (type (integer -1400301 8173230) e)) (declare (ignorable a b c d e)) (declare (optimize (compilation-speed 3) (debug 0) (space 0) (safety 1) (speed 1))) (catch 'ct7 (lcm (case 0 ((-4557) (let ((*s7* (max d))) 0)) ((-15387) c) (t 0)) (unwind-protect (throw 'ct7 b) 0))))) -1748290 -244489705763 38969920 -90 341977) -244489705763) ;;; misc.444 ;;; misc.445 ;;; gcl 25 Nov 2004 ;;; Incorrect return value (deftest misc.446 (funcall (compile nil '(lambda (a b c d) (declare (type (integer -1254 1868060) a)) (declare (type (integer -1 0) b)) (declare (type (integer -424707253248 -82453721088) c)) (declare (type (integer -252962 3018671) d)) (declare (ignorable a b c d)) (declare (optimize (safety 3) (space 3) (speed 3) (compilation-speed 3) (debug 3))) (* (labels ((%f8 (&optional (f8-1 0)) (setq b 0))) (if (> d 1668249724 (%f8)) 0 (complex a 0))) (if (oddp b) 0 c)))) 796131 -1 -338008808923 530637) -269099291056676913) (deftest misc.447 (funcall (compile nil '(lambda (a) (declare (type (integer 38632397 46632460288) a)) (declare (optimize (space 0) (safety 0) (debug 1) (compilation-speed 1) (speed 0))) (catch 'ct2 (if (= a 0 (throw 'ct2 0)) 1 2289596)))) 18160383912) 0) (deftest misc.448 (funcall (compile nil '(lambda (a b) (declare (type (integer -3716 1269) a)) (declare (type (integer -1976579 2312) b)) (declare (optimize (compilation-speed 1) (safety 0) (speed 0) (space 0) (debug 3))) (if (<= 0 b (setq a 117)) 0 a))) -1147 -44004) 117) ;;; gcl 27 Nov 2004 ;;; Incorrect return value (deftest misc.449 (funcall (compile nil '(lambda (a) (* 10 a (setq a 1000)))) 1) 10000) ;;; Error in COMPILER::CMP-ANON [or a callee]: The variable MIN is unbound. (deftest misc.450 (funcall (compile nil '(lambda (a b) (min 0 (reduce #'min (vector a b 0)) 0))) -10 -1) -10) ;;; gcl 28 Nov 2004 ;;; Incorrect return value (deftest misc.451 (funcall (compile nil '(lambda (a b) (flet ((%f3 () (setq a -2210))) (logxor a b (%f3))))) -22650 20595) 171) (deftest misc.452 (funcall (compile nil '(lambda (d) (labels ((%f3 () (setf d -1135) -983)) (+ d (%f3) 11267)))) -2914) 7370) (deftest misc.453 (funcall (compile nil '(lambda (a) (* a (setf a 2) a (identity 5)))) 3) 60) (deftest misc.454 (let* ((form '(let ((v1 0)) (decf v1 (setq v1 -1)))) (val1 (eval form)) (val2 (funcall (compile nil `(lambda () ,form))))) (if (eql val1 val2) :good (list val1 val2))) :good) ;;; sbcl 0.8.17.24 ;;; Bugs in the just-introduced fixnum arithmetic transforms ;;; LOGAND (?) bug (deftest misc.455 (funcall (compile nil '(lambda (a b) (declare (type (integer -4079701634499 2272876436845) b)) (declare (optimize (space 0) (compilation-speed 1) (safety 3) (speed 2) (debug 0))) (logand (* -775 b) a 37284))) -18465060867 832909434173) 32772) (deftest misc.456 (funcall (compile nil '(lambda (b c) (declare (type (integer -30606350847 35078064098) b)) (declare (type (integer -6652 6638) c)) (declare (optimize (space 3) (safety 0) (speed 0) (compilation-speed 2) (debug 1))) (logand (* -9964236 (setq c 6206) 2600) b c))) 17296668225 -6574) 4096) ;;; DEPOSIT-FIELD (?) bug (deftest misc.457 (funcall (compile nil '(lambda (a b) (declare (type (integer -455461 343063) a)) (declare (type (integer -1020097 -12430) b)) (declare (optimize (speed 3) (space 0) (compilation-speed 3) (debug 0) (safety 3))) (deposit-field (* (logeqv a a) b) (byte 6 24) 0))) -212811 -985078) 0) ;;; LDB, * (deftest misc.458 (funcall (compile nil ' (lambda (a) (declare (type (integer -8175 27760966190) a)) (declare (optimize ;; The next optimize declaration is necessary ;; for the bug to occur in sbcl 0.8.17.24 #+sbcl (sb-c:insert-step-conditions 0) (space 2) (speed 0) (compilation-speed 1) (safety 0) (debug 3))) (ldb (byte 29 0) (* a a)))) 14774118941) 101418825) ;;; LOGAND, + (deftest misc.459 (funcall (compile nil '(lambda (a b) (declare (type (integer -32933298905 -168011) a)) (declare (type (integer -190015111797 16) b)) (declare (optimize (speed 2) (compilation-speed 0) (space 0) (safety 1) (debug 0))) (logand (+ b -9255) a 63))) -8166030199 -45872222127) 8) ;;; In sbcl 0.8.17.28-signed-modular-arithmetic.3 ;;; Unreachable code is found or flow graph is not properly depth-first ordered. ;;; (This is apparently a different bug from the previous ones that ;;; were causing this message to be printed.) (deftest misc.460 (funcall (compile nil '(lambda (a) (declare (type (integer 50354997 50514623) a)) (declare (ignorable a)) (declare (optimize (speed 0) (safety 0) (compilation-speed 3) #+sbcl (sb-c:insert-step-conditions 0) (debug 1) (space 1))) (loop for lv3 below 2 sum (if (find 0 '(-17604051 126613572 -795198 12037855 127043241 -2 -59 -3458890 1505 -1 -2 107498637 -977489 172087 421813 543299114 12 4311490 569 -3509 -4051770 -1 1 1 216399387 -2482 143297 2 304550 -61 -195904988 57682175 2344 1294831 -247 -2 25779388 -296 -12115 -158487 -15) :test 'eql) (if (find 0 #(4193594) :test '<) (min (catch 'ct6 0) (catch 'ct8 0) 0) (let ((*s1* (cons a 0))) (car *s1*))) 0)))) 50395193) 0) ;;; gcl 16 Dec 2004 ;;; Error possibly related to type propagation (deftest misc.461 (funcall (compile nil '(lambda (a) (declare (type (integer -26657952320 0) a)) (declare (optimize (compilation-speed 0) (space 3) (speed 3) (safety 0) (debug 2))) (- a (ash -1 (min 31 (- a))) -26715477))) -26179151369) -24004952244) ;;; gcl 18 Dec 2004 ;;; Doesn't cause an error, unless -Werror is added to gcc flags ;;; gazonk0.c: In function `L1': ;;; gazonk0.c:5257: warning: assignment makes integer from pointer without a cast (deftest misc.462 (funcall (compile nil '(lambda (a b) (declare (type (integer -2726808666112 -26532) a)) (declare (type (integer 182701814 171137312256) b)) (declare (ignorable a b)) (declare (optimize (compilation-speed 3) (safety 0) (speed 3) (space 3) (debug 3))) (ash (let* ((v8 (cons 0 0))) 0) (min 15 a)))) -1982565461868 46279989780) 0) ;;; gazonk0.c: In function `L1': ;;; gazonk0.c:5262: warning: assignment makes integer from pointer without a cast (deftest misc.463 (funcall (compile nil '(lambda (a b) (declare (type (integer 0 0) a)) (declare (type (integer -160364747008 264742845184) b)) (declare (ignorable a b)) (declare (optimize (debug 0) (safety 0) (compilation-speed 2) (space 0) (speed 1))) (ash (multiple-value-setq (a) 0) (min 97 13027666096)))) 0 34670845086) 0) ;;; gcl 21 Dec 2004 ;;; Compiler error on ash, rem (deftest misc.464 (funcall (compile nil '(lambda () (declare (optimize (debug 1) (safety 2) (compilation-speed 0) (space 1) (speed 1))) (count (ash (the integer (macrolet () (rem -197 (min -72 215)))) (min 98 442719)) #(0 96) :test '=)))) 0) (deftest misc.465 (funcall (compile nil '(lambda (a) (declare (type (integer -18822 -1280) a)) (declare (optimize (debug 0) (speed 1) (compilation-speed 3) (safety 0) (space 0))) (ash (the integer (logand a (if t a (imagpart -2607360)))) (min 79 (catch 'ct7 0))))) -17635) -17635) ;;; ACL 6.2 (x86 linux) ;;; Bug in type propagation for ISQRT ;;; Found with the special purpose random tester for type propagation ;;; While compiling (:ANONYMOUS-LAMBDA 22203): ;;; Error: -1 is illegal argument to isqrt (deftest misc.466 (funcall (compile nil '(lambda (x) (declare (type (member 4 -1) x) (optimize speed (safety 1))) (isqrt x))) 4) 2) ;;; gcl 24 Dec 2004 ;;; Incorrect results (these may all be related) ;;; These are also produced by the special purpose tester in random-type-prop.lsp (deftest misc.467 (funcall (compile nil '(lambda (p2 p3) (declare (optimize speed (safety 1)) (type (integer -990888631320) p2) (type (integer -20346 -19755) p3)) (+ -77 (the (integer * -990888630255) p2) p3))) -990888630272 -19756) -990888650105) (deftest misc.468 (funcall (compile nil '(lambda (p2 p3) (declare (optimize speed (safety 1)) (type (integer * 151075404030) p2) (type (integer 6515518 *) p3)) (- 12967657127936 (the (eql 151075403520) p2) (the (member 6515658 -14) p3)))) 151075403520 6515658) 12816575208758) (deftest misc.469 (funcall (compile nil '(lambda (p2) (declare (optimize speed (safety 1)) (type integer p2)) (+ 30926 (the (integer -4025987543018 *) p2)))) -4025817763840) -4025817732914) (deftest misc.470 (funcall (compile nil '(lambda (p2) (declare (optimize speed (safety 1)) (type (integer 3689224658939 *) p2)) (+ -1071 (the (integer * 3689229115390) p2)))) 3689228853248) 3689228852177) (deftest misc.471 (funcall (compile nil '(lambda (p1 p2) (declare (optimize speed (safety 1)) (type (integer -9024844 230253450) p1) (type (eql 35716681856) p2)) (* p1 (the (integer * 35716681856) p2)))) -9024809 35716681856) -322336231864165504) (deftest misc.472 (funcall (compile nil '(lambda (p1 p2) (declare (optimize speed (safety 1)) (type (integer -785238 -80) p1) (type (eql -523213622272) p2)) (min p1 (the integer p2)))) -259 -523213622272) -523213622272) (deftest misc.473 (funcall (compile nil '(lambda (p2) (declare (optimize speed (safety 1)) (type (integer * 65861934352) p2)) (max 23939 (the (integer 64863825609 65878336765) p2)))) 65861912512) 65861912512) (deftest misc.474 (funcall (compile nil '(lambda (p1) (declare (optimize speed (safety 1)) (type (integer -6750156308) p1)) (logand (the signed-byte p1) -540165229))) -6750156304) -7289140848) ;;; abcl 25 Dec 2005 ;;; Debugger invoked on condition of type UNDEFINED-FUNCTION: ;;; The function %FAILED-AVER is undefined. (deftest misc.475 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (p1 p2 p3 p4 p6) (declare (optimize speed (safety 1)) (type (integer -785238 61564048) p1) (type (integer * 65861934352) p2)) (+ P1 (THE (INTEGER -485480 -7019) P2) P3 P4 463666373060 P6))) 61564048 -7457 24939545512 51 730)) 488667475944) (deftest misc.476 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (p4) (declare (optimize speed (safety 1)) (type (integer -115781893486) p4)) (- 1 -35 0 (the (integer -115778245122) p4) -2))) -115778114900)) 115778114938) (deftest misc.477 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (p4 p5) (declare (optimize speed (safety 1)) (type (integer -126908726190 -126906628448) p4) (type (integer * 2202) p5)) (* -1950 -33610502463 2 p4 p5))) -126906629040 1839)) -30591843552678654213361992000) (deftest misc.478 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (p2) (declare (optimize speed (safety 1)) (type (integer * 2343679) p2)) (logand 12050257282405 p2 117775123 505354693 -415679150084))) -6189)) 33816832) ;;; Bug in CMUCL Snapshot 2004-10 ;;; Invalid number of arguments: 370632372 (deftest misc.479 (let ((r (make-array nil :element-type '(unsigned-byte 32))) (fn (compile nil '(lambda (r p2) (declare (optimize speed (safety 1)) (type (simple-array (unsigned-byte 32) nil) r) (type integer p2)) (setf (aref r) (logxor 0 (the (integer 2797513123 2798027357) p2))) (values))))) (funcall fn r 2797674503) (aref r)) 2797674503) (deftest misc.480 (let ((r (make-array nil :element-type 'integer)) (fn (compile nil '(lambda (r p1) (declare (optimize speed (safety 1)) (type (simple-array integer nil) r) (type (integer -797971 -797511) p1)) (setf (aref r) (logeqv p1 15 1078254884158 -12564176924 0 15096591909)) (values))))) (funcall fn r -797965) (aref r)) -1075415510532) (deftest misc.481 (let ((r (make-array nil :element-type '(unsigned-byte 16))) (fn (compile nil '(lambda (r p1) (declare (optimize speed (safety 1)) (type (simple-array (unsigned-byte 16) nil) r) (type (member 4194309 -123 1692 -4432 -760653 -1741 37) p1)) (setf (aref r) (logorc1 (the (eql -4432) p1) 0)) (values))))) (funcall fn r -4432) (aref r)) 4431) ;; Various incorrect results (deftest misc.482 (let ((r (make-array nil :element-type '(unsigned-byte 4))) (fn (compile nil '(lambda (r p2) (declare (optimize speed (safety 1)) (type (simple-array (unsigned-byte 4) nil) r) (type (eql -4) p2)) (setf (aref r) (logorc2 13 p2)) (values))))) (funcall fn r -4) (aref r)) 15) (deftest misc.483 (let ((r (make-array nil :element-type '(unsigned-byte 4))) (fn (compile nil '(lambda (r p1 p2) (declare (optimize speed (safety 1)) (type (simple-array (unsigned-byte 4) nil) r) (type (integer * 28306533) p1) (type (integer * 1245601) p2)) (setf (aref r) (logandc1 p1 (the (integer -3308174) p2))) (values))))) (funcall fn r -519 -28180) (aref r)) 4) (deftest misc.484 (let ((r (make-array nil :element-type '(unsigned-byte 4))) (fn (compile nil '(lambda (r p2) (declare (optimize speed (safety 1)) (type (simple-array (unsigned-byte 4) nil) r) (type (member 260646 -348969 34359738370 -110167) p2)) (setf (aref r) (logandc2 9 (the (eql -348969) p2))) (values))))) (funcall fn r -348969) (aref r)) 8) (deftest misc.485 (let ((r (make-array nil :element-type 'bit)) (fn (compile nil '(lambda (r p2) (declare (optimize speed (safety 1)) (type (simple-array bit nil) r) (type (integer -108220 256178) p2)) (setf (aref r) (logand 1 (the (member -1 2147483652 1 -5 3802) p2))) (values))))) (funcall fn r -5) (aref r)) 1) (deftest misc.486 (let ((r (make-array nil :element-type '(unsigned-byte 4))) (fn (compile nil '(lambda (r p1 p2) (declare (optimize speed (safety 1)) (type (simple-array (unsigned-byte 4) nil) r) (type (integer -9) p1) (type (integer * 1234117) p2)) (setf (aref r) (logior (the (integer -295 *) p1) (the (integer -90 *) p2))) (values))))) (funcall fn r 6 6) (aref r)) 6) (deftest misc.487 (let ((r (make-array nil :element-type '(unsigned-byte 16))) (fn (compile nil '(lambda (r p1) (declare (optimize speed (safety 1)) (type (simple-array (unsigned-byte 16) nil) r) (type (integer 1583040351 1587341394) p1)) (setf (aref r) (logandc2 (the (integer 1587211196 1587341392) p1) -166174)) (values))))) (funcall fn r 1587341392) (aref r)) 34832) (deftest misc.488 (let ((r (make-array nil :element-type '(unsigned-byte 32))) (fn (compile nil '(lambda (r p2) (declare (optimize speed (safety 1)) (type (simple-array (unsigned-byte 32) nil) r) (type (integer 1960409798 1960426181) p2)) (setf (aref r) (logorc1 -1 p2)) (values))))) (funcall fn r 1960409801) (aref r)) 1960409801) (deftest misc.489 (let ((r (make-array nil :element-type '(unsigned-byte 32))) (fn (compile nil '(lambda (r p2) (declare (optimize speed (safety 1)) (type (simple-array (unsigned-byte 32) nil) r) (type (integer -55) p2)) (setf (aref r) (logorc2 0 (the (member -51) p2))) (values))))) (funcall fn r -51) (aref r)) 50) (deftest misc.490 (let ((r (make-array nil :element-type '(unsigned-byte 32))) (fn (compile nil '(lambda (r p1) (declare (optimize speed (safety 1)) (type (simple-array (unsigned-byte 32) nil) r) (type (integer 761639858 1030075825) p1)) (setf (aref r) (logior (the (integer * 35389813668) p1) 0)) (values))))) (funcall fn r 1030075308) (aref r)) 1030075308) (deftest misc.491 (let ((r (make-array nil :element-type '(signed-byte 16))) (fn (compile nil '(lambda (r p2) (declare (optimize speed (safety 1)) (type (simple-array (signed-byte 16) nil) r) (type (integer 505774114 573717424) p2)) (setf (aref r) (lognand 58539 (the (integer * 910674467) p2))) (values))))) (funcall fn r 506608551) (aref r)) -8356) (deftest misc.492 (let ((r (make-array nil :element-type '(signed-byte 8))) (fn (compile nil '(lambda (r p1) (declare (optimize speed (safety 1)) (type (simple-array (signed-byte 8) nil) r) (type (integer * 22050378) p1)) (setf (aref r) (lognand (the (integer 19464371) p1) 2257)) (values))))) (funcall fn r 19469591) (aref r)) -18) ;;; ABCL (25 Dec 2004) ;;; Class verification failed: (class: org/armedbear/lisp/out, method: execute signature: (Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;) Expecting to find integer on stack (deftest misc.493 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (b) (declare (optimize (speed 2) (debug 1) (safety 3) (compilation-speed 3) (space 1))) (aref #(41397376227 18660605846 49244777443) (min 2 (max 0 b))))) -71)) 41397376227) ;;; ABCL (26 Dec 2004) ;;; Class verification failed: [...] Illegal exception table range (deftest misc.494 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda () (declare (optimize (safety 0) (space 2) (debug 3) (speed 0) (compilation-speed 2))) (conjugate (progn (catch 'ct5 (if t 0 0)) 0)))))) 0) ;;; The value 5085 is not of type FUNCTION. (deftest misc.495 (funcall (compile nil '(lambda (a b) (declare (type (integer -4197 284380207) a)) (declare (type (integer -23 5088) b)) (declare (ignorable a b)) (declare (optimize (speed 1) (space 2) (debug 0) (compilation-speed 0) (safety 2))) (if (position (progn (1+ b) 0) '(169496 -726 -13623 53307916 128 -258391 156 7432659 30 20 -11)) 0 a))) 72179019 5084) 72179019) ;;; Inconsistent stack height 1 != 2 (deftest misc.496 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer -54915 -3396) a)) (declare (optimize (debug 3) (space 0) (safety 2) (speed 2) (compilation-speed 3))) (progn (1+ a) (catch 'ct6 (progn 0))))) -25986)) 0) (deftest misc.497 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (b) (declare (type (integer -1 0) b)) (declare (optimize (space 3) (compilation-speed 1) (safety 0) (debug 1) (speed 0))) (if 0 (prog2 0 0 (1+ b)) 0))) 0)) 0) ;;; Inconsistent stack height 1 != 0 (deftest misc.498 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer -16191 4) a)) (declare (optimize (compilation-speed 2) (space 1) (debug 0) (safety 0) (speed 2))) (conjugate (dotimes (iv1 0 0) (let ((v2 (dotimes (iv3 0 0) (1+ a)))) 0))))) -2840)) 0) ;;; Incompatible object argument for function call (deftest misc.499 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a b) (declare (type (integer -31415 133871) a)) (declare (type (integer -993 6448) b)) (declare (ignorable a b)) (declare (optimize (space 0) (debug 2) (safety 0) (speed 0) (compilation-speed 0))) (progn (ceiling (progn (1+ b) a)) a))) -16435 2620)) -16435) ;;; Stack overflow during compilation (deftest misc.500 (funcall (compile nil '(lambda nil (declare (optimize (space 2) (debug 2) (compilation-speed 2) (speed 1) (safety 3))) (the integer (integer-length (dotimes (iv4 2 15790955))))))) 24) ;;; Inconsistent stack height 1 != 0 (deftest misc.501 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer -437165353 179983908) a)) (declare (optimize (compilation-speed 0) (debug 1) (space 1) (safety 2) (speed 1))) (dotimes (iv1 0 0) (1+ a)))) 1)) 0) ;;; Ordering problems (deftest misc.502 (funcall (compile nil '(lambda (a) (declare (type (integer -7 84717795) a)) (declare (ignorable a)) (declare (optimize (speed 1) (space 1) (debug 1) (safety 2) (compilation-speed 0))) (+ a (setq a 35035201)))) 29207264) 64242465) ;;; ABCL 27 Dec 2004 ;;; Different results (deftest misc.503 (funcall (compile nil '(lambda (a) (declare (optimize (space 3) (debug 1) (speed 2) (safety 0) (compilation-speed 1))) (catch 'ct1 (throw 'ct1 (catch 'ct5 (reduce 'min (vector 0 0 0 a a 0 0 (values 0 0) (throw 'ct5 -6)) :end 8 :start 6 :from-end t)))))) 17) -6) ;;; Inconsistent stack height (deftest misc.504 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer 196060 241373941) a)) (declare (ignorable a)) (declare (optimize (speed 3) (debug 0) (safety 2) (compilation-speed 3) (space 2))) (prog2 (if 0 (+ a a) 0) 0))) 200000)) 0) (deftest misc.505 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer -6 5) a)) (declare (optimize (speed 3) (space 0) (safety 2) (compilation-speed 2) (debug 3))) (dotimes (iv1 0 0) (+ a a)))) 1)) 0) (deftest misc.506 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer -53 49) a)) (declare (optimize (debug 0) (compilation-speed 1) (space 2) (safety 0) (speed 0))) (unwind-protect (+ a a) 0))) -38)) -76) ;;; The value 15390 is not of type FUNCTION. (deftest misc.507 (funcall (compile nil '(lambda (a) (declare (type (integer 2697 13005) a)) (declare (optimize (debug 0) (space 2) (speed 2) (compilation-speed 3) (safety 3))) (truncate (prog1 0 a (+ a a))))) 7695) 0 0) ;;; COMPILE-FORM: unsupported special operator LET* ;;; Associated with 'THE' operator (deftest misc.508 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer -57853147 -2) a)) (declare (ignorable a)) (declare (optimize (debug 2) (space 1) (compilation-speed 3) (safety 1) (speed 2))) (the integer (mask-field (byte 2 29) (ash (multiple-value-setq (a) -51781613) (min 1 a)))))) -29324754)) 1610612736) (deftest misc.509 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer -38984312 657) a)) (declare (ignorable a)) (declare (optimize (debug 1) (compilation-speed 1) (speed 1) (safety 2) (space 3))) (the integer (if (> a -27907941364) 116871 (cl:handler-case (multiple-value-setq (a) -34832621)))))) -26788929)) 116871) (deftest misc.510 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer -2827 3400) a)) (declare (optimize (compilation-speed 1) (space 3) (debug 1) (safety 0) (speed 1))) (logand (the integer (dotimes (iv4 2 a) (progn iv4)))))) 155)) 155) (deftest misc.511 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer 18967 23584) a)) (declare (ignorable a)) (declare (optimize (space 1) (speed 1) (debug 1) (compilation-speed 3) (safety 1))) (the integer (values (loop for lv4 below 2 count (find a '(16389))))))) 21352)) 0) ;;; Inconsistent stack height (deftest misc.512 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer 1 188902468) a)) (declare (ignorable a)) (declare (optimize (space 2) (speed 3) (safety 3) (compilation-speed 0) (debug 2))) (catch 'ct6 (the integer (let* ((v3 (signum (ignore-errors a)))) (declare (dynamic-extent v3)) (throw 'ct6 (round (case (prog2 (lognor 290171664 v3) -3512003993 -550842867) ((4) (* 1 4092)) ((21 220 225) (block b1 (setf v3 (let* ((v9 v3)) a)))) (t -639367819))))))))) 49008586)) -639367819 0) ;;; COMPILE-FORM: unsupported special operator LET* ;;; Associated with 'THE' operator (deftest misc.513 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer -2 75025568) a)) (declare (ignorable a)) (declare (optimize (space 0) (compilation-speed 0) (safety 0) (speed 2) (debug 2))) (let* ((v8 (cons (the integer (prog2 a -1558460 a (ignore-errors (progn (tagbody) -49510826)) a)) 0))) 0))) 68043554)) 0) (deftest misc.514 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer -6844832476 188341751) a)) (declare (optimize (speed 3) (debug 1) (safety 0) (space 3) (compilation-speed 1))) (the integer (multiple-value-setq (a) -96073358)))) -3792864899)) -96073358) ;;; gcl 27 Dec 2004 ;;; Issue with dynamic extent (deftest misc.515 (funcall (compile nil '(lambda (a) (declare (type (integer -1337016312 832159784) a)) (declare (optimize speed (safety 1))) (let* ((y 0) (v9 0)) (declare (dynamic-extent v9)) (setq v9 (+ a a)) (setq y (1+ v9))))) -1209913207) -2419826413) (deftest misc.516 (funcall (compile nil '(lambda () (declare (optimize (space 0) (debug 0) (safety 2) (compilation-speed 3) (speed 1))) (let ((*s2* (* -507991378 14))) (declare (dynamic-extent *s2*)) (declare (special *s2*)) (1+ *s2*))))) -7111879291) ;;; gcl 29 Dec 2004 ;;; Interference of special variable bindings? (deftest misc.517 (funcall (compile nil '(lambda () (declare (optimize (safety 3) (space 3) (debug 1) (speed 1) (compilation-speed 0))) (let* ((*s8* (let ((*s8* (make-array nil :initial-element 0))) (declare (special *s8*)) (progn (shiftf (aref *s8*) 31508066) 0)) )) (declare (special *s8*)) 0)))) 0) ;;; Incorrect return value (deftest misc.518 (funcall (compile nil '(lambda () (declare (optimize (compilation-speed 0) (safety 1) (debug 1) (space 0) (speed 3))) (flet ((%f10 (&optional (f10-1 0) (f10-2 0) &key) (progn (tagbody (decf f10-2) (return-from %f10 (complex (unwind-protect (go tag7)) 0)) tag7) f10-2))) (if (evenp (%f10 0 0)) 0 2140390))))) 2140390) ;;; Error in APPLY [or a callee]: fixnum or bignum expected ;;; Broken at COMPILER::CMP-ANON. (deftest misc.519 (funcall (compile nil '(lambda () (declare (optimize (compilation-speed 0) (speed 1) (debug 1) (space 1) (safety 3))) (let ((*s3* (* (the integer (expt (rationalize (multiple-value-bind (*s3*) (make-array nil :initial-element 0) (shiftf (aref *s3*) 0))) 2))))) 1)))) 1) ;;; sbcl 0.8.18 (sparc solaris) ;;; identity ASH not transformed away (deftest misc.520 (funcall (compile nil '(lambda (a c e) (declare (type (integer -44330 64753) c)) (declare (type (integer -301534047 4291509) e)) (declare (optimize (safety 3) (debug 2) (speed 3) (space 2) (compilation-speed 2))) (if (oddp (ash (logorc2 c e) (min 2 (mask-field (byte 0 0) (mod 0 (max 69 0)))))) a 0))) 1 -8156 -229264929) 0) ;;; ecl (25 Jan 2005) ;;; Error: In a call to AREF, the type of the form *S6* is FIXNUM, not (ARRAY *). (deftest misc.521 (funcall (compile nil '(lambda (b) (declare (optimize (speed 0) (safety 1) (debug 1) (compilation-speed 3) (space 0))) (if b (let ((*s6* 0)) 0) (let* ((*s6* (make-array nil :initial-element 0))) (aref *s6*))))) nil) 0) ;;; nil is not of type number. (deftest misc.522 (funcall (compile nil '(lambda (a) (declare (type (integer -25 38) a)) (declare (optimize (compilation-speed 3) (safety 3) (debug 1) (space 2) (speed 1))) (flet ((%f2 (f2-1 f2-2 &optional (f2-3 (labels ((%f6 (&optional (f6-1 0) (f6-2 0)) (max a))) (%f6 0))) (f2-4 0) (f2-5 0)) (flet ((%f4 (f4-1 f4-2 f4-3) (flet ((%f15 () f2-3)) a))) 0))) (reduce #'(lambda (lmv1 lmv6) a) (vector 0 0 0 (%f2 a a) 0 a 0 a 0) :start 4 :from-end t)))) 35) 35) ;;; Incorrect return value (deftest misc.523 (funcall (compile nil '(lambda (a) (declare (type (integer -1011 978) a)) (declare (optimize (compilation-speed 1) (safety 3) (debug 0) (speed 2) (space 1))) (let ((*s5* (cons 0 (catch 'ct8 (ash (flet ((%f15 (f15-1) (return-from %f15 a))) 0) (min 57 (lognor (throw 'ct8 (shiftf a 332)) (let ((v1 (setf a 371))) a)))))))) a))) 99) 332) ;;; Seg fault (deftest misc.524 (funcall (compile nil '(lambda (a b) (declare (type (integer -2432551 871) a)) (declare (type (integer -6390 -1) b)) (declare (ignorable b)) (declare (optimize (compilation-speed 0) (safety 0) (space 2) (speed 0) (debug 3))) (flet ((%f18 (f18-1 f18-2 f18-3 &optional &key (key1 0) &allow-other-keys) (labels ((%f12 (f12-1 &optional (f12-2 0) &key (key1 (catch 'ct7 (conjugate key1))) (key2 0) &allow-other-keys) 0)) (%f12 a)))) (%f18 a 0 0)))) -925293 -1603) 0) ;;; Internal error: tried to advance stack. (deftest misc.525 (funcall (compile nil '(lambda (a) (declare (type (integer -17179869184 -2147483648) a)) (declare (ignorable a)) (declare (optimize (space 2) (debug 3) (speed 3) (compilation-speed 3) (safety 1))) (catch 'ct4 (max (conjugate (unwind-protect 0 (catch 'ct4 (values 0)))) (throw 'ct4 0))))) -17179869184) 0) ;;; integer does not specify a sequence type (deftest misc.526 (funcall (compile nil '(lambda (a) (declare (type (integer -4 3025867) a)) (declare (ignorable a)) (declare (optimize (space 1) (safety 0) (debug 0) (speed 3) (compilation-speed 0))) (flet ((%f14 (f14-1 f14-2 f14-3 &key) (let ((v4 (return-from %f14 (flet ((%f11 (&optional (f11-1 0) (f11-2 0) (f11-3 (coerce (reduce (function (lambda (lmv2 lmv5) a)) (vector f14-1 f14-1 0 f14-3 a f14-3 a f14-1 0 f14-2)) (quote integer))) &key (key1 f14-3) (key2 a)) (flet ((%f8 (f8-1 &optional (f8-2 (flet ((%f16 (f16-1 f16-2 f16-3 &optional &key (key1 0) (key2 f11-3)) key1)) 0)) &key (key1 0)) f14-3)) 0))) (if (%f11 f14-1 (%f11 0 f14-3) f14-1) 0 0))))) 0))) (%f14 0 a a)))) 857304) 0) ;;; sbcl 0.8.19.32 ;;; Type propagation problem with BIT-AND (deftest misc.527 (let ((v1 (make-array 1 :element-type 'bit :initial-contents '(1) :fill-pointer 0)) (v2 (make-array 1 :element-type 'bit :initial-contents '(1) :fill-pointer 1)) (r (make-array nil))) (funcall (compile nil `(lambda (r p2) (declare (optimize speed (safety 1)) (type (simple-array t nil) r) (type (array *) p2)) (setf (aref r) (bit-and ,v1 (the (bit-vector *) p2))) (values))) r v2) (let ((result (aref r))) (values (notnot (simple-bit-vector-p result)) (=t (array-dimension result 0) 1) (=t (aref result 0) 1)))) t t t) ;;; The value 22717067 is not of type (INTEGER 22717067 22717067) (deftest misc.528 (let* ((x 296.3066f0) (y 22717067) (form `(lambda (r p2) (declare (optimize speed (safety 1)) (type (simple-array single-float nil) r) (type (integer -9369756340 22717335) p2)) (setf (aref r) (* ,x (the (eql 22717067) p2))) (values))) (r (make-array nil :element-type 'single-float)) (expected (* x y))) (funcall (compile nil form) r y) (let ((actual (aref r))) (unless (eql expected actual) (list expected actual)))) nil) ;;; The value 46790178 is not of type (INTEGER 46790178 46790178). (deftest misc.529 (let* ((x -2367.3296f0) (y 46790178) (form `(lambda (r p2) (declare (optimize speed (safety 1)) (type (simple-array single-float nil) r) (type (eql 46790178) p2)) (setf (aref r) (+ ,x (the (integer 45893897) p2))) (values))) (r (make-array nil :element-type 'single-float)) (expected (+ x y))) (funcall (compile nil form) r y) (let ((actual (aref r))) (unless (eql expected actual) (list expected actual)))) nil) ;;; cmucl (Jan 2005 snapshot) ;;; Segmentation fault (deftest misc.530 (let* ((v (make-array '(11) :element-type 'double-float :initial-contents '(56826.586316245484d0 -57680.53641925701d0 68651.27735979737d0 30934.627728043164d0 47252.736017400945d0 35129.46986219467d0 -57804.412938803005d0 13000.374416975968d0 50263.681826551256d0 89386.08276072948d0 -89508.77479231959d0))) (form `(lambda (r) (declare (optimize speed (safety 1)) (type (simple-array t nil) r)) (setf (aref r) (array-has-fill-pointer-p ,v)))) (r (make-array nil))) (funcall (compile nil form) r) (eqlt (aref r) (array-has-fill-pointer-p v))) t) ;;; gcl ;;; Problem with 0-dim char arrays ;;; Produces wrong return value (#\\320). (deftest misc.532 (let ((r (make-array nil :element-type 'base-char))) (funcall (compile nil '(lambda (r c) (declare (optimize speed (safety 1)) (type (simple-array base-char nil) r) (type base-char c)) (setf (aref r) c) (values))) r #\Z) (aref r)) #\Z) ;;; sbcl 0.8.19.32 ;;; Bound is not *, a INTEGER or a list of a INTEGER: -51494/29889 (deftest misc.533 (let* ((r (make-array nil)) (c #c(208 -51494/29889)) (form `(lambda (r p1) (declare (optimize speed (safety 1)) (type (simple-array t nil) r) (type number p1)) (setf (aref r) (+ (the (eql ,c) p1) -319284)) (values))) (fn (compile nil form))) (funcall fn r c) (eqlt (aref r) (+ -319284 c))) t) ;;; sbcl 0.8.19.35 ;;; Incorrect return value from conditional (deftest misc.534 (let ((r0 (make-array nil))) (funcall (compile nil '(lambda (r p1 p2 p3) (declare (optimize speed (safety 1)) (type (eql 4134713351/6105637898) p2) (type (eql 2685) p3)) (setf (aref r) (if p1 (the (eql 4134713351/6105637898) p2) (the (integer * 8391301) p3))))) r0 t 4134713351/6105637898 2685) (aref r0)) 4134713351/6105637898) #| The value # :ASSERTED-TYPE # :TYPE-TO-CHECK # {DECFF19}> is not of type SB-C::REF. |# (deftest misc.535 (let ((c0 #c(4196.088977268509d0 -15943.3603515625d0))) (funcall (compile nil `(lambda (p1 p2) (declare (optimize speed (safety 1)) (type (simple-array t nil) r) (type (eql ,c0) p1) (type number p2)) (eql (the (complex double-float) p1) p2))) c0 #c(12 612/979))) nil) ;;; Similar to misc.535 (deftest misc.536 (funcall (compile nil '(lambda (p1 p2) (declare (optimize speed (safety 1)) (type (eql #c(11963908204 1/6)) p1) (type (complex rational) p2)) (eql p1 (the complex p2)))) #c(11963908204 1/6) #c(2343315619 5252231066)) nil) ;;; Comparison of bit vectors in compiled code (deftest misc.537 (let ((p1 (make-array '(0) :element-type 'bit :adjustable t))) (notnot (funcall (compile nil `(lambda (p2) (declare (optimize speed (safety 1)) (type (simple-array t nil) r) (type (simple-bit-vector 0) p2)) (equal ,p1 (the (bit-vector 0) p2)))) #*))) t) ;;; abcl (23 Feb 2005) ;;; The value #C(3 4) is not of type number. (deftest misc.538 (notnot (typep (* 2/5 #c(3 4)) 'number)) t) ;;; Allegro CL (6.2 trial edition, x86) ;;; Error: `#c(0 -8)' is not of the expected type `REAL' (deftest misc.539 (notnot-mv (complexp (funcall (compile nil '(lambda (x) (declare (OPTIMIZE SPEED (SAFETY 1)) (type (eql #c(0 -8)) x)) (sqrt x))) #c(0 -8)))) t) ;;; Illegal instruction (deftest misc.540 (let* ((d0 #(a b c d e f g h)) (d1 (make-array 5 :fill-pointer 1 :displaced-to d0 :displaced-index-offset 2))) (find #c(1.0 2.0) d1)) nil) ;;; A crasher bug of REMOVE on non-simple nibble arrays (deftest misc.541 (dotimes (i 1000) (let* ((init '(12 11 8 8 11 10 9 1 3 9 6 12 4 3 6 4 7 10 12 6 11 12 4 15 8 10 7 0 0 0 12 9 6 1 0 14 2 14 6 4 2 2 11 7 13 11 3 9 0 2 3 4 2 11 8 7 9 0 0 3 8 3 10 8 2 8 9 4 9 0 11 4 9 8 12 8 5 2 10 10 1 14 7 8 5 5 7 8 1 13 2 13 12 2 5 11 1 12 12 0 2 5 15 2 14 2 3 10 1 0 7 7 11 3 7 6 1 13 8 4 2 7 14 9 9 7 3 8 1 15 6 11 15 0 11 9 7 15 12 10 6 4 5 6 10 4 4 4 15 5 1 8 9 3 12 11 8 4 10 8 3 15 12 3 4 10 8 12 8 14 2 12 12 14 14 5 14 6 10 13 9 6 4 14 9 6 8 4 11 1 6 0 7 7 5 4 12 15 7 4 4 10 7 3 0 11 10 11 1 8 9 0 12 14 6 2 15 2 5 11 8 3 4 2 9 9 7 0 7 11 13 5 7 12 8 6 12 11 15 3 6 11 0 1 2 7 2 13 14 15 4)) (d0 (make-array '(251) :element-type '(integer 0 15) :initial-contents init :adjustable t))) (assert (equalp (remove 7 d0) (coerce (remove 7 init) '(vector (integer 0 15))))))) nil) ;;; Object identity for bit vectors (deftest misc.542 (funcall (compile nil (let ((bv1 (copy-seq #*1)) (bv2 (copy-seq #*1))) `(lambda () (eq ,bv1 ,bv2))))) nil) ;;; Lispworks personal edition 4.3 (x86 linux) ;;; Error: In PLUSP of (#C(1123113 -260528)) arguments should be of type REAL. (deftest misc.543 (funcall (compile nil '(lambda (p1) (declare (optimize speed (safety 1)) ; (type (simple-array t nil) r) (type (integer 2493220 2495515) p1)) (* p1 #c(1123113 -260528)))) 2493726) #C(2800736089038 -649685447328)) ;;; gcl (deftest misc.544 (let ((n -1.0l0)) (notnot-mv (complexp (funcall (compile nil `(lambda (p1) (declare (optimize speed (safety 1)) (type (long-float ,n 0.0l0) p1)) (sqrt p1))) n)))) t) ;;; OpenMCL ;;; 1/2 is not of type integer (deftest misc.545 (let ((x #c(-1 1/2))) (declare (type (eql #c(-1 1/2)) x)) x) #c(-1 1/2)) ;;; SBCL ;;; 0.8.19.39 ;;; The function SB-KERNEL:CHARACTER-STRING-P is undefined. (deftest misc.546 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 0) (safety 1) (debug 2) (space 3)) (type (eql a) p1)) (typep p1 (type-of "")))) 'a) nil) ;;; The function SB-KERNEL:SIMPLE-CHARACTER-STRING-P is undefined. (deftest misc.547 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 3) (safety 3) (debug 0) (space 3)) (type symbol p1)) (typep (the (eql :c1) p1) (type-of "b")))) :c1) nil) ;;; The value NIL is not of type SB-KERNEL:CTYPE. (deftest misc.548 (notnot (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 1) (debug 3) (space 2))) (atom (the (member f assoc-if write-line t w) p1)))) t)) t) ;;; IR2 type checking of unused values in [sic] not implemented. (deftest misc.549 (funcall (compile nil '(lambda (p2) (declare (optimize (speed 1) (safety 1) (debug 0) (space 3)) (type symbol p2)) (and :a (the (eql t) p2)))) t) t) (deftest misc.550 (funcall (compile nil '(lambda (p1 p2) (declare (optimize (speed 3) (safety 2) (debug 3) (space 3)) (type atom p1) (type symbol p2)) (or p1 (the (eql t) p2)))) nil t) t) (deftest misc.551 (funcall (compile nil '(lambda (p1 p2) (declare (optimize (speed 1) (safety 1) (debug 3) (space 3)) (type symbol p1) (type (integer * 55687) p2)) (funcall (the (eql +) p1) (the (integer -93015310 16215) p2) 2952))) '+ 823) 3775) (deftest misc.551a (funcall (compile nil '(lambda (x) (declare (optimize (speed 2)) (type symbol x)) (the (eql t) x))) t) t) ;;; cmucl (mar 2005 snapshot) (deftest misc.552 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 3) (safety 1) (debug 2) (space 2)) (type unsigned-byte p1)) (logbitp (the (integer -780969457 *) p1) 9))) 26) nil) ;;; ecls ;;; REAL is not of type REAL. (deftest misc.553 (funcall (compile nil '(lambda (x) (declare (type (eql #c(1.0 2.0)) x)) x)) #c(1.0 2.0)) #c(1.0 2.0)) ;;; 1 is not of type SEQUENCE (deftest misc.554 (funcall (compile nil '(lambda (x) (declare (type (array t 1) x)) x)) #(a)) #(a)) ;;; sbcl 5 Mar 2005 ;;; failed AVER: "(EQ CHECK SIMPLE)" (deftest misc.555 (notnot (funcall (compile nil '(lambda (p1) (declare (optimize (speed 1) (safety 2) (debug 2) (space 0)) (type keyword p1)) (keywordp p1))) :c)) t) ; Problem with FLOOR ; Wrong return value (deftest misc.556 (values (funcall (compile nil '(lambda (p1 p2) (declare (optimize (speed 1) (safety 0) (debug 0) (space 0)) (type (member 8174.8604) p1) (type (member -95195347) p2)) (floor p1 p2))) 8174.8604 -95195347)) -1) ; invalid number of arguments: 1 ; (possible removal of code due to type fumble) (deftest misc.557 (values (funcall (compile nil '(lambda (p1) (declare (optimize (speed 3) (safety 0) (debug 3) (space 1)) (type (member -94430.086f0) p1)) (floor (the single-float p1) 19311235))) -94430.086f0)) -1) ; FFLOOR ; Wrong return value (deftest misc.558 (values (funcall (compile nil '(lambda (p1) (declare (optimize (speed 1) (safety 2) (debug 2) (space 3)) (type (eql -39466.56f0) p1)) (ffloor p1 305598613))) -39466.56f0)) -1.0f0) ; CEILING ; invalid number of arguments: 1 (deftest misc.559 (values (funcall (compile nil '(lambda (p1) (declare (optimize (speed 1) (safety 1) (debug 1) (space 2)) (type (eql -83232.09f0) p1)) (ceiling p1 -83381228))) -83232.09f0)) 1) ; wrong return value (deftest misc.560 (values (funcall (compile nil '(lambda (p1) (declare (optimize (speed 1) (safety 1) (debug 1) (space 0)) (type (member -66414.414f0) p1)) (ceiling p1 -63019173f0))) -66414.414f0)) 1) ; FCEILING ; wrong return value (deftest misc.561 (values (funcall (compile nil '(lambda (p1) (declare (optimize (speed 0) (safety 1) (debug 0) (space 1)) (type (eql 20851.398f0) p1)) (fceiling p1 80839863))) 20851.398f0)) 1.0f0) ;;; LOG ;;; The value #C(-215549 39/40) is not of type (COMPLEX RATIONAL). (deftest misc.562 (let ((fn '(lambda (p1) (declare (optimize (speed 0) (safety 0) (debug 0) (space 2)) (type (complex rational) p1)) (log p1)))) (notnot (complexp (funcall (compile nil fn) #C(-215549 39/40))))) t) ;;; CONJUGATE ;;; Wrong result (#c(1 2)) (deftest misc.563 (funcall (compile nil '(lambda (x) (declare (optimize (speed 1) (safety 0) (debug 3) (space 1)) (type (complex rational) x)) (conjugate (the (eql #c(1 2)) x)))) #c(1 2)) #c(1 -2)) ;;; PHASE ;;; The function SB-KERNEL:%ATAN2 is undefined. (deftest misc.564 (notnot (typep (funcall (compile nil '(lambda (p1) (declare (optimize (speed 3) (safety 2) (debug 3) (space 0)) (type complex p1)) (phase (the (eql #c(1.0d0 2.0d0)) p1)))) #c(1.0d0 2.0d0)) 'double-float)) t) ;;; ACL 6.2 (trial, x86 linux) ;;; Incorrect return value (t instead of nil) (deftest misc.565 (funcall (compile nil '(lambda (x) (declare (optimize (speed 2) (safety 1) (debug 3) (space 0)) (type double-float x)) (not (the (eql 1.0d0) x)))) 1.0d0) nil) ;;; ASH ;;; Incorrect value (59 == (ash p1 -3)) (deftest misc.566 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 3) (safety 2) (debug 2) (space 0)) (type (integer 465 127871) p1)) (ash p1 -35))) 477) 0) ;;; sbcl ;;; The value -4 is not of type (INTEGER -26794287907 505600792). (deftest misc.567 (eqlt (funcall (compile nil '(lambda (p2) (declare (optimize (speed 3) (safety 1) (debug 0) (space 1)) (type (integer -26794287907 505600792) p2)) (scale-float -15193.341216130497d0 (the (integer * 25) p2)))) -4) (scale-float -15193.341216130497d0 -4)) t) ;;; ACL 7.0 (x86 linux) ;;; Found by random type prop tests ;;; Error: Attempt to divide 13026.059 by zero. (deftest misc.568 (values (funcall (compile nil '(lambda (p2) (declare (optimize (speed 1) (safety 3) (debug 3) (space 1)) (type (rational * 5325/3112) p2)) (floor 13026.059 (the (member 5325/3112 0 -2316/167 -449/460) p2)))) 5325/3112)) 7612) ;;; Error: Attempt to take the car of #2\%b which is not listp. (deftest misc.569 (funcall (compile nil '(lambda (p2) (declare (optimize (speed 3) (safety 2) (debug 1) (space 2)) (type t p2)) (ash -2609443 (the (integer -3 0) p2)))) -1) -1304722) ;;; Incorrect return value (deftest misc.570 (funcall (compile nil '(lambda () (declare (optimize (speed 3) (safety 1))) (char-equal #\: #\: #\;)))) nil) ;;; CODE-CHAR returns incorrect result ;;; (ACL7.0, 8 bit character image) (deftest misc.571 (and (< 1000 char-code-limit) (let ((c1 (code-char 1000)) (c2 (funcall (compile nil '(lambda (x) (declare (optimize speed (safety 1))) (code-char x))) 1000))) (if (not (eql c1 c2)) (list c1 c2) nil))) nil) ;;; sbcl 0.8.20.19 ;;; The value 22 is not of type (MOD 22). (deftest misc.572 (funcall (compile nil '(lambda (p4) (declare (optimize (speed 1) (safety 2) (debug 1) (space 1)) (type (integer -59 65558) p4)) (string<= #.(coerce "1yapt1l7eeenz72u6xqhdfimcyk" 'base-string) #.(coerce "bababababbbabbabbababb" 'base-string) :start2 (the (integer -3735 *) p4)))) 22) nil) ;;; The value 0 is not of type NIL. (deftest misc.573 (funcall (compile nil '(lambda (p4) (declare (optimize (speed 2) (safety 1) (debug 2) (space 2)) (type unsigned-byte p4)) (string<= (coerce "pdhd5oeynvqlthz3xrrdycotf" 'base-string) (coerce "" 'base-string) :start1 (the (integer * 81) p4)))) 10) nil) ;;; incorrect return value (deftest misc.574 (funcall (compile nil '(lambda (p4) (declare (optimize (speed 3) (safety 1) (debug 1) (space 2)) (type (integer * 397079023) p4)) (string<= (coerce "e99mo7yAJ6oU4" 'base-string) (coerce "aaABAAbaa" 'base-string) :start1 (the (member -34 131074 67108872 9 -3305367300 335) p4)))) 9) 9) ;;; In abcl (14 Mar 2005) ;;; The value T is not of type number. (deftest misc.575 (equalp #c(1269346.0 47870.12254712875) t) nil) ;;; The value #C(435422075/240892576 373) is not of type NUMBER. (deftest misc.576 (* -7023900320 #C(435422075/240892576 373)) #C(-95573789122736375/7527893 -2619914819360)) ;;; The value #C(-555014/122849 -6641556271) is not of type NUMBER. (deftest misc.577 (/ -3185994774 #C(-555014/122849 -6641556271)) #C(217230410502882805764/665706755984253572883257634437 -319343563321640207257301634954/665706755984253572883257634437)) ;;; The value "" is not of type (STRING 1). (deftest misc.578 (funcall (compile nil '(lambda (p1) (declare (optimize safety)) (the (string 1) p1))) (make-array '(1) :element-type 'base-char :initial-element #\x :fill-pointer 0)) "") ;;; clisp (11 Jan 2005) ;;; *** - SYSTEM::%RPLACA: NIL is not a pair (deftest misc.579 (funcall (compile nil '(lambda () (declare (optimize (speed 3) (safety 3) (debug 3) (space 0))) (member 61 '(432445) :allow-other-keys t :foo t)))) nil) ;;; sbcl 0.8.20.19 ;;; The component type for COMPLEX is not numeric: (OR RATIO FIXNUM) (deftest misc.580 (notnot-mv (typep #c(1 2) '(complex (or ratio fixnum)))) t) ;;; The value -5067.2056 is not of type (SINGLE-FLOAT -5067.2056 -5067.2056). (deftest misc.581 (notnot (floatp (funcall (compile nil '(lambda (x) (declare (type (eql -5067.2056) x)) (+ 213734822 x))) -5067.2056))) t) (deftest misc.581a (notnot (typep (funcall (compile nil '(lambda (x) (declare (type (eql -1.0) x)) ;;; Note! #x1000001 is the least positive integer ;;; for which this fails on x86 (+ #x1000001 x))) -1.0f0) 'single-float)) t) ;;; Incorrect result (deftest misc.582 (let ((result (funcall (compile nil ' (lambda (p1) (declare (optimize (speed 0) (safety 1) (debug 1) (space 1)) (type (eql -39887.645) p1)) (mod p1 382352925))) -39887.645))) (if (plusp result) t result)) t) ;;; Argument X is not a REAL: # (deftest misc.583 (notnot-mv (complexp (funcall (compile nil '(lambda (p1) (declare (optimize (speed 0) (safety 0) (debug 2) (space 3)) (type (complex rational) p1)) (sqrt p1))) #c(-9003 -121)))) t) ;;; The value -27 is not of type (INTEGER -34359738403 -24). (deftest misc.584 (approx= (funcall (compile nil '(lambda (p1 p2) (declare (optimize (speed 1) (safety 1) (debug 0) (space 1)) (type (member -3712.8447) p1) (type (integer -34359738403 -24) p2)) (scale-float p1 p2))) -3712.8447 -27) (scale-float -3712.8447 -27)) t) ;;; IR2 type checking of unused values in not implemented. ;;; (note that this test has no THE form) (deftest misc.585 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 0) (safety 0) (debug 3) (space 3)) (type symbol p1)) (copy-list p1))) nil) nil) ;;; The value 4 is not of type (UNSIGNED-BYTE 2). (deftest misc.586 (funcall (compile nil '(lambda (p6) (declare (optimize (speed 0) (safety 2) (debug 0) (space 0)) (type (integer -2 3009181) p6)) (string> (coerce "ababaaabb" 'base-string) (coerce "ubbm" 'base-string) :start1 2 :start2 p6 :end1 8))) 4) 2) ;;; sbcl 0.8.20.27 ;;; Control stack exhausted (deftest misc.587 (let ((result (funcall (compile nil '(lambda (p2) (declare (optimize (speed 0) (safety 3) (debug 1) (space 0)) (type (eql 33558541) p2)) (- 92215.266 p2))) 33558541))) (notnot (typep result 'single-float))) t) ;;; Lispworks 4.3 Personal Edition ;;; Incorrect return value (T instead of NIL) (deftest misc.588 (funcall (compile nil '(lambda nil (declare (optimize (speed 2) (safety 1) (debug 1) (space 1))) (functionp 3502843)))) nil) ;;; (ARRAY NIL) is an illegal type specifier. (deftest misc.589 (typep 1 '(array nil)) nil) ;;; Segmentation violation (deftest misc.590 (funcall (compile nil '(lambda nil (declare (optimize debug)) (symbolp -86755)))) nil) ;;; parse-integer fails on displaced base strings (deftest misc.591 (let* ((s1 (coerce "708553218828630100500" 'base-string)) (s2 (make-array '(13) :element-type 'base-char :displaced-to s1 :displaced-index-offset 5))) (parse-integer s2)) 3218828630100 13) ;;; abcl, 19 Mar 2005 ;;; Stack overflow (deftest misc.592 (equalp #*0 "0") nil) ;;; clisp 21 Mar 2005 (-ansi -q, x86 Linux, gcc 3.2.2) ;;; *** - Compiler bug!! Occurred in SP-DEPTH at <0. (deftest misc.593 (funcall (compile nil '(lambda (a b) (declare (ignorable a b)) (declare (optimize (space 3) (debug 0) (safety 1) (compilation-speed 3) (speed 1))) (prog2 (catch 'ct1 (if (or (and t (not (and (and (or a t) nil) nil))) nil) a (reduce #'(lambda (lmv5 lmv2) 0) (vector b 0 a)))) 0))) 2212755 3154856) 0) ;;; OpenMCL 0.14.3 ;;; 28192897: value doesn't match constraint :U8CONST in template for CCL::MATCH-VREG (deftest misc.594 (funcall (compile nil '(lambda (a b c) (declare (ignorable a b c)) (declare (type (integer -1 0) a) (type (integer -1065019672 -181184465) b) (type (integer 30074 1948824693) c)) (declare (optimize (safety 2) (compilation-speed 1) (speed 2) (space 0) (debug 0))) (ash c (min 82 -28192897)))) 0 -714979492 1474663829) 0) ;;; ecl ;;; 10000000.0d0 is not of type INTEGER. (deftest misc.595 (floor 1/2 1.0d0) 0 #.(float 1/2 1.0d0)) ;;; sbcl 0.8.21.45 (x86) ;;; The function SB-KERNEL:VECTOR-NIL-P is undefined. (deftest misc.596 (notnot (let ((s (coerce "a" 'base-string))) (funcall (compile nil `(lambda () (declare (optimize (speed 0) (safety 3) (debug 2) (space 1))) (typep ,s '(string 1))))))) t) ;;; OpenMCL ;;; Incorrect value (deftest misc.597 (funcall (compile nil '(lambda (c) (declare (optimize (speed 1) (compilation-speed 2) (space 1) (debug 1) (safety 2))) (declare (type (integer 1 41) c)) (logxor -1 c))) 8) -9) ;;; SBCL 0.9.1.19 ;;; Failure of IMAGPART in compiled code (deftest misc.598 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 0) (debug 3) (space 1)) (type short-float p1)) (imagpart (the short-float p1)))) -79916.61s0) -0.0s0) ;;; The value 20408096470 is not of type (INTEGER 19856842407 20640917103) (deftest misc.599 (funcall (compile nil '(lambda (b) (declare (type (integer 19856842407 20640917103) b)) (declare (optimize (debug 1) (speed 3) (compilation-speed 2) (safety 3) (space 3))) (lognand b (deposit-field b (byte 0 0) 3762528061)))) 20408096470) -3225589269) ;;; SBCL 0.9.1.21 ;;; The function SB-C::SPECIFER-TYPE is undefined. (deftest misc.600 (funcall (compile nil '(lambda () (declare (notinline min ash)) (declare (optimize (speed 0) (debug 1) (safety 1) (space 1) (compilation-speed 3))) (logxor (ash 0 (min 90 0)) 0)))) 0) (deftest misc.601 (funcall (compile nil '(lambda () (declare (notinline gcd)) (declare (optimize (debug 3) (space 3) (safety 3) (compilation-speed 2) (speed 3))) (logeqv 0 (gcd 0))))) -1) ;;; Lispworks 4450 ;;; Show sporadic bugs in compiled code (deftest misc.602 (let ((form '(lambda () (if (oddp (progn (vector) 3747237)) 'a nil)))) (loop repeat 10 collect (funcall (compile nil form)))) (a a a a a a a a a a)) ;;; gcl 2.7.0 (12 Jul 2005) ;;; Error in WHEN [or a callee]: The GO tag #:G3614 is missing. (deftest misc.603 (funcall (compile nil '(lambda () (let ((x (values 0))) 0)))) 0) ;;; gcl 2.7.0 (23 Jul 2005, experimental cvs HEAD) ;;; Error in COMPILER::T1EXPR [or a callee]: ;;; LOAD-TIME-VALUE is not of type (OR RATIONAL FLOAT). (deftest misc.604 (let ((form '(lambda (p1 p2) (declare (optimize (speed 2) (safety 1) (debug 3) (space 3)) (type real p1) (type t p2)) (eql (the (rational -55253767/37931089) p1) (the atom p2))))) (funcall (compile nil form) -55253767/37931089 'a)) nil) ;;; Error in FUNCALL [or a callee]: LOAD-TIME-VALUE is not of type NUMBER. (deftest misc.605 (let ((form '(lambda (p1 p2) (declare (optimize (speed 3) (safety 1) (debug 0) (space 0)) (type number p1) (type (float 0.0 3579.314s0) p2)) (eql (the real p1) p2)))) (not (funcall (compile nil form) 3579.314s0 3579.314s0))) nil) ;;; Error in COMPILER::CMP-ANON [or a callee]: #\a is not of type FIXNUM. (deftest misc.606 (let ((form '(lambda () (declare (optimize (speed 3) (safety 2) (debug 3) (space 2))) (equal #\a #c(-1775806.0s0 88367.29s0))))) (funcall (compile nil form))) nil) ;;; Error in COMPILER::CMP-ANON [or a callee]: #*1 is not of type FIXNUM. (deftest misc.607 (funcall (compile nil '(lambda () (declare (optimize (speed 0) (safety 2) (debug 2) (space 2))) (equal #*1 1)))) nil) ;;; Error in COMPILER::CMP-ANON [or a callee]: #\& is not of type FIXNUM. (deftest misc.608 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 3) (safety 2) (debug 3) (space 3)) (type (integer -62603278 -31187) p1)) (equal p1 #\&))) -31228) nil) ;;; Wrong return value (was returning T) (deftest misc.609 (funcall (compile nil '(lambda () (declare (optimize (speed 0) (safety 0) (debug 0) (space 3))) (equalp "b" #*)))) nil) ;;; Error in COMPILER::CMP-ANON [or a callee]: 7933992 is not of type SYMBOL. (deftest misc.610 (not (funcall (compile nil '(lambda (p2) (declare (optimize (speed 1) (safety 1) (debug 3) (space 2)) (type (cons symbol) p2)) (typep -32 p2))) '(eql -32))) nil) ;;; Error in CAR [or a callee]: -757161859 is not of type LIST. (deftest misc.611 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 1) (safety 3) (debug 0) (space 2)) (type (cons atom) p1)) (car p1))) '(48144509 . a)) 48144509) ;;; gcl (09 Aug 2005) ;;; Error in COMPILER::POSSIBLE-EQ-LIST-SEARCH [or a callee]: COMPILER::POSSIBLE-EQ-LIST-SEARCH does not allow the keyword :B. (deftest misc.612 (funcall (compile nil '(lambda (p1 p2) ((lambda (x y) (typep x (type-of y))) p1 (the (member "foo" #\- :b "bar") p2)))) #*1 :b) nil) ;;; Error in APPLY [or a callee]: The tag CT1 is undefined. (deftest misc.613 (funcall (compile nil '(lambda (a) (declare (optimize (space 3) (safety 1) (debug 3) (speed 1) (compilation-speed 3))) (catch 'ct1 (reduce #'(lambda (lmv6 lmv5) (throw 'ct1 0)) (list a 0 0) :end 2)))) 1) 0) ;;; Error in MULTIPLE-VALUE-BIND [or a callee]: Cannot get relocated section contents (deftest misc.614 (funcall (compile nil '(lambda (a) (declare (type (integer -3873004182 -3717314779) a)) (declare (ignorable a)) (declare (optimize (debug 0) (safety 1) (speed 3) (space 0) (compilation-speed 0))) (let* ((v1 (make-array nil :initial-element (reduce #'logand (list a 0 a))))) (declare (dynamic-extent v1)) 0))) -3755148485) 0) ;;; gcl type-prop test failures (10/30/2005) (deftest misc.615 (let* ((x -8183.7625s0) (form `(lambda (p1) (eql p1 ,x)))) (not (not (funcall (compile nil form) x)))) t) ;;; cmucl 19c ;;; Wrong return value (deftest misc.616 (funcall (compile nil '(lambda (a b c) (declare (type (integer -153105 -36629) a)) (declare (type (integer -7811721705 3704985368) b)) (declare (type (integer 0 15) c)) (declare (ignorable a b c)) (declare (optimize (safety 1) (space 0) (compilation-speed 0) (speed 3) (debug 3))) (catch 'ct7 (labels ((%f12 (f12-1 f12-2 &optional &key (key1 0) (key2 (reduce #'(lambda (lmv2 lmv1) 0) (vector 0 0) :end 2 :start 0 :from-end t)) &allow-other-keys) a)) c)))) -134217 -3699719058 10) 10) ;;; sbcl 0.9.7.33 (x86) ;;; The value 16561216769 is not of type (INTEGER -2147483648 4294967295). ;;; On sparc solaris, the error message is: ;;; debugger invoked on a SB-KERNEL:CASE-FAILURE: ;;; 16561216769 fell through ETYPECASE expression. ;;; Wanted one of (SB-C:FIXUP (OR (SIGNED-BYTE 32) (UNSIGNED-BYTE 32)) ;;; (SIGNED-BYTE 13)). (deftest misc.617 (funcall (compile nil '(lambda (b) (declare (optimize (space 3) (safety 2) (debug 1) (speed 3) (compilation-speed 2))) (let* ((v2 16561216769)) (lognand (loop for lv3 below 0 sum (setf v2 lv3)) (if (typep v2 '(integer -39 7)) b 0))))) -10298) -1) ;;; failed AVER: "(EQ POP (CAR END-STACK))" ;;; (same on sparc solaris) (deftest misc.618 (funcall (compile nil '(lambda (c) (declare (optimize (space 0) (compilation-speed 2) (debug 0) (speed 3) (safety 0))) (block b1 (ignore-errors (multiple-value-prog1 0 (apply (constantly 0) c (catch 'ct2 (return-from b1 0)) nil)))))) -4951) 0) ;;; sbcl 0.9.7.33 (sparc solaris) ;;; Incorrect return value (deftest misc.619 (funcall (compile nil '(lambda (b) (declare (type (integer 75 206) b)) (declare (optimize (speed 0) (compilation-speed 2) (debug 2) (space 2) (safety 2))) (mask-field (byte 4 28) (ash b 70)))) 79) 0) ;;; The value 64 is not of type (OR SB-C:TN (UNSIGNED-BYTE 6) NULL). (deftest misc.620 (funcall (compile nil '(lambda () (declare (optimize (safety 3) (compilation-speed 3) (debug 1) (space 3) (speed 1))) (loop for lv2 below 1 sum (ash lv2 64))))) 0) ;;; sbcl 0.9.8.17, x86 linux ;;; The value 32 is not of type (OR (INTEGER -67 -67) (INTEGER -63 -63)). (deftest misc.621 (funcall (compile nil '(lambda () (declare (optimize (debug 1) (space 0) (compilation-speed 3) (speed 1) (safety 3))) (loop for lv1 below 2 sum (dotimes (iv2 2 0) (mod (dotimes (iv4 2 0) (progn (count lv1 #*0) 0)) (min -63 (rem 0 (min -67 0))))))))) 0) ;;; sbcl 0.9.9.8, x86 linux ;;; TYPE-ERROR: The value 17549.955 is not of type REAL. (deftest misc.622 (funcall (compile nil '(lambda (p2) (declare (optimize (speed 3) (safety 2) (debug 3) (space 0)) (type real p2)) (+ 81535869 (the (member 17549.955 #:g35917) p2)))) 17549.955) #.(+ 81535869 17549.955)) ;;; sbcl 0.9.9.19 ;;; The function SB-VM::%LOGBITP is undefined. (deftest misc.623 (funcall (compile nil '(lambda () (declare (optimize (space 2) (speed 0) (debug 2) (compilation-speed 3) (safety 0))) (loop for lv3 below 1 count (minusp (loop for lv2 below 2 count (logbitp 0 (bit #*1001101001001 (min 12 (max 0 lv3)))))))))) 0) ;;; failed AVER: "(< Y 29)" (deftest misc.624 (funcall (compile nil '(lambda (a) (declare (type (integer 21 28) a)) (declare (optimize (compilation-speed 1) (safety 2) (speed 0) (debug 0) (space 1))) (let* ((v7 (flet ((%f3 (f3-1 f3-2) (loop for lv2 below 1 count (logbitp 29 (sbit #*10101111 (min 7 (max 0 (eval '0)))))))) (%f3 0 a)))) 0))) 22) 0) ;;; sbcl 0.9.9.22 (x86 linux) ;;; The following two errors appear to require the presence ;;; of two ELT forms. Somehow, the type check for one is ;;; misplaced into the other. ;;; TYPE-ERROR: The value 0 is not of type (INTEGER 3 3). (deftest misc.625 (funcall (compile nil '(lambda (a) (declare (type (integer -2 -1) a)) (declare (optimize (speed 0) (space 0) (safety 1) #+sbcl (sb-c:insert-step-conditions 0) (debug 3) (compilation-speed 1))) (elt '(47119 39679 57498 35248 23784 40597 53473 29454) (min 7 (max 0 (flet ((%f7 (f7-1 f7-2 &optional &key (key1 (elt '(0 25 30 12 27 5) (min 5 (max 0 3))))) 0)) (flet ((%f6 (&optional &key (key1 (progn (%f7 0 a) a)) (key2 0)) 0)) (%f7 a a)))))))) -2) 47119) ;;; TYPE-ERROR: The value 2 is not of type (INTEGER 12 12) (deftest misc.625a (funcall (compile nil '(lambda (a b) (declare (type (integer 1 5) b)) (declare (optimize (safety 2) (speed 2) (space 0) (compilation-speed 3) (debug 3))) (progn (flet ((%f3 (f3-1 f3-2 &optional (f3-3 b) f3-4 (f3-5 (prog1 0 (elt '(a b c d e f g h i j k l m) 12)))) f3-1)) (%f3 0 (%f3 0 a 0 a) a 0 a)) (elt '(a b c d) (min 3 b)) ))) 0 2) c) ;;; failed AVER: "(<= Y 29)" (deftest misc.626 (funcall (compile nil '(lambda (a) (declare (type (integer -902970 2) a)) (declare (optimize (space 2) (debug 0) (compilation-speed 1) (speed 0) (safety 3))) (prog2 (if (logbitp 30 a) 0 (block b3 0)) a))) -829253) -829253) ;;; The value -93368855 is not of type UNSIGNED-BYTE. ;;; [...] ;;; (LOGBITP -93368855 0) (deftest misc.628 (funcall (compile nil '(lambda () (declare (optimize (safety 3) (space 3) (compilation-speed 3) (speed 0) (debug 1))) (not (not (logbitp 0 (floor 2147483651 (min -23 0)))))))) t) ;;; sbcl 0.9.9.35 ;;; The value #S(MISC-629 :A 1 :B 3) is not of type SB-KERNEL:INSTANCE. (defstruct misc-629 a b) (deftest misc.629 (let* ((s (make-misc-629 :a 1 :b 3)) (form `(lambda (x) (declare (optimize (speed 1) (safety 3) (debug 0) (space 2)) (type (member 0 2 ,s) x)) (misc-629-a x)))) (funcall (compile nil form) s)) 1) ;;; sbcl 0.9.10.11 ;;; Failures associated with MULTIPLE-VALUE-PROG1 ;;; Argument X is not a NUMBER: NIL ;;; (SB-KERNEL:TWO-ARG-/ NIL 1) (deftest misc.630 (funcall (compile nil '(lambda () (declare (optimize (speed 1) (debug 0) (space 2) (safety 0) (compilation-speed 0))) (unwind-protect 0 (* (/ (multiple-value-prog1 -29457482 -5602513511) 1)))))) 0) ;;; Argument X is not a INTEGER: NIL ;;; (SB-KERNEL:TWO-ARG-AND NIL 1) (deftest misc.631 (if (flet ((%f17 (&key (key2 (if (evenp (multiple-value-prog1 0)) 0 0))) 0)) 0) :a :b) :a) ;;; gcl 2.7.0 (7 Mar 2006) ;;; Wrong value -- NIL (deftest misc.632 (funcall (compile nil '(lambda () (let (b) (multiple-value-setq (b) 10))))) 10) ;;; sbcl (x86 linux) 0.9.10.43 ;;; The value -17045.0 ;;; is not of type ;;; (OR (MEMBER #:|u4m7k0jz6o| 1+) ;;; (MEMBER #\b) ;;; (SINGLE-FLOAT -17045.0 -17045.0)). (deftest misc.633 (let* ((x -17045.0) (form `(lambda (p3 p4) (declare (optimize (speed 1) (safety 3) (debug 0) (space 1)) (type number p3) (type (member -1451.1257 47889 #:|3| ,x #:|aabbaaaaaababa|) p4)) (min 1 -251.2455 (the number p3) (the (member 1+ ,x #\b #:|u4m7k0jz6o|) p4) -1506/1283 65681158/19740963)))) (funcall (compile nil form) 1861 x)) -17045.0) ;;; sbcl (x86 linux) 0.9.10.48 ;;; The value 35182846 is not of type (INTEGER 35182846 35182846). (deftest misc.634 (let ((form '(lambda (p2) (declare (optimize (speed 0) (safety 3) (debug 3) (space 2)) (type number p2)) (- -83659.0 (the (member 35182846) p2))))) (funcall (compile nil form) 35182846)) #.(- -83659.0 35182846)) ;;; sbcl (x86 linux) 0.9.11.4 ;;; Different results (deftest misc.635 (let* ((form '(lambda (p2) (declare (optimize (speed 0) (safety 1) (debug 2) (space 2)) (type (member -19261719) p2)) (ceiling -46022.094 p2)))) (values (funcall (compile nil form) -19261719))) 1) ;;; TYPE-ERROR: The value 26899.875 is not of type NUMBER. (deftest misc.636 (let* ((x 26899.875) (form `(lambda (p2) (declare (optimize (speed 3) (safety 1) (debug 3) (space 1)) (type (member ,x #:g5437 char-code #:g5438) p2)) (* 104102267 p2)))) (not (not (floatp (funcall (compile nil form) x))))) t) ;;; attempt to THROW to a tag that does not exist: SB-C::LOCALL-ALREADY-LET-CONVERTED (deftest misc.637 (labels ((%f11 (f11-2 &key key1) (labels ((%f8 (f8-2 &optional (f8-5 (if nil (return-from %f11 0) 0))) :bad1)) (%f8 (%f8 0))) :bad2)) :good) :good) ;;; full call to SB-KERNEL:DATA-VECTOR-REF (deftest misc.638 (let* ((codes '(32779 60674 33150 60033 41146 23916 28908 58886 12776 21282 37346 25537 56184 40736 4845 41954 6663 44378 23466 46903 13661 36445 18784 6114 6266)) (chars (loop for code in codes collect (or (code-char code) #\x))) (c (elt chars 21)) (s (make-array '(25) :element-type 'character :initial-contents chars))) (let ((form `(lambda (p1) (declare (optimize (speed 2) (safety 0) (debug 3) (space 1)) (type (simple-string 25) p1)) (char (the (member ,(let ((s2 "abbbabbaaabbaba")) (make-array (length s2) :element-type 'base-char :initial-contents s2)) ,s) p1) 21)))) (not (not (eql c (funcall (compile nil form) s)))))) t) ;;; sbcl 0.9.11.24 (x86 linux) ;;; failed AVER: "(EQ PHYSENV (LAMBDA-PHYSENV (LAMBDA-VAR-HOME THING)))" (deftest misc.639 (let ((form '(lambda (a b d) (declare (notinline >= eql)) (declare (optimize (debug 2) (speed 3) (safety 0) (compilation-speed 3) (space 0))) (labels ((%f8 (f8-1 &optional (f8-4 (if (if (eql 0 -16) (>= d) nil) 0 0))) a)) (%f8 b))))) (funcall (compile nil form) :good 18 0)) :good) ;;; sbcl 0.9.11.45 (x86 linux) ;;; Incorrect value: -32377322164 (deftest misc.640 (let ((form '(lambda (b g) (declare (type (integer 303184 791836) b)) (declare (optimize (compilation-speed 2) (debug 0) (space 1) (speed 1) (safety 2))) (loop for lv1 below 2 sum (if (<= g lv1) (labels ((%f7 () (prog1 b 0))) (%f7)) (setf g -16188661082)))))) (funcall (compile nil form) 335562 4655131896)) -16188325520) ;;; sbcl 0.9.12.27 (x86 linux) ;;; The value NIL is not of type SB-C::IR2-NLX-INFO. (deftest misc.641 (let ((form '(lambda () (declare (optimize (speed 1) (space 0) (debug 2) (compilation-speed 0) (safety 1))) (flet ((%f3 (f3-1 &key (key1 (count (floor 0 (min -74 0)) #()))) 0)) (apply #'%f3 0 nil))))) (funcall (compile nil form))) 0) ;;; cmucl 19c (x86 linux) ;;; The assertion (NOT (MEMBER C::KIND '(:DELETED :OPTIONAL))) failed. (deftest misc.642 (let ((form ' (lambda (a b c d e f g h i j) (declare (type (integer 174130 60165950) a)) (declare (type (integer -4076 6783) b)) (declare (type (integer -178481569 -1) c)) (declare (type (integer 236 954963169) d)) (declare (type (integer -1334 407047) e)) (declare (type (integer -507 -426) f)) (declare (type (integer -1164301 148213922) g)) (declare (type (integer -184324 14515) h)) (declare (type (integer 258 323) i)) (declare (type (integer -11825 109247) j)) (declare (ignorable a b c d e f g h i j)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (compilation-speed 2) (debug 0) (space 1) (speed 3) (safety 2))) (labels ((%f4 (f4-1) (flet ((%f2 (f2-1 f2-2 f2-3 &key) (progn (return-from %f4 0) f2-2))) (common-lisp:handler-bind nil (/ (coerce (unwind-protect (reduce #'(lambda (lmv2 lmv4) (reduce #'* (vector (let () h) c (reduce #'(lambda (lmv4 lmv3) (return-from %f4 (deposit-field lmv4 (byte 23 16) (mask-field (byte 3 27) (elt '(5309746) (min 0 (max 0 j))))))) (vector (%f2 (%f2 12762 f4-1 6646240924) 1501 -15) 277 (multiple-value-call #'%f2 (values -1486981 i (%f2 a 16777222 j))) 1033) :end 4 :start 3) (/ 823 -1)) :end 3 :start 1)) (vector (common-lisp:handler-bind nil (- 0 h j b -2539837 28596 d 8161548 h -61)) -183768642 -1 31404552 81593) :start 3) (dpb i (byte 14 16) e) (dpb (count f4-1 #(524279 8388596 1021351 101986) :test '/=) (byte 4 4) 131064) (if (= 524287 f) (prog2 (denominator (elt '(1663 120) (min 1 (max 0 -17745)))) f (deposit-field e (byte 31 31) 0) (labels ((%f7 (f7-1 f7-2 f7-3 &optional (f7-4 (coerce (coerce (the integer (+ -11045 114)) 'integer) 'integer)) (f7-5 h)) -2286515)) j)) (macrolet () (prog2 -2195 1921675 h -183085 a)))) 'integer) 1))))) 0)))) (funcall (compile nil form) 58162926 -3652 -63561386 935157597 63716 -504 108893677 -146677 308 99009)) 0) ;;; Wrong return value (deftest misc.643 (let ((form '(lambda (a) (declare (type (integer 6 1273) a)) (declare (optimize (space 0) (safety 0) (debug 3) (compilation-speed 2) (speed 3))) (logorc2 0 (restart-bind nil (shiftf a 522)))))) (funcall (compile nil form) 807)) -808) ;;; -1520586839 is not of type INTEGER (deftest misc.644 (let ((form '(lambda (a) (declare (type (integer -6568333536 -12667) a)) (declare (ignorable a)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (compilation-speed 1) (safety 3) (speed 1) (debug 1) (space 3))) (unwind-protect 0 (the integer (locally (declare (special *s3* *s4*)) (progv '(*s4* *s3*) (list a a) (expt *s3* 0)))))))) (let ((*s3* 0)) (declare (special *s3*)) (funcall (compile nil form) -1520586839))) 0) ;;; NIL is not of type C::CBLOCK (deftest misc.645 (let ((form '(lambda (a) (declare (notinline abs isqrt)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (debug 3) (safety 1) (space 2) (compilation-speed 1) (speed 0))) (progn (tagbody (prog2 a 0 (labels ((%f9 (&key &allow-other-keys) (go 3))) (%f9))) (isqrt (abs (unwind-protect 0))) 3) a)))) (eval `(,form 0))) 0) ;;; Segmentation violation (deftest misc.646 (let ((form '(lambda (a) (declare (type (integer -125 -44) a)) (declare (ignorable a)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (speed 0) (debug 0) (space 2) (compilation-speed 3) (safety 3))) (mask-field (byte 0 0) (block b3 (isqrt (abs (catch 'ct2 (return-from b3 0))))))))) (funcall (compile nil form) -50)) 0) ;;; 1928431123 is not of type (MOD 536870911) (deftest misc.647 (let ((form '(lambda (a) (declare (type (integer -2494 534) a)) (declare (ignorable a)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (speed 0) (space 0) (compilation-speed 3) (safety 1) (debug 1))) (dotimes (iv3 1 0) (block b1 (loop for lv1 below 1 count (logbitp 0 (reduce #'(lambda (lmv6 lmv2) (if (> 2208446653 lmv6) (return-from b1 lmv2) lv1)) (list 0 0 0 1928431123 iv3 iv3 a a) :end 5 :from-end t)))))))) (funcall (compile nil form) 1)) 0) ;;; The assertion (AND C::SUCC (NULL (CDR C::SUCC))) failed. (deftest misc.648 (let ((form '(lambda (a) (declare (type (integer -8 11754838336) a)) (declare (ignorable a)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (space 0) (compilation-speed 0) (speed 3) (debug 3) (safety 0))) (labels ((%f13 () (logorc1 (unwind-protect 0) (prog1 0 (prog2 (max 0 a) 0 (progn (return-from %f13 a) a)))))) 0)))) (funcall (compile nil form) 2582756596)) 0) ;;; sbcl 0.9.13.8 (x86 linux) ;;; VALUES type illegal in this context: * (deftest misc.649 (let ((form '(lambda (p2) (declare (optimize (speed 0) (safety 0) (debug 2) (space 2)) (type (member integer *) p2)) (coerce 523242 p2)))) (funcall (compile nil form) 'integer)) 523242) ;;; The symbol AND is not valid as a type specifier (deftest misc.650 (let ((form '(lambda (p2) (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) (type (member integer and) p2)) (coerce -12 p2)))) (funcall (compile nil form) 'integer)) -12) ;;; The symbol OR is not valid as a type specifier (deftest misc.651 (let ((form '(lambda (p2) (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) (type (member integer or) p2)) (coerce 1 p2)))) (funcall (compile nil form) 'integer)) 1) ;;; The symbol NOT is not valid as a type specifier. (deftest misc.652 (let ((form '(lambda (p2) (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) (type (member integer not) p2)) (coerce 2 p2)))) (funcall (compile nil form) 'integer)) 2) ;;; The symbol SATISFIES is not valid as a type specifier. (deftest misc.653 (let ((form '(lambda (p2) (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) (type (member integer satisfies) p2)) (coerce 2 p2)))) (funcall (compile nil form) 'integer)) 2) ;;; error while parsing arguments to DEFTYPE EQL: ;;; invalid number of elements in ;;; () ;;; to satisfy lambda list ;;; (SB-KERNEL::N): ;;; exactly 1 expected, but 0 found (deftest misc.654 (let ((form '(lambda (p2) (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) (type (member integer eql) p2)) (coerce 2 p2)))) (funcall (compile nil form) 'integer)) 2) ;;; The symbol MEMBER is not valid as a type specifier. (deftest misc.655 (let ((form '(lambda (p2) (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) (type (member integer member) p2)) (coerce 2 p2)))) (funcall (compile nil form) 'integer)) 2) ;;; error while parsing arguments to DEFTYPE MOD: ;;; invalid number of elements in ;;; () ;;; to satisfy lambda list ;;; (SB-KERNEL::N): ;;; exactly 1 expected, but 0 found (deftest misc.656 (let ((form '(lambda (p2) (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) (type (member integer mod) p2)) (coerce 2 p2)))) (funcall (compile nil form) 'integer)) 2) ;;; The symbol VALUES is not valid as a type specifier. (deftest misc.657 (let ((form '(lambda (p2) (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) (type (member integer values) p2)) (coerce 2 p2)))) (funcall (compile nil form) 'integer)) 2) gcl27-2.7.0/ansi-tests/mismatch.lsp000066400000000000000000000424471454061450500170740ustar00rootroot00000000000000;-*- 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)) (deftest mistmatch-string.25 (let ((s0 "12345") (s1 "123A") (s2 "245")) (do-special-strings (s s0 nil) (assert (null (mismatch s s0))) (assert (null (mismatch s0 s))) (assert (null (mismatch s s0 :from-end t))) (assert (null (mismatch s0 s :from-end t))) (assert (eql (mismatch s s1) 3)) (assert (eql (mismatch s1 s) 3)) )) nil) ;;; test and test-not tests (defharmless mismatch.test-and-test-not.1 (mismatch '(1 2 3) '(1 2 4) :test #'eql :test-not #'eql)) (defharmless mismatch.test-and-test-not.2 (mismatch '(1 2 3) '(1 2 4) :test-not #'eql :test #'eql)) (defharmless mismatch.test-and-test-not.3 (mismatch #(1 2 3) #(1 2 4) :test #'eql :test-not #'eql)) (defharmless mismatch.test-and-test-not.4 (mismatch #(1 2 3) #(1 2 4) :test-not #'eql :test #'eql)) (defharmless mismatch.test-and-test-not.5 (mismatch "abc" "abd" :test #'eql :test-not #'eql)) (defharmless mismatch.test-and-test-not.6 (mismatch "abc" "abd" :test-not #'eql :test #'eql)) (defharmless mismatch.test-and-test-not.7 (mismatch #*011 #*010 :test #'eql :test-not #'eql)) (defharmless mismatch.test-and-test-not.8 (mismatch #*011 #*010 :test-not #'eql :test #'eql)) ;;; 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 (signals-error (mismatch) program-error) t) (deftest mismatch.error.2 (signals-error (mismatch nil) program-error) t) (deftest mismatch.error.3 (signals-error (mismatch nil nil :bad t) program-error) t) (deftest mismatch.error.4 (signals-error (mismatch nil nil :bad t :allow-other-keys nil) program-error) t) (deftest mismatch.error.5 (signals-error (mismatch nil nil :key) program-error) t) (deftest mismatch.error.6 (signals-error (mismatch nil nil 1 2) program-error) t) (deftest mismatch.error.7 (signals-error (mismatch '(a b) '(a b) :test #'identity) program-error) t) (deftest mismatch.error.8 (signals-error (mismatch '(a b) '(a b) :test-not #'identity) program-error) t) (deftest mismatch.error.9 (signals-error (mismatch '(a b) '(a b) :key #'car) type-error) t) (deftest mismatch.error.10 (signals-error (mismatch '(a b) '(a b) :key #'cons) program-error) t) gcl27-2.7.0/ansi-tests/modules.lsp000066400000000000000000000037641454061450500167360ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 30 19:51:06 2005 ;;;; Contains: Tests of *MODULES*, PROVIDE, and REQUIRE (in-package :cl-test) (deftest modules.1 (notnot (every #'stringp *modules*)) t) (deftest modules.2 (let ((*modules* *modules*)) (provide "FOO") (notnot (member "FOO" *modules* :test #'string=))) t) (deftest modules.3 (let ((*modules* *modules*)) (provide "FOO") (provide "FOO") (count "FOO" *modules* :test #'string=)) 1) (deftest modules.4 (let ((*modules* *modules*)) (provide "FOO") (require "FOO") (values))) (deftest modules.5 (let ((*modules* *modules*)) (provide :|FOO|) (notnot (member "FOO" *modules* :test #'string=))) t) (deftest modules.6 (let ((*modules* *modules*)) (provide "FOO") (require :|FOO|) (values))) (deftest modules.7 (let ((*modules* *modules*) (fn 'modules7-fun)) (when (fboundp fn) (fmakunbound fn)) (require "MODULES-7" #p"modules7.lsp") (funcall fn)) :good) (deftest modules.8 (let ((*modules* *modules*) (fns '(modules8a-fun modules8b-fun))) (dolist (fn fns) (when (fboundp fn) (fmakunbound fn))) (require "MODULES-8" '(#p"modules8a.lsp" #p"modules8b.lsp")) (mapcar #'funcall fns)) (:good :also-good)) (deftest modules.9 (signals-error (require "AB7djaCgaaL") error) t) (deftest modules.10 (do-special-strings (s "FOO") (let ((*modules* *modules*)) (provide s) (assert (member "FOO" *modules* :test #'string=)))) nil) (deftest modules.11 (do-special-strings (s "FOO") (let ((*modules* *modules*)) (provide "FOO") (require s) (values))) nil) (deftest modules.12 (unless (member "Z" *modules* :test #'string=) (let ((*modules* *modules*)) (provide #\Z) (not (member "Z" *modules* :test #'string=)))) nil) (deftest modules.13 (unless (member "Z" *modules* :test #'string=) (let ((*modules* *modules*)) (provide "Z") (require #\Z) nil)) nil)gcl27-2.7.0/ansi-tests/modules7.lsp000066400000000000000000000000641454061450500170130ustar00rootroot00000000000000(in-package :cl-test) (defun modules7-fun () :good) gcl27-2.7.0/ansi-tests/modules8a.lsp000066400000000000000000000000651454061450500171560ustar00rootroot00000000000000(in-package :cl-test) (defun modules8a-fun () :good) gcl27-2.7.0/ansi-tests/modules8b.lsp000066400000000000000000000000721454061450500171550ustar00rootroot00000000000000(in-package :cl-test) (defun modules8b-fun () :also-good) gcl27-2.7.0/ansi-tests/muffle-warning.lsp000066400000000000000000000023671454061450500202050ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 23 08:46:05 2003 ;;;; Contains: Tests of the MUFFLE-WARNING restart and function (in-package :cl-test) (deftest muffle-warning.1 (restart-case (progn (muffle-warning) 'bad) (muffle-warning () 'good)) good) (deftest muffle-warning.2 (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 (list (first (compute-restarts))) (muffle-warning c2)) (muffle-warning () 'bad) (muffle-warning () 'good))) good) (deftest muffle-warning.3 (restart-case (progn (muffle-warning nil) 'bad) (muffle-warning () 'good)) good) (deftest muffle-warning.4 (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 (list (first (compute-restarts))) (muffle-warning nil)) (muffle-warning () 'good) (muffle-warning () 'bad))) good) (deftest muffle-warning.5 (signals-error (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (with-condition-restarts c1 (compute-restarts) ;; All conditions are now associated with c1 (muffle-warning c2))) control-error) t) gcl27-2.7.0/ansi-tests/multiple-value-bind.lsp000066400000000000000000000051051454061450500211340ustar00rootroot00000000000000;-*- 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) ;;; No implicit tagbody (deftest multiple-value-bind.8 (block nil (tagbody (multiple-value-bind (x) nil (go 10) 10 (return 'bad)) 10 (return 'good))) good) ;;; Works with single values (deftest multiple-value-bind.9 (multiple-value-bind (x y z) :foo (list x y z)) (:foo nil nil)) (deftest multiple-value-bind.10 (multiple-value-bind (x) :foo x) :foo) (deftest multiple-value-bind.11 (multiple-value-bind () :foo) nil) (deftest multiple-value-bind.12 (multiple-value-bind () (values)) nil) (deftest multiple-value-bind.13 (multiple-value-bind () (values 1 2 3 4 5)) nil) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest multiple-value-bind.14 (macrolet ((%m (z) z)) (multiple-value-bind (x y z) (expand-in-current-env (%m (values 1 2 3))) (list x y z))) (1 2 3)) ;;; Error cases (deftest multiple-value-bind.error.1 (signals-error (funcall (macro-function 'multiple-value-bind)) program-error) t) (deftest multiple-value-bind.error.2 (signals-error (funcall (macro-function 'multiple-value-bind) '(multiple-value-bind nil nil)) program-error) t) (deftest multiple-value-bind.error.3 (signals-error (funcall (macro-function 'multiple-value-bind) '(multiple-value-bind nil nil) nil nil) program-error) t) gcl27-2.7.0/ansi-tests/multiple-value-call.lsp000066400000000000000000000014151454061450500211330ustar00rootroot00000000000000;-*- 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)) ;;; Macros are expanded in the appropriate environment (deftest multiple-value-call.4 (macrolet ((%m (z) z)) (multiple-value-call (expand-in-current-env (%m #'list)) (values 1 2))) (1 2)) (deftest multiple-value-call.5 (macrolet ((%m (z) z)) (multiple-value-call 'list (expand-in-current-env (%m (values 1 2))))) (1 2)) gcl27-2.7.0/ansi-tests/multiple-value-list.lsp000066400000000000000000000035011454061450500211710ustar00rootroot00000000000000;-*- 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.5 (multiple-value-list (values 'a)) (a)) (deftest multiple-value-list.6 (multiple-value-list (values 'a 'b)) (a b)) (deftest multiple-value-list.7 (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) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest multiple-value-list.8 (macrolet ((%m (z) z)) (multiple-value-list (expand-in-current-env (%m 1)))) (1)) (deftest multiple-value-list.9 (macrolet ((%m (z) z)) (multiple-value-list (expand-in-current-env (%m (values 1 2 3))))) (1 2 3)) ;;; Test that the argument is evaluated just once (deftest multiple-value-list.order.1 (let ((i 0)) (values (multiple-value-list (incf i)) i)) (1) 1) ;;; Error tests (deftest multiple-value-list.error.1 (signals-error (funcall (macro-function 'multiple-value-list)) program-error) t) (deftest multiple-value-list.error.2 (signals-error (funcall (macro-function 'multiple-value-list) '(multiple-value-list nil)) program-error) t) (deftest multiple-value-list.error.3 (signals-error (funcall (macro-function 'multiple-value-list) '(multiple-value-list nil) nil nil) program-error) t) gcl27-2.7.0/ansi-tests/multiple-value-prog1.lsp000066400000000000000000000037171454061450500212570ustar00rootroot00000000000000;-*- 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) ;;; No implicit tagbody (deftest multiple-value-prog1.10 (block nil (tagbody (multiple-value-prog1 (values) (go 10) 10 (return 'bad)) 10 (return 'good))) good) ;;; Macros are expanded in the appropriate environment (deftest multiple-value-prog1.11 (macrolet ((%m (z) z)) (multiple-value-prog1 (expand-in-current-env (%m :good)))) :good) (deftest multiple-value-prog1.12 (macrolet ((%m (z) z)) (multiple-value-prog1 :good (expand-in-current-env (%m :foo)))) :good) gcl27-2.7.0/ansi-tests/multiple-value-setq.lsp000066400000000000000000000071571454061450500212050ustar00rootroot00000000000000;-*- 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) (deftest multiple-value-setq.13 (multiple-value-setq nil :good) :good) (deftest multiple-value-setq.14 (multiple-value-setq nil (values)) nil) (deftest multiple-value-setq.15 (multiple-value-setq nil (values 'a 'b)) a) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest multiple-value-setq.16 (macrolet ((%m (z) z)) (let ((x :bad)) (symbol-macrolet ((z (expand-in-current-env (%m x)))) (multiple-value-setq (z) :good)) x)) :good) (deftest multiple-value-setq.17 (macrolet ((%m (z) z)) (let ((x :bad)) (values (multiple-value-setq (x) (expand-in-current-env (%m :good))) x))) :good :good) ;;; Error tests (deftest multiple-value-setq.error.1 (signals-error (funcall (macro-function 'multiple-value-setq)) program-error) t) (deftest multiple-value-setq.error.2 (signals-error (funcall (macro-function 'multiple-value-setq) '(multiple-value-setq nil nil)) program-error) t) (deftest multiple-value-setq.error.3 (signals-error (funcall (macro-function 'multiple-value-setq) '(multiple-value-setq nil nil) nil nil) program-error) t) gcl27-2.7.0/ansi-tests/name-char.lsp000066400000000000000000000051131454061450500171070ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 29 17:14:03 2004 ;;;; Contains: Tests of NAME-CHAR (in-package :cl-test) (compile-and-load "char-aux.lsp") (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) ;;; Specialized sequence tests (deftest name-char.specialized.1 (loop for etype in '(standard-char base-char character) append (loop for s in '("Rubout" "Page" "Backspace" "Return" "Tab" "Linefeed" "Space" "Newline") for s2 = (make-array (length s) :element-type 'base-char :initial-contents s) unless (eql (name-char s) (name-char s2)) collect (list s s2))) nil) (deftest name-char.specialized.2 (loop for etype in '(standard-char base-char character) append (loop for s in '("Rubout" "Page" "Backspace" "Return" "Tab" "Linefeed" "Space" "Newline") for s2 = (make-array (length s) :element-type etype :adjustable t :initial-contents s) unless (eql (name-char s) (name-char s2)) collect (list etype s s2))) nil) (deftest name-char.specialized.3 (loop for etype in '(standard-char base-char character) append (loop for s in '("Rubout" "Page" "Backspace" "Return" "Tab" "Linefeed" "Space" "Newline") for s2 = (make-array (+ 3 (length s)) :element-type etype :fill-pointer (length s) :initial-contents (concatenate 'string s " ")) unless (eql (name-char s) (name-char s2)) collect (list etype s s2))) nil) (deftest name-char.specialized.4 (loop for etype in '(standard-char base-char character) append (loop for s in '("Rubout" "Page" "Backspace" "Return" "Tab" "Linefeed" "Space" "Newline") for s1 = (make-array (+ 4 (length s)) :element-type etype :initial-contents (concatenate 'string " " s " ")) for s2 = (make-array (length s) :element-type etype :displaced-to s1 :displaced-index-offset 2) unless (eql (name-char s) (name-char s2)) collect (list etype s s2))) nil) ;;; Error tests (deftest name-char.error.1 (signals-error (name-char) program-error) t) (deftest name-char.error.2 (signals-error (name-char "space" "space") program-error) t) gcl27-2.7.0/ansi-tests/namestring.lsp000066400000000000000000000036131454061450500174260ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Sep 2 07:24:42 2004 ;;;; Contains: Tests for NAMESTRING (in-package :cl-test) (deftest namestring.1 (let* ((vals (multiple-value-list (namestring "namestring.lsp"))) (s (first vals))) (if (and (null (cdr vals)) (stringp s) (equal (namestring s) s)) :good vals)) :good) (deftest namestring.2 (do-special-strings (s "namestring.lsp" nil) (let ((ns (namestring s))) (assert (stringp ns)) (assert (string= (namestring ns) ns)))) nil) ;;; I'm not convinced these tested required behavior, so I'm commenting ;;; them out for now. FIXME: determine if they are bogus #| (deftest namestring.3 (let* ((name "namestring.lsp") (pn (merge-pathnames (pathname name))) (name2 (namestring pn)) (pn2 (pathname name2))) (or (equalt pn pn2) (list (list pn (pathname-host pn) (pathname-device pn) (pathname-directory pn) (pathname-name pn) (pathname-type pn) (pathname-version pn)) (list pn2 (pathname-host pn2) (pathname-device pn2) (pathname-directory pn2) (pathname-name pn2) (pathname-type pn2) (pathname-version pn2))))) t) (deftest namestring.4 (let* ((name "namestring.lsp") (pn (merge-pathnames (pathname name))) (name2 (with-open-file (s pn :direction :input) (namestring s))) (pn2 (pathname name2))) (or (equalt pn pn2) (list (list pn (pathname-host pn) (pathname-device pn) (pathname-directory pn) (pathname-name pn) (pathname-type pn) (pathname-version pn)) (list pn2 (pathname-host pn2) (pathname-device pn2) (pathname-directory pn2) (pathname-name pn2) (pathname-type pn2) (pathname-version pn2))))) t) |# ;;; Error tests (deftest namestring.error.1 (signals-error (namestring) program-error) t) (deftest namestring.error.2 (signals-error (namestring "namestring.lsp" nil) program-error) t) gcl27-2.7.0/ansi-tests/nbutlast.lsp000066400000000000000000000045321454061450500171140ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:41:54 2003 ;;;; Contains: Tests of NBUTLAST (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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.7 (nbutlast (list 'a 'b 'c 'd) (1+ most-positive-fixnum)) nil) (deftest nbutlast.8 (nbutlast (list 'a 'b 'c 'd) most-positive-fixnum) nil) (deftest nbutlast.9 (nbutlast (list 'a 'b 'c 'd) (1- most-positive-fixnum)) 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) ;;; Error tests (deftest nbutlast.error.1 (signals-error (let ((x (list* 'a 'b 'c 'd))) (nbutlast x 'a)) type-error) t) (deftest nbutlast.error.2 (signals-error (nbutlast 'a 10) type-error) t) (deftest nbutlast.error.3 (signals-error (nbutlast 2 10) type-error) t) (deftest nbutlast.error.4 (signals-error (nbutlast #\w 10) type-error) t) (deftest nbutlast.error.5 (signals-error (nbutlast (list 'a 'b 'c 'd) -3) type-error) t) (deftest nbutlast.error.6 (signals-error (nbutlast (list 'a) 20.0) type-error) t) (deftest nbutlast.error.7 (signals-error (nbutlast (list 'a) -100.0) type-error) t) (deftest nbutlast.error.8 (signals-error (nbutlast) program-error) t) (deftest nbutlast.error.9 (signals-error (nbutlast (list 'a 'b 'c) 3 3) program-error) t) (deftest nbutlast.error.10 (signals-error (locally (nbutlast 'a 10) t) type-error) t) gcl27-2.7.0/ansi-tests/nconc.lsp000066400000000000000000000026711454061450500163620ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:35:53 2003 ;;;; Contains: Tests of NCONC (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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 (list 'a) (incf i)) i)) (a . 1) 1) gcl27-2.7.0/ansi-tests/next-method-p.lsp000066400000000000000000000033311454061450500177450ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 31 08:04:45 2003 ;;;; Contains: Tests of NEXT-METHOD-P (in-package :cl-test) (defgeneric nmp-gf-01 (x) (:method ((x integer)) (notnot-mv (next-method-p))) (:method ((x number)) 'foo) (:method ((x symbol)) (next-method-p))) (deftest next-method-p.1 (nmp-gf-01 10) t) (deftest next-method-p.2 (nmp-gf-01 1.2) foo) (deftest next-method-p.3 (nmp-gf-01 'a) nil) (defgeneric nmp-gf-02 (x y) (:method ((x integer) (y symbol)) (notnot-mv (next-method-p))) (:method ((x number) (y (eql nil))) 'foo)) (deftest next-method-p.4 (nmp-gf-02 10 nil) t) (deftest next-method-p.5 (nmp-gf-02 10 'a) nil) (defgeneric nmp-gf-03 (x y) (:method ((x integer) (y symbol)) #'next-method-p) (:method ((x t) (y (eql nil))) (constantly 1))) (deftest next-method-p.6 (notnot-mv (funcall (the function (nmp-gf-03 10 nil)))) t) (deftest next-method-p.7 (funcall (nmp-gf-03 10 'a)) nil) (defgeneric nmp-gf-04 (x y)) (defmethod nmp-gf-04 ((x integer) (y symbol)) #'next-method-p) (defmethod nmp-gf-04 ((x t) (y (eql nil))) (constantly 2)) (deftest next-method-p.8 (notnot-mv (funcall (the function (nmp-gf-04 10 nil)))) t) (deftest next-method-p.9 (funcall (nmp-gf-04 10 'a)) nil) ;; With AROUND methods (defgeneric nmp-gf-05 (x)) (defmethod nmp-gf-05 :around ((x number)) (notnot-mv (next-method-p))) (defmethod nmp-gf-05 ((x integer)) 'foo) (deftest next-method-p.10 (nmp-gf-05 10) t) ;; Need to also test next-method-p in builtin method combinations ;;; Error tests (deftest next-method-p.error.1 (signals-error (progn (eval '(defmethod nmp-gf-06 ((x t)) (next-method-p nil))) (nmp-gf-06 nil)) program-error) t) gcl27-2.7.0/ansi-tests/nil.lsp000066400000000000000000000011411454061450500160330ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 17 06:32:46 2002 ;;;; Contains: Tests for NIL (in-package :cl-test) (deftest nil.1 (check-predicate #'(lambda (x) (not (subtypep (type-of x) nil)))) nil) (deftest nil.2 (check-predicate #'(lambda (x) (subtypep nil (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 gcl27-2.7.0/ansi-tests/nintersection.lsp000066400000000000000000000222501454061450500201410ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:40:02 2003 ;;;; Contains: Tests of NINTERSECTION (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) (defharmless nintersection.test-and-test-not.1 (nintersection (list 'a 'b 'c) (list 'a 'c 'e) :test #'eql :test-not #'eql)) (defharmless nintersection.test-and-test-not.2 (nintersection (list 'a 'b 'c) (list 'a 'c 'e) :test-not #'eql :test #'eql)) ;;; 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 (signals-error (nintersection) program-error) t) (deftest nintersection.error.2 (signals-error (nintersection nil) program-error) t) (deftest nintersection.error.3 (signals-error (nintersection nil nil :bad t) program-error) t) (deftest nintersection.error.4 (signals-error (nintersection nil nil :key) program-error) t) (deftest nintersection.error.5 (signals-error (nintersection nil nil 1 2) program-error) t) (deftest nintersection.error.6 (signals-error (nintersection nil nil :bad t :allow-other-keys nil) program-error) t) (deftest nintersection.error.7 (signals-error (nintersection (list 1 2 3) (list 4 5 6) :test #'identity) program-error) t) (deftest nintersection.error.8 (signals-error (nintersection (list 1 2 3) (list 4 5 6) :test-not #'identity) program-error) t) (deftest nintersection.error.9 (signals-error (nintersection (list 1 2 3) (list 4 5 6) :key #'cons) program-error) t) (deftest nintersection.error.10 (signals-error (nintersection (list 1 2 3) (list 4 5 6) :key #'car) type-error) t) (deftest nintersection.error.11 (signals-error (nintersection (list 1 2 3) (list* 4 5 6 7)) type-error) t) (deftest nintersection.error.12 (signals-error (nintersection (list* 1 2 3) (list 4 5 6)) type-error) t) (deftest nintersection.error.13 (check-type-error #'(lambda (x) (nintersection x (copy-seq '(a b c)))) #'listp) nil) (deftest nintersection.error.14 (check-type-error #'(lambda (x) (nintersection (copy-seq '(a b c)) x)) #'listp) nil)gcl27-2.7.0/ansi-tests/no-applicable-method.lsp000066400000000000000000000007461454061450500212470ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 11 13:46:44 2003 ;;;; Contains: Tests of NO-APPLICABLE-METHOD (in-package :cl-test) (defgeneric no-app-meth-gf-01 (x)) (deftest no-applicable-method.1 (handler-case (progn (no-app-meth-gf-01 'x) :bad) (error () :good)) :good) ;;; I can't conformantly define useful methods for no-applicable-method ;;; without defining new generic function classes, and there's ;;; no standard way to do that. Grrr.gcl27-2.7.0/ansi-tests/no-next-method.lsp000066400000000000000000000021651454061450500201260ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 11 14:41:50 2003 ;;;; Contains: Tests of NO-NEXT-METHOD (in-package :cl-test) (defgeneric no-next-meth-gf-01 (x)) (defmethod no-next-meth-gf-01 ((x integer)) (call-next-method)) (defmethod no-next-meth-gf-01 :around ((x character)) (call-next-method)) (deftest no-next-method.1 (handler-case (progn (no-next-meth-gf-01 10) :bad) (error () :good)) :good) (deftest no-next-method.2 (handler-case (progn (no-next-meth-gf-01 ) :bad) (error () :good)) :good) ;;; (defparameter *no-next-meth-gf-02* ;;; (defgeneric no-next-meth-gf-02 (x))) ;;; ;;; (defmethod no-next-meth-gf-02 ((x integer)) ;;; (call-next-method)) ;;; ;;; (defmethod no-next-meth-gf-02 :around ((x character)) ;;; (call-next-method)) ;;; ;;; (defmethod no-next-method ((gf (eql *no-next-meth-gf-02*)) ;;; (method standard-method) ;;; &rest args) ;;; (values (copy-list args) :aborted)) ;;; ;;; (deftest no-next-method.3 ;;; (no-next-meth-gf-02 10) ;;; (10) :aborted) ;;; ;;; (deftest no-next-method.4 ;;; (no-next-meth-gf-02 #\a) ;;; (#\a) :aborted) gcl27-2.7.0/ansi-tests/not-and-null.lsp000066400000000000000000000016771454061450500175770ustar00rootroot00000000000000;-*- 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 (signals-error (null) program-error) t) (deftest null.error.2 (signals-error (null nil nil) program-error) t) (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 (signals-error (not) program-error) t) (deftest not.error.2 (signals-error (not nil nil) program-error) t) gcl27-2.7.0/ansi-tests/notany.lsp000066400000000000000000000167661454061450500166040ustar00rootroot00000000000000;-*- 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) ;;; Other specialized sequences (deftest notany.17 (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 2 3 4 5 6) :fill-pointer 4))) (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (not (notany #'plusp v)))) (nil nil nil nil nil t t t t t)) (deftest notany.18 (loop for i from 1 to 40 for type = `(unsigned-byte ,i) unless (let ((v (make-array '(10) :initial-contents (loop for j in '(0 0 0 0 1 2 3 4 5 6) collect (mod j (ash 1 i))) :element-type type :fill-pointer 4))) (equal (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (not (notany #'plusp v))) '(nil nil nil nil nil t t t t t))) collect i) nil) (deftest notany.19 (loop for i from 1 to 40 for type = `(signed-byte ,i) unless (let ((v (make-array '(10) :initial-contents '(0 0 0 0 -1 -1 -1 -1 -1 -1) :element-type type :fill-pointer 4))) (equal (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (not (notany #'minusp v))) '(nil nil nil nil nil t t t t t))) collect i) nil) (deftest notany.20 (let ((v (make-array '(10) :initial-contents "abcd012345" :element-type 'character :fill-pointer 4))) (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (not (notany #'digit-char-p v)))) (nil nil nil nil nil t t t t t)) (deftest notany.21 (let ((v (make-array '(10) :initial-contents "abcd012345" :element-type 'base-char :fill-pointer 4))) (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (not (notany #'digit-char-p v)))) (nil nil nil nil nil t t t t t)) (deftest notany.22 (let ((v (make-array '(5) :initial-contents "abcde" :element-type 'base-char))) (values (notnot (notany #'digit-char-p v)) (setf (aref v 2) #\0) (notany #'digit-char-p v))) t #\0 nil) (deftest notany.23 (loop for type in '(short-float single-float double-float long-float) for v = (make-array '(9) :element-type type :initial-contents (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6 0 8 3))) when (notany #'zerop v) collect (list type v)) nil) (deftest notany.24 (loop for type in '(short-float single-float double-float long-float) for v = (make-array '(9) :element-type type :fill-pointer 6 :initial-contents (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6 0 8 3))) unless (notany #'zerop v) collect (list type v)) nil) (deftest notany.25 (loop for type in '(short-float single-float double-float long-float) for ctype = `(complex ,type) for v = (make-array '(6) :element-type ctype :initial-contents (mapcar #'(lambda (x) (complex x (coerce x type))) '(1 2 3 4 5 6))) unless (notany (complement #'complexp) v) collect (list type v)) nil) ;;; Displaced vectors (deftest notany.26 (let* ((v1 (make-array '(10) :initial-contents '(1 3 2 4 6 8 5 7 9 1))) (v2 (make-array '(4) :displaced-to v1 :displaced-index-offset 2))) (values (notany #'oddp v1) (notnot (notany #'oddp v2)))) nil t) (deftest notany.27 (loop for i from 1 to 40 for type = `(unsigned-byte ,i) unless (let* ((v1 (make-array '(10) :initial-contents '(1 1 0 0 0 0 1 1 1 1) :element-type type)) (v2 (make-array '(4) :displaced-to v1 :displaced-index-offset 2 :element-type type))) (and (not (notany 'oddp v1)) (notany #'oddp v2))) collect i) nil) (deftest notany.28 (loop for i from 1 to 40 for type = `(signed-byte ,i) unless (let* ((v1 (make-array '(10) :initial-contents '(-1 -1 0 0 0 0 -1 -1 -1 -1) :element-type type)) (v2 (make-array '(4) :displaced-to v1 :displaced-index-offset 2 :element-type type))) (and (not (notany 'oddp v1)) (notany #'oddp v2))) collect i) nil) (deftest notany.29 (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'character))) (loop for i from 0 to 6 for s2 = (make-array '(2) :element-type 'character :displaced-to s1 :displaced-index-offset i) collect (not (notany 'digit-char-p s2)))) (t t nil nil t t t)) (deftest notany.30 (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'base-char))) (loop for i from 0 to 6 for s2 = (make-array '(2) :element-type 'base-char :displaced-to s1 :displaced-index-offset i) collect (not (notany 'digit-char-p s2)))) (t t nil nil t t t)) (deftest notany.31 (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) :adjustable t))) (values (notnot (notany #'minusp v)) (progn (adjust-array v '(11) :initial-element -1) (notany #'minusp v)))) t nil) (deftest notany.32 (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) :fill-pointer 10 :adjustable t))) (values (notnot (notany #'minusp v)) (progn (adjust-array v '(11) :initial-element -1) (notnot (notany #'minusp v))))) t t) (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 (check-type-error #'(lambda (x) (notany x '(a b c))) (typef '(or symbol function))) nil) (deftest notany.error.4 (check-type-error #'(lambda (x) (notany #'null x)) #'sequencep) nil) (deftest notany.error.7 (check-type-error #'(lambda (x) (notany #'eql () x)) #'sequencep) nil) (deftest notany.error.8 (signals-error (notany) program-error) t) (deftest notany.error.9 (signals-error (notany #'null) program-error) t) (deftest notany.error.10 (signals-error (locally (notany 1 '(a b c)) t) type-error) t) (deftest notany.error.11 (signals-error (notany #'cons '(a b c)) program-error) t) (deftest notany.error.12 (signals-error (notany #'cons '(a b c) '(1 2 4) '(g h j)) program-error) t) (deftest notany.error.13 (signals-error (notany #'car '(a b c)) type-error) t)gcl27-2.7.0/ansi-tests/notes.lsp000066400000000000000000000045251454061450500164120ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jun 30 21:43:23 2003 ;;;; Contains: Notes concerning various parts of the ANSI spec. (in-package :cl-test) (defnote :allow-nil-arrays "Allow specialized arrays of type (array nil).") (defnote :allow-nonzero-nil-vectors "Allow specialized vectors of type (vector nil) of nonzero size.") (defnote :nil-vectors-are-strings "Assume that (VECTOR NIL) objects are strings.") (defnote :standardized-package-nicknames "The standardized package nicknames specified in section 11 of ANSI CL are exclusive (disputed).") (defnote :type-of/strict-builtins "Interpret requirement 1.a on the TYPE-OF page to apply to all built-in types that contain the object, not just to some builtin type that contains the object.") (defnote :assume-no-gray-streams "Disable the test if gray streams are present.") (defnote :assume-no-simple-streams "Disable the test if simple streams are present.") (defnote :open-if-exists-new-version-no-error "Assume that OPEN, when called with :if-exists :new-version, does not fail.") #+sbcl (rt::disable-note :open-if-exists-new-version-no-error) (defnote :make-condition-with-compound-name "The spec says MAKE-CONDITION should work on any subtype of CONDITION, but this causes all sorts of problems. They probably meant only non-compound names.") (defnote :ansi-spec-problem "A catch-all for tests that illustrate problems in the ANSI spec.") (defnote :negative-zero-is-similar-to-positive-zero "The definition of similarity implies that -0.0 and 0.0 are similar (for each float type.) If negative zeros are distinct this is probably not good, since it makes (defconstant x 0.0) be nonportable.") (defnote :result-type-element-type-by-subtype "Assume that (for sequence functions MAP, etc.) the element type of a vector result type is defined to be the type X such that result-type is a subtype of (vector X).") (defnote :string-on-character-can-be-constant "string on characters need not be fresh") ;;; Haible disagrees with :result-type-element-type-by-subtype #+clisp (rt::disable-note :result-type-element-type-by-subtype) #+(or openmcl gcl ecl) (rt::disable-note :nil-vectors-are-strings) #+gcl (rt::disable-note :allow-nil-arrays) #+gcl (rt::disable-note :make-condition-with-compound-name) #+gcl (rt::disable-note :string-on-character-can-be-constant) gcl27-2.7.0/ansi-tests/notevery.lsp000066400000000000000000000171271454061450500171370ustar00rootroot00000000000000;-*- 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) ;;; Other specialized sequences (deftest notevery.17 (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 2 3 4 5 6) :fill-pointer 4))) (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (not (notevery #'zerop v)))) (t t t t t nil nil nil nil nil)) (deftest notevery.18 (loop for i from 1 to 40 for type = `(unsigned-byte ,i) unless (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 1 1 1 1 1) :element-type type :fill-pointer 4))) (equal (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (not (notevery #'zerop v))) '(t t t t t nil nil nil nil nil))) collect i) nil) (deftest notevery.19 (loop for i from 1 to 40 for type = `(signed-byte ,i) unless (let ((v (make-array '(10) :initial-contents '(0 0 0 0 -1 -1 -1 -1 -1 -1) :element-type type :fill-pointer 4))) (equal (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (not (notevery #'zerop v))) '(t t t t t nil nil nil nil nil))) collect i) nil) (deftest notevery.20 (let ((v (make-array '(10) :initial-contents "abcd012345" :element-type 'character :fill-pointer 4))) (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (not (notevery #'alpha-char-p v)))) (t t t t t nil nil nil nil nil)) (deftest notevery.21 (let ((v (make-array '(10) :initial-contents "abcd012345" :element-type 'base-char :fill-pointer 4))) (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (not (notevery #'alpha-char-p v)))) (t t t t t nil nil nil nil nil)) (deftest notevery.22 (let ((v (make-array '(5) :initial-contents "abcde" :element-type 'base-char))) (values (not (notevery #'alpha-char-p v)) (setf (aref v 2) #\0) (not (notevery #'alpha-char-p v)))) t #\0 nil) ;;; Displaced vectors (deftest notevery.23 (let* ((v1 (make-array '(10) :initial-contents '(1 3 2 4 6 8 5 7 9 1))) (v2 (make-array '(4) :displaced-to v1 :displaced-index-offset 2))) (values (not (notevery #'evenp v1)) (not (notevery 'evenp v2)))) nil t) (deftest notevery.24 (loop for i from 1 to 40 for type = `(unsigned-byte ,i) unless (let* ((v1 (make-array '(10) :initial-contents '(1 1 0 0 0 0 1 1 1 1) :element-type type)) (v2 (make-array '(4) :displaced-to v1 :displaced-index-offset 2 :element-type type))) (and (notevery 'evenp v1) (not (notevery #'evenp v2)))) collect i) nil) (deftest notevery.25 (loop for i from 1 to 40 for type = `(signed-byte ,i) unless (let* ((v1 (make-array '(10) :initial-contents '(-1 -1 0 0 0 0 -1 -1 -1 -1) :element-type type)) (v2 (make-array '(4) :displaced-to v1 :displaced-index-offset 2 :element-type type))) (and (notevery 'evenp v1) (not (notevery #'evenp v2)))) collect i) nil) (deftest notevery.26 (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'character))) (loop for i from 0 to 6 for s2 = (make-array '(2) :element-type 'character :displaced-to s1 :displaced-index-offset i) collect (not (notevery 'alpha-char-p s2)))) (nil nil t t nil nil nil)) (deftest notevery.27 (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'base-char))) (loop for i from 0 to 6 for s2 = (make-array '(2) :element-type 'base-char :displaced-to s1 :displaced-index-offset i) collect (not (notevery 'alpha-char-p s2)))) (nil nil t t nil nil nil)) ;;; adjustable vectors (deftest notevery.28 (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) :adjustable t))) (values (not (notevery #'plusp v)) (progn (adjust-array v '(11) :initial-element -1) (not (notevery #'plusp v))))) t nil) (deftest notevery.29 (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) :fill-pointer 10 :adjustable t))) (values (not (notevery #'plusp v)) (progn (adjust-array v '(11) :initial-element -1) (not (notevery #'plusp v))))) t t) ;;; Float, complex vectors (deftest notevery.30 (loop for type in '(short-float single-float double-float long-float) for v = (make-array '(6) :element-type type :initial-contents (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6))) when (notevery #'plusp v) collect (list type v)) nil) (deftest notevery.31 (loop for type in '(short-float single-float double-float long-float) for v = (make-array '(6) :element-type type :fill-pointer 5 :initial-contents (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 -1))) when (notevery #'plusp v) collect (list type v)) nil) (deftest notevery.32 (loop for type in '(short-float single-float double-float long-float) for ctype = `(complex ,type) for v = (make-array '(6) :element-type ctype :initial-contents (mapcar #'(lambda (x) (complex x (coerce x type))) '(1 2 3 4 5 6))) when (notevery #'complexp v) collect (list type v)) 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 (check-type-error #'(lambda (x) (notevery x '(a b c))) (typef '(or symbol function))) nil) (deftest notevery.error.4 (check-type-error #'(lambda (x) (notevery #'null x)) #'sequencep) nil) (deftest notevery.error.7 (check-type-error #'(lambda (x) (notevery #'eql () x)) #'sequencep) nil) (deftest notevery.error.8 (signals-error (notevery) program-error) t) (deftest notevery.error.9 (signals-error (notevery #'null) program-error) t) (deftest notevery.error.10 (signals-error (locally (notevery 1 '(a b c)) t) type-error) t) (deftest notevery.error.11 (signals-error (notevery #'cons '(a b c)) program-error) t) (deftest notevery.error.12 (signals-error (notevery #'cons '(a b c) '(1 2 4) '(g h j)) program-error) t) (deftest notevery.error.13 (signals-error (notevery #'car '(a b c)) type-error) t)gcl27-2.7.0/ansi-tests/nreconc.lsp000066400000000000000000000016271454061450500167110ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:38:12 2003 ;;;; Contains: Tests of NRECONC (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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 (signals-error (nreconc) program-error) t) (deftest nreconc.error.2 (signals-error (nreconc nil) program-error) t) (deftest nreconc.error.3 (signals-error (nreconc nil nil nil) program-error) t) (deftest nreconc.error.4 (signals-error (nreconc (cons 'a 'b) (list 'z)) type-error) t) gcl27-2.7.0/ansi-tests/nreverse.lsp000066400000000000000000000075601454061450500171150ustar00rootroot00000000000000;-*- 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-vector.4 (let ((x (make-array 0 :fill-pointer t :adjustable t))) (nreverse x)) #()) (deftest nreverse-vector.5 (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-vector.6 (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) ;;; Unusual vectors (deftest nreverse-vector.7 (do-special-integer-vectors (v #(0 0 1 0 1 1) nil) (let ((nv (nreverse v))) (assert (= (length nv) 6)) (assert (every #'= nv #(1 1 0 1 0 0))))) nil) (deftest nreverse-vector.8 (do-special-integer-vectors (v #(0 0 -1 0 -1 -1 0 -1) nil) (let ((nv (nreverse v))) (assert (= (length nv) 8)) (assert (every #'= nv #(-1 0 -1 -1 0 -1 0 0))))) nil) (deftest nreverse-vector.9 (let ((len 10)) (loop for etype in '(short-float single-float double-float long-float rational) for vals = (loop for i from 1 to len collect (coerce i etype)) for vec = (make-array len :element-type etype :initial-contents vals) for nvec = (nreverse vec) unless (and (eql (length nvec) len) (every #'eql (reverse vals) nvec)) collect (list etype vals nvec))) nil) (deftest nreverse-vector.10 (let ((len 10)) (loop for cetype in '(short-float single-float double-float long-float rational integer) for etype = `(complex ,cetype) for vals = (loop for i from 1 to len collect (complex (coerce i cetype) (coerce (- i) cetype))) for vec = (make-array len :element-type etype :initial-contents vals) for nvec = (nreverse vec) unless (and (eql (length nvec) len) (every #'eql (reverse vals) nvec)) collect (list etype vals nvec))) nil) ;;; Bit vectors (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) ;;; Strings (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-string.5 (do-special-strings (s (copy-seq "12345") nil) (let ((s2 (nreverse s))) (assert (stringp s2)) (assert (string= s2 "54321")) (assert (equal (array-element-type s) (array-element-type s2))))) nil) ;;; Argument is evaluated only once (deftest nreverse.order.1 (let ((i 0)) (values (nreverse (progn (incf i) (list 'a 'b 'c 'd))) i)) (d c b a) 1) ;;; Error tests (deftest nreverse.error.1 (check-type-error #'nreverse #'sequencep) nil) (deftest nreverse.error.6 (signals-error (nreverse) program-error) t) (deftest nreverse.error.7 (signals-error (nreverse nil nil) program-error) t) (deftest nreverse.error.8 (signals-error (locally (nreverse 'a) t) type-error) t) gcl27-2.7.0/ansi-tests/nset-difference.lsp000066400000000000000000000167321454061450500203260ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:44:44 2003 ;;;; Contains: Tests of NSET-DIFFERENCE (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) (defharmless nset-difference.test-and-test-not.1 (nset-difference (list 1 2 3 4) (list 1 7 3 8) :test #'eql :test-not #'eql)) (defharmless nset-difference.test-and-test-not.2 (nset-difference (list 1 2 3 4) (list 1 7 3 8) :test-not #'eql :test #'eql)) ;;; 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 (signals-error (nset-difference) program-error) t) (deftest nset-difference.error.2 (signals-error (nset-difference nil) program-error) t) (deftest nset-difference.error.3 (signals-error (nset-difference nil nil :bad t) program-error) t) (deftest nset-difference.error.4 (signals-error (nset-difference nil nil :key) program-error) t) (deftest nset-difference.error.5 (signals-error (nset-difference nil nil 1 2) program-error) t) (deftest nset-difference.error.6 (signals-error (nset-difference nil nil :bad t :allow-other-keys nil) program-error) t) (deftest nset-difference.error.7 (signals-error (nset-difference (list 1 2) (list 3 4) :test #'identity) program-error) t) (deftest nset-difference.error.8 (signals-error (nset-difference (list 1 2) (list 3 4) :test-not #'identity) program-error) t) (deftest nset-difference.error.9 (signals-error (nset-difference (list 1 2) (list 3 4) :key #'cons) program-error) t) (deftest nset-difference.error.10 (signals-error (nset-difference (list 1 2) (list 3 4) :key #'car) type-error) t) (deftest nset-difference.error.11 (signals-error (nset-difference (list 1 2 3) (list* 4 5 6)) type-error) t) (deftest nset-difference.error.12 (signals-error (nset-difference (list* 1 2 3) (list 4 5 6)) type-error) t) (deftest nset-difference.error.13 (check-type-error #'(lambda (x) (nset-difference (list 'a 'b) x)) #'listp) nil) (deftest nset-difference.error.14 (check-type-error #'(lambda (x) (nset-difference x (list 'a 'b))) #'listp) nil) gcl27-2.7.0/ansi-tests/nset-exclusive-or.lsp000066400000000000000000000215441454061450500206560ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:47:05 2003 ;;;; Contains: Tests of NSET-EXCLUSIVE-OR (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) (defharmless nset-exclusive-or.test-and-test-not.1 (nset-exclusive-or (list 1 2 3 4) (list 1 7 3 8) :test #'eql :test-not #'eql)) (defharmless nset-exclusive-or.test-and-test-not.2 (nset-exclusive-or (list 1 2 3 4) (list 1 7 3 8) :test-not #'eql :test #'eql)) ;;; 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) ;;; Randomized test (deftest random-nset-exclusive-or (random-set-exclusive-or-test 10 1000 'nset-exclusive-or) nil) ;;; Error tests (deftest nset-exclusive-or.error.1 (signals-error (nset-exclusive-or) program-error) t) (deftest nset-exclusive-or.error.2 (signals-error (nset-exclusive-or nil) program-error) t) (deftest nset-exclusive-or.error.3 (signals-error (nset-exclusive-or nil nil :bad t) program-error) t) (deftest nset-exclusive-or.error.4 (signals-error (nset-exclusive-or nil nil :key) program-error) t) (deftest nset-exclusive-or.error.5 (signals-error (nset-exclusive-or nil nil 1 2) program-error) t) (deftest nset-exclusive-or.error.6 (signals-error (nset-exclusive-or nil nil :bad t :allow-other-keys nil) program-error) t) (deftest nset-exclusive-or.error.7 (signals-error (nset-exclusive-or (list 1 2) (list 3 4) :test #'identity) program-error) t) (deftest nset-exclusive-or.error.8 (signals-error (nset-exclusive-or (list 1 2) (list 3 4) :test-not #'identity) program-error) t) (deftest nset-exclusive-or.error.9 (signals-error (nset-exclusive-or (list 1 2) (list 3 4) :key #'cons) program-error) t) (deftest nset-exclusive-or.error.10 (signals-error (nset-exclusive-or (list 1 2) (list 3 4) :key #'car) type-error) t) (deftest nset-exclusive-or.error.11 (signals-error (nset-exclusive-or (list 1 2 3) (list* 4 5 6)) type-error) t) (deftest nset-exclusive-or.error.12 (signals-error (nset-exclusive-or (list* 1 2 3) (list 4 5 6)) type-error) t) (deftest nset-exclusive-or.error.13 (check-type-error #'(lambda (x) (nset-exclusive-or x (list 'a 'b))) #'listp) nil) (deftest nset-exclusive-or.error.14 (check-type-error #'(lambda (x) (nset-exclusive-or (list 'a 'b) x)) #'listp) nil) gcl27-2.7.0/ansi-tests/nstring-capitalize.lsp000066400000000000000000000110161454061450500210620ustar00rootroot00000000000000;-*- 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.11 (nstring-capitalize "") "") (deftest nstring-capitalize.12 :notes (:nil-vectors-are-strings) (nstring-capitalize (make-array '(0) :element-type nil)) "") (deftest nstring-capitalize.13 (loop for type in '(standard-char base-char character) for s = (make-array '(10) :element-type type :fill-pointer 5 :initial-contents "aB0cDefGHi") collect (list (copy-seq s) (copy-seq (nstring-capitalize s)) (copy-seq s) (progn (setf (fill-pointer s) 10) (copy-seq s)) )) (("aB0cD" "Ab0cd" "Ab0cd" "Ab0cdefGHi") ("aB0cD" "Ab0cd" "Ab0cd" "Ab0cdefGHi") ("aB0cD" "Ab0cd" "Ab0cd" "Ab0cdefGHi"))) (deftest nstring-capitalize.14 (loop for type in '(standard-char base-char character) for s0 = (make-array '(10) :element-type type :initial-contents "zZaB0cDefG") for s = (make-array '(5) :element-type type :displaced-to s0 :displaced-index-offset 2) collect (list (copy-seq s) (nstring-capitalize s) (copy-seq s) s0)) (("aB0cD" "Ab0cd" "Ab0cd" "zZAb0cdefG") ("aB0cD" "Ab0cd" "Ab0cd" "zZAb0cdefG") ("aB0cD" "Ab0cd" "Ab0cd" "zZAb0cdefG"))) (deftest nstring-capitalize.15 (loop for type in '(standard-char base-char character) for s = (make-array '(5) :element-type type :adjustable t :initial-contents "aB0cD") collect (list (copy-seq s) (nstring-capitalize s) (copy-seq s))) (("aB0cD" "Ab0cd" "Ab0cd") ("aB0cD" "Ab0cd" "Ab0cd") ("aB0cD" "Ab0cd" "Ab0cd"))) ;;; Order of evaluation tests (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 (signals-error (nstring-capitalize) program-error) t) (deftest nstring-capitalize.error.2 (signals-error (nstring-capitalize (copy-seq "abc") :bad t) program-error) t) (deftest nstring-capitalize.error.3 (signals-error (nstring-capitalize (copy-seq "abc") :start) program-error) t) (deftest nstring-capitalize.error.4 (signals-error (nstring-capitalize (copy-seq "abc") :bad t :allow-other-keys nil) program-error) t) (deftest nstring-capitalize.error.5 (signals-error (nstring-capitalize (copy-seq "abc") :end) program-error) t) (deftest nstring-capitalize.error.6 (signals-error (nstring-capitalize (copy-seq "abc") 1 2) program-error) t) gcl27-2.7.0/ansi-tests/nstring-downcase.lsp000066400000000000000000000111331454061450500205400ustar00rootroot00000000000000;-*- 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.11 :notes (:nil-vectors-are-strings) (nstring-downcase (make-array '(0) :element-type nil)) "") (deftest nstring-downcase.12 (loop for type in '(standard-char base-char character) for s = (make-array '(10) :element-type type :fill-pointer 5 :initial-contents "aB0cDefGHi") collect (list (copy-seq s) (copy-seq (nstring-downcase s)) (copy-seq s) (progn (setf (fill-pointer s) 10) (copy-seq s)) )) (("aB0cD" "ab0cd" "ab0cd" "ab0cdefGHi") ("aB0cD" "ab0cd" "ab0cd" "ab0cdefGHi") ("aB0cD" "ab0cd" "ab0cd" "ab0cdefGHi"))) (deftest nstring-downcase.13 (loop for type in '(standard-char base-char character) for s0 = (make-array '(10) :element-type type :initial-contents "zZaB0cDefG") for s = (make-array '(5) :element-type type :displaced-to s0 :displaced-index-offset 2) collect (list (copy-seq s) (nstring-downcase s) (copy-seq s) s0)) (("aB0cD" "ab0cd" "ab0cd" "zZab0cdefG") ("aB0cD" "ab0cd" "ab0cd" "zZab0cdefG") ("aB0cD" "ab0cd" "ab0cd" "zZab0cdefG"))) (deftest nstring-downcase.14 (loop for type in '(standard-char base-char character) for s = (make-array '(5) :element-type type :adjustable t :initial-contents "aB0cD") collect (list (copy-seq s) (nstring-downcase s) (copy-seq s))) (("aB0cD" "ab0cd" "ab0cd") ("aB0cD" "ab0cd" "ab0cd") ("aB0cD" "ab0cd" "ab0cd"))) ;;; Order of evaluation tests (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 (signals-error (nstring-downcase) program-error) t) (deftest nstring-downcase.error.2 (signals-error (nstring-downcase (copy-seq "abc") :bad t) program-error) t) (deftest nstring-downcase.error.3 (signals-error (nstring-downcase (copy-seq "abc") :start) program-error) t) (deftest nstring-downcase.error.4 (signals-error (nstring-downcase (copy-seq "abc") :bad t :allow-other-keys nil) program-error) t) (deftest nstring-downcase.error.5 (signals-error (nstring-downcase (copy-seq "abc") :end) program-error) t) (deftest nstring-downcase.error.6 (signals-error (nstring-downcase (copy-seq "abc") 1 2) program-error) t) gcl27-2.7.0/ansi-tests/nstring-upcase.lsp000066400000000000000000000107611454061450500202230ustar00rootroot00000000000000;-*- 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.11 :notes (:nil-vectors-are-strings) (nstring-upcase (make-array '(0) :element-type nil)) "") (deftest nstring-upcase.12 (loop for type in '(standard-char base-char character) for s = (make-array '(10) :element-type type :fill-pointer 5 :initial-contents "aB0cDefGHi") collect (list (copy-seq s) (copy-seq (nstring-upcase s)) (copy-seq s) (progn (setf (fill-pointer s) 10) (copy-seq s)) )) (("aB0cD" "AB0CD" "AB0CD" "AB0CDefGHi") ("aB0cD" "AB0CD" "AB0CD" "AB0CDefGHi") ("aB0cD" "AB0CD" "AB0CD" "AB0CDefGHi"))) (deftest nstring-upcase.13 (loop for type in '(standard-char base-char character) for s0 = (make-array '(10) :element-type type :initial-contents "zZaB0cDefG") for s = (make-array '(5) :element-type type :displaced-to s0 :displaced-index-offset 2) collect (list (copy-seq s) (nstring-upcase s) (copy-seq s) s0)) (("aB0cD" "AB0CD" "AB0CD" "zZAB0CDefG") ("aB0cD" "AB0CD" "AB0CD" "zZAB0CDefG") ("aB0cD" "AB0CD" "AB0CD" "zZAB0CDefG"))) (deftest nstring-upcase.14 (loop for type in '(standard-char base-char character) for s = (make-array '(5) :element-type type :adjustable t :initial-contents "aB0cD") collect (list (copy-seq s) (nstring-upcase s) (copy-seq s))) (("aB0cD" "AB0CD" "AB0CD") ("aB0cD" "AB0CD" "AB0CD") ("aB0cD" "AB0CD" "AB0CD"))) ;;; Order of evaluation tests (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 (signals-error (nstring-upcase) program-error) t) (deftest nstring-upcase.error.2 (signals-error (nstring-upcase (copy-seq "abc") :bad t) program-error) t) (deftest nstring-upcase.error.3 (signals-error (nstring-upcase (copy-seq "abc") :start) program-error) t) (deftest nstring-upcase.error.4 (signals-error (nstring-upcase (copy-seq "abc") :bad t :allow-other-keys nil) program-error) t) (deftest nstring-upcase.error.5 (signals-error (nstring-upcase (copy-seq "abc") :end) program-error) t) (deftest nstring-upcase.error.6 (signals-error (nstring-upcase (copy-seq "abc") 1 2) program-error) t) gcl27-2.7.0/ansi-tests/nsublis.lsp000066400000000000000000000107471454061450500167440ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:35:33 2003 ;;;; Contains: Tests of NSUBLIS (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) (deftest nsublis.10 (check-nsublis (list 0 3 8 20) '((1 . x) (5 . y) (10 . z)) :test #'(lambda (x y) (and (realp x) (realp y) (< x y)))) (x y z 20)) (deftest nsublis.11 (check-nsublis (list 0 3 8 20) '((1 . x) (5 . y) (10 . z)) :test-not #'(lambda (x y) (not (and (realp x) (realp y) (< x y))))) (x y z 20)) (defharmless nsublis.test-and-test-not.1 (nsublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :test #'eql :test-not #'eql)) (defharmless nsublis.test-and-test-not.2 (nsublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :test-not #'eql :test #'eql)) ;;; 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 (signals-error (nsublis) program-error) t) (deftest nsublis.error.2 (signals-error (nsublis nil) program-error) t) (deftest nsublis.error.3 (signals-error (nsublis nil 'a :test) program-error) t) (deftest nsublis.error.4 (signals-error (nsublis nil 'a :bad-keyword t) program-error) t) (deftest nsublis.error.5 (signals-error (nsublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :test #'identity) program-error) t) (deftest nsublis.error.6 (signals-error (nsublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :key #'cons) program-error) t) (deftest nsublis.error.7 (signals-error (nsublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :test-not #'identity) program-error) t) (deftest nsublis.error.8 (signals-error (nsublis '((a . 1) . bad) (list 'a 'b 'c 'd)) type-error) t) gcl27-2.7.0/ansi-tests/nsubst-if-not.lsp000066400000000000000000000056271454061450500177760ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:54:12 2003 ;;;; Contains: Tests of NSUBST-IF-NOT (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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-not.2 (check-nsubst-if-not 'a (complement #'listp) '((100 1) (2 3) (4 3 2 1) (a b c))) a) (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-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-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-not.6 (nsubst-if-not 'a #'null nil :bad t :allow-other-keys t) nil) (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) ;;; 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 (deftest nsubst-if-not.error.1 (signals-error (nsubst-if-not) program-error) t) (deftest nsubst-if-not.error.2 (signals-error (nsubst-if-not 'a) program-error) t) (deftest nsubst-if-not.error.3 (signals-error (nsubst-if-not 'a #'null) program-error) t) (deftest nsubst-if-not.error.4 (signals-error (nsubst-if-not 'a #'null nil :foo nil) program-error) t) (deftest nsubst-if-not.error.5 (signals-error (nsubst-if-not 'a #'null nil :test) program-error) t) (deftest nsubst-if-not.error.6 (signals-error (nsubst-if-not 'a #'null nil 1) program-error) t) (deftest nsubst-if-not.error.7 (signals-error (nsubst-if-not 'a #'null nil :bad t :allow-other-keys nil) program-error) t) (deftest nsubst-if-not.error.8 (signals-error (nsubst-if-not 'a #'null (list 'a nil 'c) :key #'cons) program-error) t) gcl27-2.7.0/ansi-tests/nsubst-if.lsp000066400000000000000000000054431454061450500171740ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:51:41 2003 ;;;; Contains: Tests of NSUBST-IF (in-package :cl-test) (compile-and-load "cons-aux.lsp") (deftest nsubst-if.1 (check-nsubst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c))) a) (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.4 (check-nsubst-if 'b #'identity '((100 1) (2 3) (4 3 2 1) (a b c)) :key #'listp) b) (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.6 (check-nsubst-if 'a #'(lambda (x) (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.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) ;;; 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) ;;; error cases (deftest nsubst-if.error.1 (signals-error (nsubst-if) program-error) t) (deftest nsubst-if.error.2 (signals-error (nsubst-if 'a) program-error) t) (deftest nsubst-if.error.3 (signals-error (nsubst-if 'a #'null) program-error) t) (deftest nsubst-if.error.4 (signals-error (nsubst-if 'a #'null nil :foo nil) program-error) t) (deftest nsubst-if.error.5 (signals-error (nsubst-if 'a #'null nil :test) program-error) t) (deftest nsubst-if.error.6 (signals-error (nsubst-if 'a #'null nil 1) program-error) t) (deftest nsubst-if.error.7 (signals-error (nsubst-if 'a #'null nil :bad t :allow-other-keys nil) program-error) t) (deftest nsubst-if.error.8 (signals-error (nsubst-if 'a #'null (list 'a nil 'c) :key #'cons) program-error) t) gcl27-2.7.0/ansi-tests/nsubst.lsp000066400000000000000000000106601454061450500165750ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:49:58 2003 ;;;; Contains: Tests of NSUBST (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) (deftest nsubst.10 (check-nsubst 'x 10 (copy-tree '(1 2 10 20 30 4)) :test #'(lambda (x y) (and (realp x) (realp y) (< x y)))) (1 2 10 x x 4)) (deftest nsubst.11 (check-nsubst 'x 10 (copy-tree '(1 2 10 20 30 4)) :test-not #'(lambda (x y) (not (and (realp x) (realp y) (< x y))))) (1 2 10 x x 4)) (defharmless nsubset.test-and-test-not.1 (nsubst 'a 'b (list 'a 'b 'c 'd 'e) :test #'eq :test-not #'eq)) (defharmless nsubset.test-and-test-not.2 (nsubst 'a 'b (list 'a 'b 'c 'd 'e) :test-not #'eq :test #'eq)) ;;; 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)) ;;; Error cases (deftest nsubst.error.1 (signals-error (nsubst) program-error) t) (deftest nsubst.error.2 (signals-error (nsubst 'a) program-error) t) (deftest nsubst.error.3 (signals-error (nsubst 'a 'b) program-error) t) (deftest nsubst.error.4 (signals-error (nsubst 'a 'b nil :foo nil) program-error) t) (deftest nsubst.error.5 (signals-error (nsubst 'a 'b nil :test) program-error) t) (deftest nsubst.error.6 (signals-error (nsubst 'a 'b nil 1) program-error) t) (deftest nsubst.error.7 (signals-error (nsubst 'a 'b nil :bad t :allow-other-keys nil) program-error) t) (deftest nsubst.error.8 (signals-error (nsubst 'a 'b (list 'a 'b) :test #'identity) program-error) t) (deftest nsubst.error.9 (signals-error (nsubst 'a 'b (list 'a 'b) :test-not #'identity) program-error) t) (deftest nsubst.error.10 (signals-error (nsubst 'a 'b (list 'a 'b) :key #'equal) program-error) t) gcl27-2.7.0/ansi-tests/nsubstitute-if-not.lsp000066400000000000000000000620421454061450500210430ustar00rootroot00000000000000;-*- 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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-p 'a) x :count -1)) (a b a c)) (deftest nsubstitute-if-not-list.8 (nsubstitute-if-not 'b (is-not-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-p 'a) x)) #()) (deftest nsubstitute-if-not-vector.2 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eql-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-eql-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-eql-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-eql-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-eql-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-eql-p 'a) x :count -1)) #(a b a c)) (deftest nsubstitute-if-not-vector.8 (let ((x #())) (nsubstitute-if-not 'b (is-not-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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)) (deftest nsubstitute-if-not-vector.32 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (nsubstitute-if-not 'x (is-not-eql-p 'c) v2 :count 1)) #(d a b x d a b c)) (deftest nsubstitute-if-not-vector.33 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (nsubstitute-if-not 'x (is-not-eql-p 'c) v2 :count 1 :from-end t)) #(d a b c d a b x)) ;;; Tests on strings (deftest nsubstitute-if-not-string.1 (let ((x "")) (nsubstitute-if-not #\b (is-not-eql-p #\a) x)) "") (deftest nsubstitute-if-not-string.2 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eql-p #\a) x)) "bbbc") (deftest nsubstitute-if-not-string.3 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eql-p #\a) x :count nil)) "bbbc") (deftest nsubstitute-if-not-string.4 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eql-p #\a) x :count 2)) "bbbc") (deftest nsubstitute-if-not-string.5 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eql-p #\a) x :count 1)) "bbac") (deftest nsubstitute-if-not-string.6 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eql-p #\a) x :count 0)) "abac") (deftest nsubstitute-if-not-string.7 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eql-p #\a) x :count -1)) "abac") (deftest nsubstitute-if-not-string.8 (let ((x "")) (nsubstitute-if-not #\b (is-not-eql-p #\a) x :from-end t)) "") (deftest nsubstitute-if-not-string.9 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eql-p #\a) x :from-end t)) "bbbc") (deftest nsubstitute-if-not-string.10 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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") (deftest nsubstitute-if-not-string.32 (do-special-strings (s "xyzabcxyzabc" nil) (assert (string= (nsubstitute-if-not #\! (is-not-eql-p #\a) s) "xyz!bcxyz!bc"))) nil) (deftest nsubstitute-if-not-string.33 (do-special-strings (s "xyzabcxyzabc" nil) (assert (string= (nsubstitute-if-not #\! (is-not-eql-p #\a) s :count 1) "xyz!bcxyzabc"))) nil) (deftest nsubstitute-if-not-string.34 (do-special-strings (s "xyzabcxyzabc" nil) (assert (string= (nsubstitute-if-not #\! (is-not-eql-p #\a) s :count 1 :from-end t) "xyzabcxyz!bc"))) nil) ;;; Tests on bit-vectors (deftest nsubstitute-if-not-bit-vector.1 (let* ((orig #*) (x (copy-seq orig)) (result (nsubstitute-if-not 0 (is-not-eql-p 1) x))) result) #*) (deftest nsubstitute-if-not-bit-vector.2 (let* ((orig #*) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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 (signals-error (nsubstitute-if-not) program-error) t) (deftest nsubstitute-if-not.error.2 (signals-error (nsubstitute-if-not 'a) program-error) t) (deftest nsubstitute-if-not.error.3 (signals-error (nsubstitute-if-not 'a #'null) program-error) t) (deftest nsubstitute-if-not.error.4 (signals-error (nsubstitute-if-not 'a #'null nil 'bad t) program-error) t) (deftest nsubstitute-if-not.error.5 (signals-error (nsubstitute-if-not 'a #'null nil 'bad t :allow-other-keys nil) program-error) t) (deftest nsubstitute-if-not.error.6 (signals-error (nsubstitute-if-not 'a #'null nil :key) program-error) t) (deftest nsubstitute-if-not.error.7 (signals-error (nsubstitute-if-not 'a #'null nil 1 2) program-error) t) (deftest nsubstitute-if-not.error.8 (signals-error (nsubstitute-if-not 'a #'cons (list 'a 'b 'c)) program-error) t) (deftest nsubstitute-if-not.error.9 (signals-error (nsubstitute-if-not 'a #'car (list 'a 'b 'c)) type-error) t) (deftest nsubstitute-if-not.error.10 (signals-error (nsubstitute-if-not 'a #'identity (list 'a 'b 'c) :key #'car) type-error) t) (deftest nsubstitute-if-not.error.11 (signals-error (nsubstitute-if-not 'a #'identity (list 'a 'b 'c) :key #'cons) program-error) t) (deftest nsubstitute-if-not.error.12 (check-type-error #'(lambda (x) (nsubstitute-if-not 1 #'null x)) #'sequencep) nil) gcl27-2.7.0/ansi-tests/nsubstitute-if.lsp000066400000000000000000000576001454061450500202510ustar00rootroot00000000000000;-*- 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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-p 'a) x :count -1)) (a b a c)) (deftest nsubstitute-if-list.8 (nsubstitute-if 'b (is-eql-p 'a) nil :from-end t) nil) (deftest nsubstitute-if-list.9 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-p 'a) x)) #()) (deftest nsubstitute-if-vector.2 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eql-p 'a) x)) #(b b b c)) (deftest nsubstitute-if-vector.3 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eql-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-eql-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-eql-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-eql-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-eql-p 'a) x :count -1)) #(a b a c)) (deftest nsubstitute-if-vector.8 (let ((x #())) (nsubstitute-if 'b (is-eql-p 'a) x :from-end t)) #()) (deftest nsubstitute-if-vector.9 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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)) (deftest nsubstitute-if-vector.32 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (values (nsubstitute-if 'x (is-eql-p 'c) v2 :count 1) v1)) #(d a b x d a b c) #(a b c d a b x d a b c d a b c d)) (deftest nsubstitute-if-vector.33 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (values (nsubstitute-if 'x (is-eql-p 'c) v2 :count 1 :from-end t) v1)) #(d a b c d a b x) #(a b c d a b c d a b x d a b c d)) ;;; Tests on strings (deftest nsubstitute-if-string.1 (let ((x "")) (nsubstitute-if #\b (is-eql-p #\a) x)) "") (deftest nsubstitute-if-string.2 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x)) "bbbc") (deftest nsubstitute-if-string.3 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :count nil)) "bbbc") (deftest nsubstitute-if-string.4 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :count 2)) "bbbc") (deftest nsubstitute-if-string.5 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :count 1)) "bbac") (deftest nsubstitute-if-string.6 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :count 0)) "abac") (deftest nsubstitute-if-string.7 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :count -1)) "abac") (deftest nsubstitute-if-string.8 (let ((x "")) (nsubstitute-if #\b (is-eql-p #\a) x :from-end t)) "") (deftest nsubstitute-if-string.9 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :from-end t)) "bbbc") (deftest nsubstitute-if-string.10 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :from-end t :count nil)) "bbbc") (deftest nsubstitute-if-string.11 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :count 2 :from-end t)) "bbbc") (deftest nsubstitute-if-string.12 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :count 1 :from-end t)) "abbc") (deftest nsubstitute-if-string.13 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :count 0 :from-end t)) "abac") (deftest nsubstitute-if-string.14 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-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-eql-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-eql-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-eql-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-eql-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") (deftest nsubstitute-if-string.32 (do-special-strings (s "xyzabcxyzabc" nil) (assert (string= (nsubstitute-if #\! (is-eql-p #\a) s) "xyz!bcxyz!bc")) (assert (string= s "xyz!bcxyz!bc"))) nil) (deftest nsubstitute-if-string.33 (do-special-strings (s "xyzabcxyzabc" nil) (assert (string= (nsubstitute-if #\! (is-eql-p #\a) s :count 1) "xyz!bcxyzabc")) (assert (string= s "xyz!bcxyzabc"))) nil) (deftest nsubstitute-if-string.34 (do-special-strings (s "xyzabcxyzabc" nil) (assert (string= (nsubstitute-if #\! (is-eql-p #\a) s :count 1 :from-end t) "xyzabcxyz!bc")) (assert (string= s "xyzabcxyz!bc"))) nil) ;;; Tests on bit-vectors (deftest nsubstitute-if-bit-vector.1 (let* ((orig #*) (x (copy-seq orig)) (result (nsubstitute-if 0 (is-eql-p 1) x))) result) #*) (deftest nsubstitute-if-bit-vector.2 (let* ((orig #*) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eql-p 0) x))) result) #*) (deftest nsubstitute-if-bit-vector.3 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 0 (is-eql-p 1) x))) result) #*000000) (deftest nsubstitute-if-bit-vector.4 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eql-p 0) x))) result) #*111111) (deftest nsubstitute-if-bit-vector.5 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-p #\1) x :key #'nextdigit))) result) "a1a2342a15") (deftest nsubstitute-if-string.25 (let* ((orig "0102342015") (x (copy-seq orig)) (result (nsubstitute-if #\a (is-eql-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-eql-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-eql-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 (signals-error (nsubstitute-if) program-error) t) (deftest nsubstitute-if.error.2 (signals-error (nsubstitute-if 'a) program-error) t) (deftest nsubstitute-if.error.3 (signals-error (nsubstitute-if 'a #'null) program-error) t) (deftest nsubstitute-if.error.4 (signals-error (nsubstitute-if 'a #'null nil 'bad t) program-error) t) (deftest nsubstitute-if.error.5 (signals-error (nsubstitute-if 'a #'null nil 'bad t :allow-other-keys nil) program-error) t) (deftest nsubstitute-if.error.6 (signals-error (nsubstitute-if 'a #'null nil :key) program-error) t) (deftest nsubstitute-if.error.7 (signals-error (nsubstitute-if 'a #'null nil 1 2) program-error) t) (deftest nsubstitute-if.error.8 (signals-error (nsubstitute-if 'a #'cons (list 'a 'b 'c)) program-error) t) (deftest nsubstitute-if.error.9 (signals-error (nsubstitute-if 'a #'car (list 'a 'b 'c)) type-error) t) (deftest nsubstitute-if.error.10 (signals-error (nsubstitute-if 'a #'identity (list 'a 'b 'c) :key #'car) type-error) t) (deftest nsubstitute-if.error.11 (signals-error (nsubstitute-if 'a #'identity (list 'a 'b 'c) :key #'cons) program-error) t) (deftest nsubstitute-if.error.12 (check-type-error #'(lambda (x) (nsubstitute-if 0 #'identity x)) #'sequencep) nil) gcl27-2.7.0/ansi-tests/nsubstitute.lsp000066400000000000000000000711631454061450500176550ustar00rootroot00000000000000;-*- 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) (defharmless nsubstitute.test-and-test-not.1 (nsubstitute 'b 'a (list 'a 'b 'c 'd 'a 'b) :test #'eql :test-not #'eql)) (defharmless nsubstitute.test-and-test-not.2 (nsubstitute 'b 'a (list 'a 'b 'c 'd 'a 'b) :test-not #'eql :test #'eql)) (defharmless nsubstitute.test-and-test-not.3 (nsubstitute 'b 'a (vector 'a 'b 'c 'd 'a 'b) :test #'eql :test-not #'eql)) (defharmless nsubstitute.test-and-test-not.4 (nsubstitute 'b 'a (vector 'a 'b 'c 'd 'a 'b) :test-not #'eql :test #'eql)) (defharmless nsubstitute.test-and-test-not.5 (nsubstitute #\b #\a (copy-seq "abcdab") :test #'eql :test-not #'eql)) (defharmless nsubstitute.test-and-test-not.6 (nsubstitute #\b #\a (copy-seq "abcdab") :test-not #'eql :test #'eql)) (defharmless nsubstitute.test-and-test-not.7 (nsubstitute 1 0 (copy-seq #*001101001) :test #'eql :test-not #'eql)) (defharmless nsubstitute.test-and-test-not.8 (nsubstitute 0 1 (copy-seq #*1100110101) :test-not #'eql :test #'eql)) ;;;; 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-vector.32 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (values (nsubstitute 'x 'c v2 :count 1) v1)) #(d a b x d a b c) #(a b c d a b x d a b c d a b c d)) (deftest nsubstitute-vector.33 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (values (nsubstitute 'x 'c v2 :count 1 :from-end t) v1)) #(d a b c d a b x) #(a b c d a b c d a b x d a b c d)) (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-string.32 (do-special-strings (s "xyzabcxyzabc" nil) (assert (string= (nsubstitute #\! #\a s) "xyz!bcxyz!bc")) (assert (string= s "xyz!bcxyz!bc"))) nil) (deftest nsubstitute-string.33 (do-special-strings (s "xyzabcxyzabc" nil) (assert (string= (nsubstitute #\! #\a s :count 1) "xyz!bcxyzabc")) (assert (string= s "xyz!bcxyzabc"))) nil) (deftest nsubstitute-string.34 (do-special-strings (s "xyzabcxyzabc" nil) (assert (string= (nsubstitute #\! #\a s :count 1 :from-end t) "xyzabcxyz!bc")) (assert (string= s "xyzabcxyz!bc"))) nil) ;;; More bit vector tests (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 (signals-error (nsubstitute) program-error) t) (deftest nsubstitute.error.2 (signals-error (nsubstitute 'a) program-error) t) (deftest nsubstitute.error.3 (signals-error (nsubstitute 'a 'b) program-error) t) (deftest nsubstitute.error.4 (signals-error (nsubstitute 'a 'b nil 'bad t) program-error) t) (deftest nsubstitute.error.5 (signals-error (nsubstitute 'a 'b nil 'bad t :allow-other-keys nil) program-error) t) (deftest nsubstitute.error.6 (signals-error (nsubstitute 'a 'b nil :key) program-error) t) (deftest nsubstitute.error.7 (signals-error (nsubstitute 'a 'b nil 1 2) program-error) t) (deftest nsubstitute.error.8 (signals-error (nsubstitute 'a 'b (list 'a 'b 'c) :test #'identity) program-error) t) (deftest nsubstitute.error.9 (signals-error (nsubstitute 'a 'b (list 'a 'b 'c) :test-not #'identity) program-error) t) (deftest nsubstitute.error.10 (signals-error (nsubstitute 'a 'b (list 'a 'b 'c) :key #'cons) program-error) t) (deftest nsubstitute.error.11 (signals-error (nsubstitute 'a 'b (list 'a 'b 'c) :key #'car) type-error) t) (deftest nsubstitute.error.12 (check-type-error #'(lambda (x) (nsubstitute 1 0 x)) #'sequencep) nil) gcl27-2.7.0/ansi-tests/nth-value.lsp000066400000000000000000000027401454061450500171620ustar00rootroot00000000000000;-*- 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) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest nth-value.6 (macrolet ((%m (z) z)) (nth-value (expand-in-current-env (%m 1)) (values 'a 'b 'c))) b) (deftest nth-value.7 (macrolet ((%m (z) z)) (nth-value 1 (expand-in-current-env (%m (values 'a 'b 'c))))) b) ;;; Order of evaluation test (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) ;;; Error tests (deftest nth-value.error.1 (signals-error (funcall (macro-function 'nth-value)) program-error) t) (deftest nth-value.error.2 (signals-error (funcall (macro-function 'nth-value) '(nth-value 1 '(a b c))) program-error) t) (deftest nth-value.error.3 (signals-error (funcall (macro-function 'nth-value) '(nth-value 1 '(a b c)) nil nil) program-error) t) gcl27-2.7.0/ansi-tests/nth.lsp000066400000000000000000000022421454061450500160450ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:33:23 2003 ;;;; Contains: Tests of NTH (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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 (signals-error (nth) program-error) t) (deftest nth.error.2 (signals-error (nth 0) program-error) t) (deftest nth.error.3 (signals-error (nth 1 '(a b c) nil) program-error) t) (deftest nth.error.4 (signals-error (nth 0 '(a b c) nil) program-error) t) gcl27-2.7.0/ansi-tests/nthcdr.lsp000066400000000000000000000024321454061450500165370ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:48:36 2003 ;;;; Contains: Tests of NTHCDR (in-package :cl-test) (compile-and-load "cons-aux.lsp") ;;; Error tests (deftest nthcdr.error.1 (check-type-error #'(lambda (x) (nthcdr x (copy-list '(a b c d)))) (typef 'unsigned-byte)) nil) (deftest nthcdr.error.6 (signals-error (nthcdr -10 (copy-tree '(a b c d))) type-error) t) (deftest nthcdr.error.7 (signals-error (nthcdr) program-error) t) (deftest nthcdr.error.8 (signals-error (nthcdr 0) program-error) t) (deftest nthcdr.error.9 (signals-error (nthcdr 0 nil nil) program-error) t) (deftest nthcdr.error.10 (signals-error (nthcdr 3 (cons 'a 'b)) type-error) t) (deftest nthcdr.error.11 (signals-error (locally (nthcdr 'a (copy-tree '(a b c d))) t) type-error) t) ;;; Non-error tests (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) gcl27-2.7.0/ansi-tests/number-comparison.lsp000066400000000000000000001255471454061450500207320ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Apr 7 07:17:42 2003 ;;;; Contains: Tests of =, /=, <, <=, >, >= (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Errors tests on comparison functions (deftest =.error.1 (signals-error (=) program-error) t) (deftest /=.error.1 (signals-error (/=) program-error) t) (deftest <.error.1 (signals-error (<) program-error) t) (deftest <=.error.1 (signals-error (<=) program-error) t) (deftest >.error.1 (signals-error (>) program-error) t) (deftest >=.error.1 (signals-error (>=) program-error) t) ;;; Tests of = (deftest =.1 (loop for x in *numbers* unless (= x) collect x) nil) (deftest =.2 (loop for x in *numbers* unless (= x x) collect x) nil) (deftest =.3 (loop for x in *numbers* unless (= x x x) collect x) nil) (deftest =.4 (=.4-fn) nil) (deftest =.5 (loop for i from 1 to 10000 for i2 = (1+ i) never (or (= i i2) (= i2 i))) t) (deftest =.6 (loop for i from 5 to 10000 by 17 for j from 2 to i by 19 for r = (/ i j) unless (and (not (= r (1+ r))) (not (= r 0)) (not (= r (- r))) (= r r)) collect r) nil) (deftest =.7 (let ((args nil)) (loop for i from 1 to (min 256 (1- call-arguments-limit)) do (push 17 args) always (apply #'= args))) t) (deftest =.8 (loop for i from 2 to (min 256 (1- call-arguments-limit)) for args = (append (make-list (1- i) :initial-element 7) (list 23)) when (apply #'= args) collect args) nil) (deftest =.9 (=t 0 0.0) t) (deftest =.10 (=t 0 #c(0 0)) t) (deftest =.11 (=t 1 #c(1.0 0.0)) t) (deftest =.12 (=t -0.0 0.0) t) (deftest =.13 (let ((nums '(0 0.0s0 0.0f0 0.0d0 0.0l0 #c(0.0s0 0.0s0) #c(0.0f0 0.0f0) #c(0.0d0 0.0d0) #c(0.0l0 0.0l0)))) (loop for x in nums append (loop for y in nums unless (= x y) collect (list x y)))) nil) (deftest =.14 (let ((nums '(17 17.0s0 17.0f0 17.0d0 17.0l0 #c(17.0s0 0.0s0) #c(17.0f0 0.0f0) #c(17.0d0 0.0d0) #c(17.0l0 0.0l0)))) (loop for x in nums append (loop for y in nums unless (= x y) collect (list x y)))) nil) (deftest =.15 (let ((nums '(-17 -17.0s0 -17.0f0 -17.0d0 -17.0l0 #c(-17.0s0 0.0s0) #c(-17.0f0 0.0f0) #c(-17.0d0 0.0d0) #c(-17.0l0 0.0l0)))) (loop for x in nums append (loop for y in nums unless (= x y) collect (list x y)))) nil) (deftest =.16 (let ((n 60000) (m 30000)) (loop for x = (- (random n) m) for y = (- (random n) m) for z = (- (random n) m) for w = (- (random n) m) for a = (* x y) for b = (* x w) for c = (* y z) for d = (* w z) repeat 10000 when (and (/= b 0) (/= d 0) (or (not (= (/ a b) (/ c d))) (/= (/ a b) (/ c d)))) collect (list a b c d))) nil) ;;; Comparison of a rational with a float (deftest =.17 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for exp = (nth-value 1 (decode-float eps)) for radix = (float-radix eps) when (< (* (log radix 2) exp) 1000) nconc (let* ((rat (rational eps)) (xrat (rational x))) (loop for i from 2 to 100 for rat/i = (/ rat i) for xrat+rat/i = (+ xrat rat/i) nconc (if (= x xrat+rat/i) (list (list x i xrat+rat/i)) nil)))) nil) (deftest =.18 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-negative-epsilon single-float-negative-epsilon double-float-negative-epsilon long-float-negative-epsilon) for exp = (nth-value 1 (decode-float eps)) for radix = (float-radix eps) when (< (* (log radix 2) exp) 1000) nconc (let* ((rat (rational eps)) (xrat (rational x))) (loop for i from 2 to 100 for rat/i = (/ rat i) for xrat-rat/i = (- xrat rat/i) nconc (if (= x xrat-rat/i) (list (list x i xrat-rat/i)) nil)))) nil) (deftest =.19 (let ((bound (expt 10 1000))) (loop for x in (list most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float) for d = (and (<= x bound) (truncate x)) when (and d (or (= (* 3/2 d) x) (= x (* 5/4 d)))) collect (list x d (* 3/2 d) (* 5/4 d)))) nil) (deftest =.order.1 (let ((i 0) x y) (values (= (progn (setf x (incf i)) 1) (progn (setf y (incf i)) 2)) i x y)) nil 2 1 2) (deftest =.order.2 (let ((i 0) x y z) (values (= (progn (setf x (incf i)) 1) (progn (setf y (incf i)) 2) (progn (setf z (incf i)) 3)) i x y z)) nil 3 1 2 3) (deftest =.order.3 (let ((i 0) u v w x y z) (values (= (progn (setf u (incf i)) 1) (progn (setf v (incf i)) 2) (progn (setf w (incf i)) 3) (progn (setf x (incf i)) 4) (progn (setf y (incf i)) 5) (progn (setf z (incf i)) 6)) i u v w x y z)) nil 6 1 2 3 4 5 6) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (deftest /=.1 (loop for x in *numbers* unless (/= x) collect x) nil) (deftest /=.2 (loop for x in *numbers* when (/= x x) collect x) nil) (deftest /=.3 (loop for x in *numbers* when (/= x x x) collect x) nil) (deftest /=.4 (/=.4-fn) nil) (deftest /=.4a (/=.4a-fn) nil) (deftest /=.5 (loop for i from 1 to 10000 for i2 = (1+ i) always (and (/= i i2) (/= i2 i))) t) (deftest /=.6 (loop for i from 5 to 10000 by 17 for j from 2 to i by 19 for r = (/ i j) when (or (not (/= r (1+ r))) (not (/= r 0)) (not (/= r (- r))) (/= r r)) collect r) nil) (deftest /=.7 (let ((args (list 17)) (args2 nil)) (loop for i from 2 to (min 256 (1- call-arguments-limit)) do (push 17 args) do (push i args2) always (and (not (apply #'/= args)) (apply #'/= args2)))) t) (deftest /=.8 (loop for i from 2 to (min 256 (1- call-arguments-limit)) for args = (append (make-list (1- i) :initial-element 7) (list 7)) when (apply #'/= args) collect args) nil) (deftest /=.9 (/= 0 0.0) nil) (deftest /=.10 (/= 0 #c(0 0)) nil) (deftest /=.11 (/= 1 #c(1.0 0.0)) nil) (deftest /=.12 (/= -0.0 0.0) nil) (deftest /=.13 (let ((nums '(0 0.0s0 0.0f0 0.0d0 0.0l0 #c(0.0s0 0.0s0) #c(0.0f0 0.0f0) #c(0.0d0 0.0d0) #c(0.0l0 0.0l0)))) (loop for x in nums append (loop for y in nums when (/= x y) collect (list x y)))) nil) (deftest /=.14 (let ((nums '(17 17.0s0 17.0f0 17.0d0 17.0l0 #c(17.0s0 0.0s0) #c(17.0f0 0.0f0) #c(17.0d0 0.0d0) #c(17.0l0 0.0l0)))) (loop for x in nums append (loop for y in nums when (/= x y) collect (list x y)))) nil) (deftest /=.15 (let ((nums '(-17 -17.0s0 -17.0f0 -17.0d0 -17.0l0 #c(-17.0s0 0.0s0) #c(-17.0f0 0.0f0) #c(-17.0d0 0.0d0) #c(-17.0l0 0.0l0)))) (loop for x in nums append (loop for y in nums when (/= x y) collect (list x y)))) nil) (deftest /=.17 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for exp = (nth-value 1 (decode-float eps)) for radix = (float-radix eps) when (< (* (log radix 2) exp) 1000) nconc (let* ((rat (rational eps)) (xrat (rational x))) (loop for i from 2 to 100 for rat/i = (/ rat i) for xrat+rat/i = (+ xrat rat/i) nconc (if (/= x xrat+rat/i) nil (list (list x i xrat+rat/i)))))) nil) (deftest /=.18 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-negative-epsilon single-float-negative-epsilon double-float-negative-epsilon long-float-negative-epsilon) for exp = (nth-value 1 (decode-float eps)) for radix = (float-radix eps) when (< (* (log radix 2) exp) 1000) nconc (let* ((rat (rational eps)) (xrat (rational x))) (loop for i from 2 to 100 for rat/i = (/ rat i) for xrat-rat/i = (- xrat rat/i) nconc (if (/= x xrat-rat/i) nil (list (list x i xrat-rat/i)))))) nil) (deftest /=.19 (let ((bound (expt 10 1000))) (loop for x in (list most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float) for d = (and (<= x bound) (truncate x)) unless (or (null d) (and (/= (* 3/2 d) x) (/= x (* 5/4 d)))) collect (list x d (* 3/2 d) (* 5/4 d)))) nil) (deftest /=.order.1 (let ((i 0) x y) (values (notnot (/= (progn (setf x (incf i)) 1) (progn (setf y (incf i)) 2))) i x y)) t 2 1 2) (deftest /=.order.2 (let ((i 0) x y z) (values (notnot (/= (progn (setf x (incf i)) 1) (progn (setf y (incf i)) 2) (progn (setf z (incf i)) 3))) i x y z)) t 3 1 2 3) (deftest /=.order.3 (let ((i 0) u v w x y z) (values (notnot (/= (progn (setf u (incf i)) 1) (progn (setf v (incf i)) 2) (progn (setf w (incf i)) 3) (progn (setf x (incf i)) 4) (progn (setf y (incf i)) 5) (progn (setf z (incf i)) 6))) i u v w x y z)) t 6 1 2 3 4 5 6) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (deftest <.1 (let ((a 0) (b 1)) (notnot-mv (< a b))) t) (deftest <.2 (let ((a 0) (b 0)) (notnot-mv (< a b))) nil) (deftest <.3 (let ((a 1) (b 0)) (notnot-mv (< a b))) nil) (defparameter *number-less-tests* (let* ((n (- most-positive-fixnum most-negative-fixnum)) (n2 (* 1000 n))) (nconc (loop for i = (+ (random n) most-negative-fixnum) for i2 = (+ i (random most-positive-fixnum)) repeat 1000 nconc (list (list i i2 t) (list i2 i nil))) (loop for i = (random n2) for i2 = (+ (random n2) i) repeat 1000 nconc (list (list i i2 t) (list i2 i nil))) (loop for x in *universe* when (integerp x) nconc (list (list x (1+ x) t) (list (1+ x) x nil))) (loop for x in *universe* when (realp x) collect (list x x nil)) (loop for x in *universe* when (and (realp x) (>= x 1)) nconc (loop for epsilon in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for bound in (list most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float) for lower-bound in (list most-negative-short-float most-negative-single-float most-negative-double-float most-negative-long-float) for one in '(1.0s0 1.0f0 1.0d0 1.0l0) when (and (<= (abs (float-exponent lower-bound)) 500) (<= (abs (float-exponent x)) 500) (<= (abs (float-exponent bound)) 500)) when (<= (rational lower-bound) (rational x) (rational bound)) nconc (let* ((y (float x one)) (z (* y (- one (* 2 epsilon))))) (list (list y z nil) (list z y t))))) (loop for x in *universe* when (and (realp x) (<= x -1)) nconc (loop for epsilon in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for bound in (list most-negative-short-float most-negative-single-float most-negative-double-float most-negative-long-float) for upper-bound in (list most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float) for one in '(1.0s0 1.0f0 1.0d0 1.0l0) when (and (<= (abs (float-exponent bound)) 500) (<= (abs (float-exponent x)) 500) (<= (abs (float-exponent upper-bound)) 500)) when (<= (rational bound) (rational x) (rational upper-bound)) nconc (let* ((y (float x one))) (let ((z (* y (- one (* 2 epsilon))))) (list (list y z t) (list z y nil)))))) (loop for x in *universe* when (and (realp x) (< -1 x 1)) nconc (loop for epsilon in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for lower-bound in (list most-negative-short-float most-negative-single-float most-negative-double-float most-negative-long-float) for upper-bound in (list most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float) for one in '(1.0s0 1.0f0 1.0d0 1.0l0) when (and (<= (abs (float-exponent lower-bound)) 500) (<= (abs (float-exponent x)) 500) (<= (abs (float-exponent upper-bound)) 500)) when (<= (rational lower-bound) (rational x) (rational upper-bound)) nconc (handler-case (let* ((y (float x one)) (z1 (+ y epsilon)) (z2 (- y epsilon))) (list (list y z1 t) (list z1 y nil) (list y z2 nil) (list z2 y t))) (arithmetic-error () nil))) )))) (deftest <.4 (loop for (x y result . rest) in *number-less-tests* unless (if (< x y) result (not result)) collect (list* x y result rest)) nil) (deftest <.5 (loop for x in *universe* when (and (typep x 'real) (not (< x))) collect x) nil) (deftest <.6 (let ((args (list 17)) (args2 nil)) (loop for i from 2 to (min 256 (1- call-arguments-limit)) do (push 17 args) do (push (- i) args2) unless (and (not (apply #'< args)) (apply #'< args2)) collect (list args args2))) nil) (deftest <.7 (let* ((len (min 256 (1- call-arguments-limit))) (args-proto (loop for i from 1 to len collect i))) (loop for i from 1 below len for args = (copy-list args-proto) do (setf (elt args i) 0) never (apply #'< args))) t) ;;; Check that < is antisymmetric (deftest <.8 (<.8-fn) nil) ;;; < is symmetric with > (deftest <.9 (<.9-fn) nil) ;;; < is negation of >= (deftest <.10 (<.10-fn) nil) (deftest <.11 (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) never (or (< (- x) x) (< x (- x)))) t) (deftest <.17 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for exp = (nth-value 1 (decode-float eps)) for radix = (float-radix eps) when (< (* (log radix 2) exp) 1000) nconc (let* ((rat (rational eps)) (xrat (rational x))) (loop for i from 2 to 100 for rat/i = (/ rat i) for xrat+rat/i = (+ xrat rat/i) nconc (if (< x xrat+rat/i) nil (list (list x i xrat+rat/i)))))) nil) (deftest <.18 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-negative-epsilon single-float-negative-epsilon double-float-negative-epsilon long-float-negative-epsilon) for exp = (nth-value 1 (decode-float eps)) for radix = (float-radix eps) when (< (* (log radix 2) exp) 1000) nconc (let* ((rat (rational eps)) (xrat (rational x))) (loop for i from 2 to 100 for rat/i = (/ rat i) for xrat-rat/i = (- xrat rat/i) nconc (if (< x xrat-rat/i) (list (list x i xrat-rat/i)) nil)))) nil) (deftest <.19 (let ((bound (expt 10 1000))) (loop for x in (list most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float) for d = (and (<= x bound) (truncate x)) unless (or (null d) (and (< x (* 3/2 d)) (not (< (* 17/16 d) x)))) collect (list x d (* 3/2 d) (* 17/16 d)))) nil) (deftest <.order.1 (let ((i 0) x y) (values (notnot (< (progn (setf x (incf i)) 1) (progn (setf y (incf i)) 2))) i x y)) t 2 1 2) (deftest <.order.2 (let ((i 0) x y z) (values (notnot (< (progn (setf x (incf i)) 1) (progn (setf y (incf i)) 2) (progn (setf z (incf i)) 3))) i x y z)) t 3 1 2 3) (deftest <.order.3 (let ((i 0) u v w x y z) (values (notnot (< (progn (setf u (incf i)) 1) (progn (setf v (incf i)) 2) (progn (setf w (incf i)) 3) (progn (setf x (incf i)) 4) (progn (setf y (incf i)) 5) (progn (setf z (incf i)) 6))) i u v w x y z)) t 6 1 2 3 4 5 6) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (deftest <=.1 (let ((a 0) (b 1)) (notnot-mv (<= a b))) t) (deftest <=.2 (let ((a 0) (b 0)) (notnot-mv (<= a b))) t) (deftest <=.3 (let ((a 1) (b 0)) (notnot-mv (<= a b))) nil) (defparameter *number-less-or-equal-tests* (let* ((n (- most-positive-fixnum most-negative-fixnum)) (n2 (* 1000 n))) (nconc (loop for i = (+ (random n) most-negative-fixnum) for i2 = (+ i (random most-positive-fixnum)) repeat 1000 nconc (list (list i i2 t) (list i2 i nil))) (loop for i = (random n2) for i2 = (+ (random n2) i) repeat 1000 nconc (list (list i i2 t) (list i2 i nil))) (loop for x in *universe* when (integerp x) nconc (list (list x (1+ x) t) (list (1+ x) x nil))) (loop for x in *universe* when (realp x) collect (list x x t)) (loop for x in *universe* when (and (realp x) (>= x 1)) nconc (loop for epsilon in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for bound in (list most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float) for lower-bound in (list most-negative-short-float most-negative-single-float most-negative-double-float most-negative-long-float) for one in '(1.0s0 1.0f0 1.0d0 1.0l0) when (and (<= (abs (float-exponent lower-bound)) 500) (<= (abs (float-exponent x)) 500) (<= (abs (float-exponent bound)) 500)) when (<= (rational lower-bound) (rational x) (rational bound)) nconc (let* ((y (float x one)) (z (* y (- one (* 2 epsilon))))) (list (list y z nil) (list z y t))))) (loop for x in *universe* when (and (realp x) (<= x -1)) nconc (loop for epsilon in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for bound in (list most-negative-short-float most-negative-single-float most-negative-double-float most-negative-long-float) for upper-bound in (list most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float) for one in '(1.0s0 1.0f0 1.0d0 1.0l0) when (and (<= (abs (float-exponent bound)) 500) (<= (abs (float-exponent x)) 500) (<= (abs (float-exponent upper-bound)) 500)) when (<= (rational bound) (rational x) (rational upper-bound)) nconc (let* ((y (float x one)) (z (* y (- one (* 2 epsilon))))) (list (list y z t) (list z y nil))))) (loop for x in *universe* when (and (realp x) (< -1 x 1)) nconc (loop for epsilon in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for lower-bound in (list most-negative-short-float most-negative-single-float most-negative-double-float most-negative-long-float) for upper-bound in (list most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float) for one in '(1.0s0 1.0f0 1.0d0 1.0l0) when (and (<= (abs (float-exponent lower-bound)) 500) (<= (abs (float-exponent x)) 500) (<= (abs (float-exponent upper-bound)) 500)) when (<= (rational lower-bound) (rational x) (rational upper-bound)) nconc (handler-case (let* ((y (float x one)) (z1 (+ y epsilon)) (z2 (- y epsilon))) (list (list y z1 t) (list z1 y nil) (list y z2 nil) (list z2 y t))) (floating-point-underflow () nil)))) ))) (deftest <=.4 (loop for (x y result . rest) in *number-less-or-equal-tests* unless (if (<= x y) result (not result)) collect (list* x y result rest)) nil) (deftest <=.5 (loop for x in *universe* when (and (typep x 'real) (not (<= x))) collect x) nil) (deftest <=.6 (let ((args (list 17)) (args2 nil) (args3 (list 0))) (loop for i from 2 to (min 256 (1- call-arguments-limit)) do (push 17 args) do (push (- i) args2) do (push i args3) unless (and (apply #'<= args) (apply #'<= args2) (not (apply #'<= args3))) collect (list args args2 args3))) nil) (deftest <=.7 (let* ((len (min 256 (1- call-arguments-limit))) (args-proto (loop for i from 1 to len collect i))) (loop for i from 1 below len for args = (copy-list args-proto) do (setf (elt args i) 0) never (apply #'<= args))) t) ;;; Check that <= is symmetric with >= (deftest <=.8 (<=.8-fn) nil) ;;; Check that <= is equivalent to (or < =) (deftest <=.9 (<=.9-fn) nil) (deftest <=.10 (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) always (and (<= (- x) x) (<= x (- x)))) t) (deftest <=.17 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for exp = (nth-value 1 (decode-float eps)) for radix = (float-radix eps) when (< (* (log radix 2) exp) 1000) nconc (let* ((rat (rational eps)) (xrat (rational x))) (loop for i from 2 to 100 for rat/i = (/ rat i) for xrat+rat/i = (+ xrat rat/i) nconc (if (<= x xrat+rat/i) nil (list (list x i xrat+rat/i)))))) nil) (deftest <=.18 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-negative-epsilon single-float-negative-epsilon double-float-negative-epsilon long-float-negative-epsilon) for exp = (nth-value 1 (decode-float eps)) for radix = (float-radix eps) when (< (* (log radix 2) exp) 1000) nconc (let* ((rat (rational eps)) (xrat (rational x))) (loop for i from 2 to 100 for rat/i = (/ rat i) for xrat-rat/i = (- xrat rat/i) nconc (if (<= x xrat-rat/i) (list (list x i xrat-rat/i)) nil)))) nil) (deftest <=.19 (let ((bound (expt 10 1000))) (loop for x in (list most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float) for d = (and (<= x bound) (truncate x)) unless (or (null d) (and (<= x (* 3/2 d)) (not (<= (* 5/4 d) x)))) collect (list x d (* 3/2 d) (* 5/4 d)))) nil) (deftest <=.order.1 (let ((i 0) x y) (values (notnot (<= (progn (setf x (incf i)) 1) (progn (setf y (incf i)) 2))) i x y)) t 2 1 2) (deftest <=.order.2 (let ((i 0) x y z) (values (notnot (<= (progn (setf x (incf i)) 1) (progn (setf y (incf i)) 2) (progn (setf z (incf i)) 3))) i x y z)) t 3 1 2 3) (deftest <=.order.3 (let ((i 0) u v w x y z) (values (notnot (<= (progn (setf u (incf i)) 1) (progn (setf v (incf i)) 2) (progn (setf w (incf i)) 3) (progn (setf x (incf i)) 4) (progn (setf y (incf i)) 5) (progn (setf z (incf i)) 6))) i u v w x y z)) t 6 1 2 3 4 5 6) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (deftest >.1 (let ((a 0) (b 1)) (notnot-mv (> a b))) nil) (deftest >.2 (let ((a 0) (b 0)) (notnot-mv (> a b))) nil) (deftest >.3 (let ((a 1) (b 0)) (notnot-mv (> a b))) t) (deftest >.4 (loop for (x y result . rest) in *number-less-tests* unless (if (> y x) result (not result)) collect (list* y x result rest)) nil) (deftest >.5 (loop for x in *universe* when (and (typep x 'real) (not (> x))) collect x) nil) (deftest >.6 (let ((args (list 17)) (args2 nil)) (loop for i from 2 to (min 256 (1- call-arguments-limit)) do (push 17 args) do (push i args2) unless (and (not (apply #'> args)) (apply #'> args2)) collect (list args args2))) nil) (deftest >.7 (let* ((len (min 256 (1- call-arguments-limit))) (args-proto (loop for i from 1 to len collect i))) (loop for i from 1 below len for args = (copy-list args-proto) do (setf (elt args i) 0) never (apply #'> args))) t) ;;; > is negation of <= (deftest >.8 (>.8-fn) nil) (deftest >.9 (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) never (or (> (- x) x) (> x (- x)))) t) (deftest >.17 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for exp = (nth-value 1 (decode-float eps)) for radix = (float-radix eps) when (< (* (log radix 2) exp) 1000) nconc (let* ((rat (rational eps)) (xrat (rational x))) (loop for i from 2 to 100 for rat/i = (/ rat i) for xrat+rat/i = (+ xrat rat/i) nconc (if (> x xrat+rat/i) (list (list x i xrat+rat/i)) nil)))) nil) (deftest >.18 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-negative-epsilon single-float-negative-epsilon double-float-negative-epsilon long-float-negative-epsilon) for exp = (nth-value 1 (decode-float eps)) for radix = (float-radix eps) when (< (* (log radix 2) exp) 1000) nconc (let* ((rat (rational eps)) (xrat (rational x))) (loop for i from 2 to 100 for rat/i = (/ rat i) for xrat-rat/i = (- xrat rat/i) nconc (if (> x xrat-rat/i) nil (list (list x i xrat-rat/i)))))) nil) (deftest >.19 (let ((bound (expt 10 1000))) (loop for x in (list most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float) for d = (and (<= x bound) (truncate x)) unless (or (null d) (and (> (* 3/2 d) x) (not (> x (* 17/16 d))))) collect (list x d (* 3/2 d) (* 17/16 d)))) nil) (deftest >.order.1 (let ((i 0) x y) (values (notnot (> (progn (setf x (incf i)) 2) (progn (setf y (incf i)) 1))) i x y)) t 2 1 2) (deftest >.order.2 (let ((i 0) x y z) (values (notnot (> (progn (setf x (incf i)) 3) (progn (setf y (incf i)) 2) (progn (setf z (incf i)) 1))) i x y z)) t 3 1 2 3) (deftest >.order.3 (let ((i 0) u v w x y z) (values (notnot (> (progn (setf u (incf i)) 6) (progn (setf v (incf i)) 5) (progn (setf w (incf i)) 4) (progn (setf x (incf i)) 3) (progn (setf y (incf i)) 2) (progn (setf z (incf i)) 1))) i u v w x y z)) t 6 1 2 3 4 5 6) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (deftest >=.1 (let ((a 0) (b 1)) (notnot-mv (>= a b))) nil) (deftest >=.2 (let ((a 0) (b 0)) (notnot-mv (>= a b))) t) (deftest >=.3 (let ((a 1) (b 0)) (notnot-mv (>= a b))) t) (deftest >=.4 (loop for (x y result . rest) in *number-less-or-equal-tests* unless (if (>= y x) result (not result)) collect (list* y x result rest)) nil) (deftest >=.5 (loop for x in *universe* when (and (typep x 'real) (not (>= x))) collect x) nil) (deftest >=.6 (let ((args (list 17)) (args2 (list 0)) (args3 nil)) (loop for i from 2 to (min 256 (1- call-arguments-limit)) do (push 17 args) do (push (- i) args2) do (push i args3) unless (and (apply #'>= args) (not (apply #'>= args2)) (apply #'>= args3)) collect (list args args2 args3))) nil) (deftest >=.7 (let* ((len (min 256 (1- call-arguments-limit))) (args-proto (loop for i from 1 to len collect i))) (loop for i from 1 below len for args = (copy-list args-proto) do (setf (elt args i) 0) never (apply #'>= args))) t) ;;; Check that >= is equivalent to (or > =) (deftest >=.8 (>=.8-fn) nil) (deftest >=.9 (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) always (and (>= (- x) x) (>= x (- x)))) t) (deftest >=.17 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for exp = (nth-value 1 (decode-float eps)) for radix = (float-radix eps) when (< (* (log radix 2) exp) 1000) nconc (let* ((rat (rational eps)) (xrat (rational x))) (loop for i from 2 to 100 for rat/i = (/ rat i) for xrat+rat/i = (+ xrat rat/i) nconc (if (>= x xrat+rat/i) (list (list x i xrat+rat/i)) nil)))) nil) (deftest >=.18 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-negative-epsilon single-float-negative-epsilon double-float-negative-epsilon long-float-negative-epsilon) for exp = (nth-value 1 (decode-float eps)) for radix = (float-radix eps) when (< (* (log radix 2) exp) 1000) nconc (let* ((rat (rational eps)) (xrat (rational x))) (loop for i from 2 to 100 for rat/i = (/ rat i) for xrat-rat/i = (- xrat rat/i) nconc (if (>= x xrat-rat/i) nil (list (list x i xrat-rat/i)))))) nil) (deftest >=.19 (let ((bound (expt 10 1000))) (loop for x in (list most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float) for d = (and (<= x bound) (truncate x)) unless (or (null d) (and (>= (* 3/2 d) x) (not (>= x(* 17/16 d))))) collect (list x d (* 3/2 d) (* 17/16 d)))) nil) (deftest >=.order.1 (let ((i 0) x y) (values (notnot (>= (progn (setf x (incf i)) 2) (progn (setf y (incf i)) 1))) i x y)) t 2 1 2) (deftest >=.order.2 (let ((i 0) x y z) (values (notnot (>= (progn (setf x (incf i)) 3) (progn (setf y (incf i)) 2) (progn (setf z (incf i)) 1))) i x y z)) t 3 1 2 3) (deftest >=.order.3 (let ((i 0) u v w x y z) (values (notnot (>= (progn (setf u (incf i)) 6) (progn (setf v (incf i)) 5) (progn (setf w (incf i)) 4) (progn (setf x (incf i)) 3) (progn (setf y (incf i)) 2) (progn (setf z (incf i)) 1))) i u v w x y z)) t 6 1 2 3 4 5 6) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Comparison of rationals (deftest compare-rationals.1 (compare-random-rationals 60000 30000 10000) nil) (deftest compare-rationals.2 (compare-random-rationals 600000 300000 10000) nil) (deftest compare-rationals.3 (compare-random-rationals 6000000 3000000 10000) nil) (deftest compare-rationals.4 (compare-random-rationals 6000000000 3000000000 10000) nil) ;;;; Comparison of bignums with floats (deftest bignum.float.compare.1a (loop for x in *floats* when (or (zerop x) (< (abs (log (abs x))) 10000)) nconc (loop for r = (1+ (random (ash 1 (random 32)))) repeat 200 nconc (let ((i (+ r (ceiling (rational x))))) (unless (< x i) (list (list r x i)))))) nil) (deftest bignum.float.compare.1b (loop for x in *floats* when (or (zerop x) (< (abs (log (abs x))) 10000)) nconc (loop for r = (1+ (random (ash 1 (random 32)))) repeat 200 nconc (let ((i (- (floor (rational x)) r))) (unless (< i x) (list (list r x i)))))) nil) (deftest bignum.float.compare.2a (loop for x in *floats* when (or (zerop x) (< (abs (log (abs x))) 10000)) nconc (loop for r = (1+ (random (ash 1 (random 32)))) repeat 200 nconc (let ((i (+ r (ceiling (rational x))))) (unless (> i x) (list (list r x i)))))) nil) (deftest bignum.float.compare.2b (loop for x in *floats* when (or (zerop x) (< (abs (log (abs x))) 10000)) nconc (loop for r = (1+ (random (ash 1 (random 32)))) repeat 200 nconc (let ((i (- (floor (rational x)) r))) (unless (> x i) (list (list r x i)))))) nil) (deftest bignum.float.compare.3a (loop for x in *floats* when (or (zerop x) (< (abs (log (abs x))) 10000)) nconc (loop for r = (1+ (random (ash 1 (random 32)))) repeat 200 nconc (let ((i (+ r (ceiling (rational x))))) (when (or (= x i) (= i x)) (list (list r x i)))))) nil) (deftest bignum.float.compare.3b (loop for x in *floats* when (or (zerop x) (< (abs (log (abs x))) 10000)) nconc (loop for r = (1+ (random (ash 1 (random 32)))) repeat 200 nconc (let ((i (- (floor (rational x)) r))) (when (or (= x i) (= i x)) (list (list r x i)))))) nil) (deftest bignum.float.compare.4a (loop for x in *floats* when (or (zerop x) (< (abs (log (abs x))) 10000)) nconc (loop for r = (1+ (random (ash 1 (random 32)))) repeat 200 nconc (let ((i (+ r (ceiling (rational x))))) (unless (and (/= i x) (/= x i)) (list (list r x i)))))) nil) (deftest bignum.float.compare.4b (loop for x in *floats* when (or (zerop x) (< (abs (log (abs x))) 10000)) nconc (loop for r = (1+ (random (ash 1 (random 32)))) repeat 200 nconc (let ((i (- (floor (rational x)) r))) (unless (and (/= i x) (/= x i)) (list (list r x i)))))) nil) (deftest bignum.float.compare.5a (loop for x in *floats* when (or (zerop x) (< (abs (log (abs x))) 10000)) nconc (loop for r = (1+ (random (ash 1 (random 32)))) repeat 200 nconc (let ((i (+ r (ceiling (rational x))))) (unless (<= x i) (list (list r x i)))))) nil) (deftest bignum.float.compare.5b (loop for x in *floats* when (or (zerop x) (< (abs (log (abs x))) 10000)) nconc (loop for r = (1+ (random (ash 1 (random 32)))) repeat 200 nconc (let ((i (- (floor (rational x)) r))) (unless (<= i x) (list (list r x i)))))) nil) (deftest bignum.float.compare.6a (loop for x in *floats* when (or (zerop x) (< (abs (log (abs x))) 10000)) nconc (loop for r = (1+ (random (ash 1 (random 32)))) repeat 200 nconc (let ((i (+ r (ceiling (rational x))))) (unless (>= i x) (list (list r x i)))))) nil) (deftest bignum.float.compare.6b (loop for x in *floats* when (or (zerop x) (< (abs (log (abs x))) 10000)) nconc (loop for r = (1+ (random (ash 1 (random 32)))) repeat 200 nconc (let ((i (- (floor (rational x)) r))) (unless (>= x i) (list (list r x i)))))) nil) (deftest bignum.float.compare.7 (let ((toobig (loop for x in *reals* collect (and (> (abs x) 1.0) (> (abs (log (abs x))) 10000))))) (loop for x in *reals* for xtoobig in toobig nconc (unless xtoobig (let ((fx (floor x))) (loop for y in *reals* for ytoobig in toobig when (and (not ytoobig) (< x y) (or (not (< fx y)) (<= y fx) (not (> y fx)) (>= fx y))) collect (list x y)))))) nil) (deftest bignum.float.compare.8 (let ((toobig (loop for x in *reals* collect (and (> (abs x) 1.0) (> (abs (log (abs x))) 10000))))) (loop for x in *reals* for xtoobig in toobig nconc (unless xtoobig (let ((fx (floor x))) (loop for y in *reals* for ytoobig in toobig when (and (not ytoobig) (<= x y) (or (not (<= fx y)) (> fx y) (not (>= y fx)) (< y fx))) collect (list x y)))))) nil) ;;; More randomized comparisons (deftest bignum.short-float.random.compare.1 (let* ((integer-bound (ash 1 1000)) (upper-bound (if (< (/ most-positive-short-float 2) integer-bound) (/ most-positive-short-float 2) (coerce integer-bound 'short-float)))) (loop for bound = 1.0s0 then (* bound 2) while (<= bound upper-bound) nconc (loop for r = (random bound) for fr = (floor r) for cr = (ceiling r) repeat 20 unless (and (<= fr r cr) (if (= r fr) (= r cr) (/= r cr)) (>= cr r fr)) collect (list r fr cr)))) nil) (deftest bignum.single-float.random.compare.1 (let* ((integer-bound (ash 1 100)) (upper-bound (if (< (/ most-positive-single-float 2) integer-bound) (/ most-positive-single-float 2) (coerce integer-bound 'single-float)))) (loop for bound = 1.0f0 then (* bound 2) while (<= bound upper-bound) nconc (loop for r = (random bound) for fr = (floor r) for cr = (ceiling r) repeat 20 unless (and (<= fr r cr) (if (= r fr) (= r cr) (/= r cr)) (>= cr r fr)) collect (list r fr cr)))) nil) (deftest bignum.double-float.random.compare.1 (let* ((integer-bound (ash 1 100)) (upper-bound (if (< (/ most-positive-double-float 2) integer-bound) (/ most-positive-double-float 2) (coerce integer-bound 'double-float)))) (loop for bound = 1.0d0 then (* bound 2) while (<= bound upper-bound) nconc (loop for r = (random bound) for fr = (floor r) for cr = (ceiling r) repeat 20 unless (and (<= fr r cr) (if (= r fr) (= r cr) (/= r cr)) (>= cr r fr)) collect (list r fr cr)))) nil) (deftest bignum.long-float.random.compare.1 (let* ((integer-bound (ash 1 100)) (upper-bound (if (< (/ most-positive-long-float 2) integer-bound) (/ most-positive-long-float 2) (coerce integer-bound 'long-float)))) (loop for bound = 1.0l0 then (* bound 2) while (< bound upper-bound) nconc (loop for r = (random bound) for fr = (floor r) for cr = (ceiling r) repeat 20 unless (and (<= fr r cr) (if (= r fr) (= r cr) (/= r cr)) (>= cr r fr)) collect (list r fr cr)))) nil) ;;; Rational/float comparisons (deftest rational.short-float.random.compare.1 (let* ((integer-bound (ash 1 1000)) (upper-bound (if (< (/ most-positive-short-float 2) integer-bound) (/ most-positive-short-float 2) (coerce integer-bound 'short-float)))) (loop for bound = 1.0s0 then (* bound 2) while (<= bound upper-bound) nconc (loop for r = (+ 1.s0 (random bound)) for fr = (floor r) for cr = (ceiling r) for m = (ash 1 (1+ (random 30))) for p = (1+ (random m)) for q = (1+ (random m)) for x = 0 repeat 50 when (<= p q) do (psetf p (1+ q) q p) do (setf x (/ p q)) unless (let ((fr/x (/ fr x)) (cr*x (* cr x))) (and (<= fr/x r cr*x) (< fr/x r cr*x) (> cr*x r fr/x) (>= cr*x r fr/x))) collect (list r p q x fr cr)))) nil) (deftest rational.single-float.random.compare.1 (let* ((integer-bound (ash 1 1000)) (upper-bound (if (< (/ most-positive-single-float 2) integer-bound) (/ most-positive-single-float 2) (coerce integer-bound 'single-float)))) (loop for bound = 1.0f0 then (* bound 2) while (<= bound upper-bound) nconc (loop for r = (+ 1.s0 (random bound)) for fr = (floor r) for cr = (ceiling r) for m = (ash 1 (1+ (random 30))) for p = (1+ (random m)) for q = (1+ (random m)) for x = 0 repeat 50 when (<= p q) do (psetf p (1+ q) q p) do (setf x (/ p q)) unless (let ((fr/x (/ fr x)) (cr*x (* cr x))) (and (<= fr/x r cr*x) (< fr/x r cr*x) (> cr*x r fr/x) (>= cr*x r fr/x))) collect (list r p q x fr cr)))) nil) (deftest rational.double-float.random.compare.1 (let* ((integer-bound (ash 1 1000)) (upper-bound (if (< (/ most-positive-double-float 4) integer-bound) (/ most-positive-double-float 4) (coerce integer-bound 'double-float)))) (loop for bound = 1.0d0 then (* bound 4) while (<= bound upper-bound) nconc (loop for r = (+ 1.s0 (random bound)) for fr = (floor r) for cr = (ceiling r) for m = (ash 1 (1+ (random 30))) for p = (1+ (random m)) for q = (1+ (random m)) for x = 0 repeat 50 when (<= p q) do (psetf p (1+ q) q p) do (setf x (/ p q)) unless (let ((fr/x (/ fr x)) (cr*x (* cr x))) (and (<= fr/x r cr*x) (< fr/x r cr*x) (> cr*x r fr/x) (>= cr*x r fr/x))) collect (list r p q x fr cr)))) nil) (deftest rational.long-float.random.compare.1 (let* ((integer-bound (ash 1 1000)) (upper-bound (if (< (/ most-positive-long-float 4) integer-bound) (/ most-positive-long-float 4) (coerce integer-bound 'long-float)))) (loop for bound = 1.0d0 then (* bound 4) while (<= bound upper-bound) nconc (loop for r = (+ 1.s0 (random bound)) for fr = (floor r) for cr = (ceiling r) for m = (ash 1 (1+ (random 30))) for p = (1+ (random m)) for q = (1+ (random m)) for x = 0 repeat 50 when (<= p q) do (psetf p (1+ q) q p) do (setf x (/ p q)) unless (let ((fr/x (/ fr x)) (cr*x (* cr x))) (and (<= fr/x r cr*x) (< fr/x r cr*x) (> cr*x r fr/x) (>= cr*x r fr/x))) collect (list r p q x fr cr)))) nil) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest =.env.1 (macrolet ((%m (z) z)) (mapcar 'notnot (list (= (expand-in-current-env (%m 0))) (= 1 (expand-in-current-env (%m 1))) (= (expand-in-current-env (%m 2)) 2) (= (expand-in-current-env (%m 3)) (expand-in-current-env (%m 3))) (= (expand-in-current-env (%m #c(1 2))) (expand-in-current-env (%m #c(1 2)))) (= 1 (expand-in-current-env (%m 2.0))) (= (expand-in-current-env (%m 2)) 2/3) (= (expand-in-current-env (%m 4)) (expand-in-current-env (%m 5))) (= (expand-in-current-env (%m 0)) 0 0) (= 0 (expand-in-current-env (%m 0)) 0) (= 0 0 (expand-in-current-env (%m 0))) ))) (t t t t t nil nil nil t t t)) (deftest /=.env.1 (macrolet ((%m (z) z)) (mapcar 'notnot (list (/= (expand-in-current-env (%m 0))) (/= 1 (expand-in-current-env (%m 1))) (/= (expand-in-current-env (%m 2)) 2) (/= (expand-in-current-env (%m 3)) (expand-in-current-env (%m 3))) (/= (expand-in-current-env (%m #c(1 2))) (expand-in-current-env (%m #c(1 2)))) (/= 1 (expand-in-current-env (%m 2.0))) (/= (expand-in-current-env (%m 2)) 2/3) (/= (expand-in-current-env (%m 4)) (expand-in-current-env (%m 5))) (/= (expand-in-current-env (%m 2)) 0 1) (/= 0 (expand-in-current-env (%m 2)) 1) (/= 0 1 (expand-in-current-env (%m 2))) ))) (t nil nil nil nil t t t t t t)) (deftest <.env.1 (macrolet ((%m (z) z)) (mapcar 'notnot (list (< (expand-in-current-env (%m 0))) (< 0 (expand-in-current-env (%m 1))) (< (expand-in-current-env (%m 2)) 3) (< (expand-in-current-env (%m 5)) (expand-in-current-env (%m 7))) (< 3 (expand-in-current-env (%m 2.0))) (< (expand-in-current-env (%m 2)) 2/3) (< (expand-in-current-env (%m 6)) (expand-in-current-env (%m 5))) (< (expand-in-current-env (%m 1)) 2 3) (< 1 (expand-in-current-env (%m 2)) 3) (< 1 2 (expand-in-current-env (%m 3))) ))) (t t t t nil nil nil t t t)) (deftest <=.env.1 (macrolet ((%m (z) z)) (mapcar 'notnot (list (<= (expand-in-current-env (%m 0))) (<= 0 (expand-in-current-env (%m 1))) (<= (expand-in-current-env (%m 2)) 3) (<= (expand-in-current-env (%m 5)) (expand-in-current-env (%m 7))) (<= 3 (expand-in-current-env (%m 2.0))) (<= (expand-in-current-env (%m 2)) 2/3) (<= (expand-in-current-env (%m 6)) (expand-in-current-env (%m 5))) (<= (expand-in-current-env (%m 2)) 2 3) (<= 1 (expand-in-current-env (%m 1)) 3) (<= 1 2 (expand-in-current-env (%m 2))) ))) (t t t t nil nil nil t t t)) (deftest >.env.1 (macrolet ((%m (z) z)) (mapcar 'notnot (list (> (expand-in-current-env (%m 0))) (> 2 (expand-in-current-env (%m 1))) (> (expand-in-current-env (%m 4)) 3) (> (expand-in-current-env (%m 10)) (expand-in-current-env (%m 7))) (> 1 (expand-in-current-env (%m 2.0))) (> (expand-in-current-env (%m -1)) 2/3) (> (expand-in-current-env (%m 4)) (expand-in-current-env (%m 5))) (> (expand-in-current-env (%m 2)) 1 0) (> 2 (expand-in-current-env (%m 1)) 0) (> 2 1 (expand-in-current-env (%m 0))) ))) (t t t t nil nil nil t t t)) (deftest >=.env.1 (macrolet ((%m (z) z)) (mapcar 'notnot (list (>= (expand-in-current-env (%m 0))) (>= 2 (expand-in-current-env (%m 1))) (>= (expand-in-current-env (%m 4)) 3) (>= (expand-in-current-env (%m 7)) (expand-in-current-env (%m 7))) (>= 1 (expand-in-current-env (%m 2.0))) (>= (expand-in-current-env (%m -1)) 2/3) (>= (expand-in-current-env (%m 4)) (expand-in-current-env (%m 5))) (>= (expand-in-current-env (%m 2)) 1 1) (>= 1 (expand-in-current-env (%m 1)) 0) (>= 2 2 (expand-in-current-env (%m 0))) ))) (t t t t nil nil nil t t t)) gcl27-2.7.0/ansi-tests/numberp.lsp000066400000000000000000000007031454061450500167240ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 6 18:20:36 2003 ;;;; Contains: Tests of NUMBERP (in-package :cl-test) (deftest numberp.error.1 (signals-error (numberp) program-error) t) (deftest numberp.error.2 (signals-error (numberp 0 nil) program-error) t) (deftest numberp.error.3 (signals-error (numberp 'a nil nil) program-error) t) (deftest numberp.1 (check-type-predicate #'numberp 'number) nil) gcl27-2.7.0/ansi-tests/numbers-aux.lsp000066400000000000000000000230761454061450500175320ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Apr 7 07:24:43 2003 ;;;; Contains: Auxiliary functions for number tests (in-package :cl-test) (eval-when (:compile-toplevel :load-toplevel :execute) (compile-and-load "random-aux.lsp")) ;;; Binary search on reals (defun float-binary-search (fn lo hi) "FN is a function that, if true for X, is true for all Y > X. Find the smallest float in [lo,hi] for which the function return true." (assert (functionp fn)) (assert (floatp lo)) (assert (floatp hi)) (assert (<= lo hi)) (assert (funcall fn hi)) (loop while (<= lo hi) do (let ((mid (/ (+ lo hi) 2))) (if (funcall fn mid) (if (= mid hi) (return hi) (setq hi mid)) (if (= mid lo) (return hi) (setq lo mid)))))) (defun integer-binary-search (fn lo hi) "FN is a function that, if true for X, is true for all Y < X. Find the largest integer in [lo,hi) for which the function return true." (assert (functionp fn)) (assert (integerp lo)) (assert (integerp hi)) (assert (<= lo hi)) (assert (funcall fn lo)) (loop while (< lo hi) do (let ((mid (ceiling (+ lo hi) 2))) (if (funcall fn mid) (setq lo mid) (if (= mid hi) (return lo) (setq hi mid)))) finally (return lo))) (defun find-largest-exactly-floatable-integer (upper-bound) (integer-binary-search #'(lambda (i) (let* ((f (float i)) (i- (1- i)) (f- (float i-))) (and (= f i) (= f- i-)))) 0 upper-bound)) (defun eqlzt (x y) "Return T if (eql x y) or if both are zero of the same type." (cond ((complexp x) (and (complexp y) (eqlzt (realpart x) (realpart y)) (eqlzt (imagpart x) (imagpart y)))) ((zerop x) (eqlt (abs x) (abs y))) (t (eqlt x y)))) (defconstant +rational-most-negative-short-float+ (rational-safely most-negative-short-float)) (defconstant +rational-most-negative-single-float+ (rational-safely most-negative-single-float)) (defconstant +rational-most-negative-double-float+ (rational-safely most-negative-double-float)) (defconstant +rational-most-negative-long-float+ (rational-safely most-negative-long-float)) (defconstant +rational-most-positive-short-float+ (rational-safely most-positive-short-float)) (defconstant +rational-most-positive-single-float+ (rational-safely most-positive-single-float)) (defconstant +rational-most-positive-double-float+ (rational-safely most-positive-double-float)) (defconstant +rational-most-positive-long-float+ (rational-safely most-positive-long-float)) (defun float-exponent (x) (if (floatp x) (nth-value 1 (decode-float x)) 0)) (defun numbers-are-compatible (x y) (cond ((complexp x) (and (numbers-are-compatible (realpart x) y) (numbers-are-compatible (imagpart x) y))) ((complexp y) (and (numbers-are-compatible x (realpart y)) (numbers-are-compatible x (imagpart y)))) (t (when (floatp x) (rotatef x y)) (or (floatp x) (not (floatp y)) (etypecase y (short-float (<= +rational-most-negative-short-float+ x +rational-most-positive-short-float+)) (single-float (<= +rational-most-negative-single-float+ x +rational-most-positive-single-float+)) (double-float (<= +rational-most-negative-double-float+ x +rational-most-positive-double-float+)) (long-float (<= +rational-most-negative-long-float+ x +rational-most-positive-long-float+))))))) ;;; NOTE! According to section 12.1.4.1, when a rational is compared ;;; to a float, the effect is as if the float is convert to a rational ;;; (by RATIONAL), not as if the rational is converted to a float. ;;; This means the calls to numbers-are-compatible are not necessary. (defun =.4-fn () (loop for x in *numbers* append (loop for y in *numbers* unless (or ;; (not (numbers-are-compatible x y)) (if (= x y) (= y x) (not (= y x)))) collect (list x y)))) (defun /=.4-fn () (loop for x in *numbers* append (loop for y in *numbers* unless (or ;; (not (numbers-are-compatible x y)) (if (/= x y) (/= y x) (not (/= y x)))) collect (list x y)))) (defun /=.4a-fn () (loop for x in *numbers* append (loop for y in *numbers* when (and ;; (numbers-are-compatible x y) (if (= x y) (/= x y) (not (/= x y)))) collect (list x y)))) (defun <.8-fn () (loop for x in *reals* nconc (loop for y in *reals* when (handler-case (and ;; (numbers-are-compatible x y) (and (< x y) (> x y))) (arithmetic-error () nil)) collect (list x y)))) (defun <.9-fn () (loop for x in *reals* nconc (loop for y in *reals* when (handler-case (and ;; (numbers-are-compatible x y) (if (< x y) (not (> y x)) (> y x))) (arithmetic-error () nil)) collect (list x y)))) (defun <.10-fn () (loop for x in *reals* nconc (loop for y in *reals* when (handler-case (and ;; (numbers-are-compatible x y) (if (< x y) (>= x y) (not (>= x y)))) (arithmetic-error () nil)) collect (list x y)))) (defun <=.8-fn () (loop for x in *reals* nconc (loop for y in *reals* when (handler-case (and ;; (numbers-are-compatible x y) (if (<= x y) (not (>= y x)) (>= y x))) (arithmetic-error () nil)) collect (list x y)))) (defun <=.9-fn () (loop for x in *reals* nconc (loop for y in *reals* when (handler-case (and ;; (numbers-are-compatible x y) (if (<= x y) (not (or (= x y) (< x y))) (or (= x y) (< x y)))) (arithmetic-error () nil)) collect (list x y)))) (defun >.8-fn () (loop for x in *reals* nconc (loop for y in *reals* when (handler-case (and ;; (numbers-are-compatible x y) (if (> x y) (<= x y) (not (<= x y)))) (arithmetic-error () nil)) collect (list x y)))) (defun >=.8-fn () (loop for x in *reals* nconc (loop for y in *reals* when (handler-case (and ;; (numbers-are-compatible x y) (if (>= x y) (not (or (= x y) (> x y))) (or (= x y) (> x y)))) (arithmetic-error () nil)) collect (list x y)))) ;;; Comparison of rationsls (defun compare-random-rationals (n m rep) (loop for a = (- (random n) m) for b = (- (random n) m) for c = (- (random n) m) for d = (- (random n) m) repeat rep when (and (/= b 0) (/= d 0) (let ((q1 (/ a b)) (q2 (/ c d)) (ad (* a d)) (bc (* b c))) (when (< (* b d) 0) (setq ad (- ad)) (setq bc (- bc))) (or (if (< q1 q2) (not (< ad bc)) (< ad bc)) (if (<= q1 q2) (not (<= ad bc)) (<= ad bc)) (if (> q1 q2) (not (> ad bc)) (> ad bc)) (if (>= q1 q2) (not (>= ad bc)) (>= ad bc)) (if (= q1 q2) (not (= ad bc)) (= ad bc)) (if (/= q1 q2) (not (/= ad bc)) (/= ad bc))))) collect (list a b c d))) (defun max.2-fn () (loop for x in *reals* nconc (loop for y in *reals* when (numbers-are-compatible x y) unless (handler-case (let ((m (max x y))) (and (>= m x) (>= m y) (or (= m x) (= m y)))) (floating-point-underflow () t) (floating-point-overflow () t)) collect (list x y (max x y))))) (defun min.2-fn () (loop for x in *reals* nconc (loop for y in *reals* when (numbers-are-compatible x y) unless (handler-case (let ((m (min x y))) (and (<= m x) (<= m y) (or (= m x) (= m y)))) (floating-point-underflow () t) (floating-point-overflow () t)) collect (list x y (min x y))))) ;;; Compute the number of digits that can be added to 1.0 in the appropriate ;;; float type, a rational representation of the smallest radix^(-k) s.t. ;;; 1.0 + radix^(-k) /= 1.0, and the float representation of that value. ;;; Note that this will in general be > -epsilon. (defun find-epsilon (x) (assert (floatp x)) (let* ((one (float 1 x)) (radix (float-radix one)) (eps (/ 1 radix))) (loop for next-eps = (/ eps radix) for i from 1 until (eql one (+ one next-eps)) do (setq eps next-eps) finally (return (values i eps (float eps one)))))) (defun test-log-op-with-decls (op xlo xhi ylo yhi niters &optional (decls '((optimize (speed 3) (safety 1) (debug 1))))) "Test that a compiled form of the LOG* function OP computes the expected result on two random integers drawn from the types `(integer ,xlo ,xhi) and `(integer ,ylo ,yhi). Try niters choices. Return a list of pairs on which the test fails." (assert (symbolp op)) (assert (integerp xlo)) (assert (integerp xhi)) (assert (integerp ylo)) (assert (integerp yhi)) (assert (integerp niters)) (assert (<= xlo xhi)) (assert (<= ylo yhi)) (let* ((source `(lambda (x y) (declare (type (integer ,xlo ,xhi) x) (type (integer ,ylo ,yhi) y) ,@ decls) (,op x y))) (fn (compile nil source))) (loop for i below niters for x = (random-from-interval (1+ xhi) xlo) for y = (random-from-interval (1+ yhi) ylo) unless (eql (funcall (the symbol op) x y) (funcall fn x y)) collect (list x y)))) (defun test-log-op (op n1 n2) (flet ((%r () (let ((r (random 33))) (- (random (ash 1 (1+ r))) (ash 1 r))))) (loop for x1 = (%r) for x2 = (%r) for y1 = (%r) for y2 = (%r) repeat n1 nconc (test-log-op-with-decls op (min x1 x2) (max x1 x2) (min y1 y2) (max y1 y2) n2)))) (defun safe-tan (x &optional (default 0.0)) (handler-case (let ((result (multiple-value-list (tan x)))) (assert (null (cdr result))) (car result)) (arithmetic-error () default))) gcl27-2.7.0/ansi-tests/numerator-denominator.lsp000066400000000000000000000046651454061450500216200ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 7 08:24:57 2003 ;;;; Contains: Tests of NUMERATOR, DENOMINATOR (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (deftest numerator.error.1 (signals-error (numerator) program-error) t) (deftest numerator.error.2 (signals-error (numerator 1/2 nil) program-error) t) (deftest denominator.error.1 (signals-error (denominator) program-error) t) (deftest denominator.error.2 (signals-error (denominator 1/2 nil) program-error) t) (deftest numerator-denominator.1 (loop for n = (abs (random-fixnum)) for d = (1+ (abs (random-fixnum))) for g = (gcd n d) for n1 = (/ n g) for d1 = (/ d g) for r = (/ n d) for n2 = (numerator r) for d2 = (denominator r) repeat 1000 unless (and (eql (gcd n1 d1) 1) (>= n1 0) (>= d1 1) (eql n1 n2) (eql d1 d2)) collect (list n1 d1 r n2 d2)) nil) (deftest numerator-denominator.2 (let ((bound (expt 10 20))) (loop for n = (random-from-interval bound 0) for d = (random-from-interval bound 1) for g = (gcd n d) for n1 = (/ n g) for d1 = (/ d g) for r = (/ n d) for n2 = (numerator r) for d2 = (denominator r) repeat 1000 unless (and (eql (gcd n1 d1) 1) (>= n1 0) (>= d1 1) (eql n1 n2) (eql d1 d2)) collect (list n1 d1 r n2 d2))) nil) (deftest numerator-denominator.3 (loop for n = (abs (random-fixnum)) for d = (1+ (abs (random-fixnum))) for g = (gcd n d) for n1 = (/ n g) for d1 = (/ d g) for r = (/ n (- d)) for n2 = (numerator r) for d2 = (denominator r) repeat 1000 unless (and (eql (gcd n1 d1) 1) (>= n1 0) (>= d1 1) (eql n1 (- n2)) (eql d1 d2)) collect (list n1 d1 r n2 d2)) nil) (deftest numerator-denominator.4 (let ((bound (expt 10 20))) (loop for n = (random-from-interval bound 0) for d = (random-from-interval bound 1) for g = (gcd n d) for n1 = (/ n g) for d1 = (/ d g) for r = (/ n (- d)) for n2 = (numerator r) for d2 = (denominator r) repeat 1000 unless (and (eql (gcd n1 d1) 1) (>= n1 0) (>= d1 1) (eql n1 (- n2)) (eql d1 d2)) collect (list n1 d1 r n2 d2))) nil) (deftest numerator-denominator.5 (loop for r in *rationals* for n = (numerator r) for d = (denominator r) unless (and (integerp n) (integerp d) (eql (gcd n d) 1) (>= d 1) (eql (/ n d) r)) collect (list r n d)) nil) gcl27-2.7.0/ansi-tests/nunion.lsp000066400000000000000000000226541454061450500165730ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:42:35 2003 ;;;; Contains: Tests of NUNION (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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")) (defharmless nunion.test-and-test-not.1 (nunion (list 1 4 8 10) (list 1 2 3 9 10 13) :test #'eql :test-not #'eql)) (defharmless nunion.test-and-test-not.2 (nunion (list 1 4 8 10) (list 1 2 3 9 10 13) :test-not #'eql :test #'eql)) ;; 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 (signals-error (nunion) program-error) t) (deftest nunion.error.2 (signals-error (nunion nil) program-error) t) (deftest nunion.error.3 (signals-error (nunion nil nil :bad t) program-error) t) (deftest nunion.error.4 (signals-error (nunion nil nil :key) program-error) t) (deftest nunion.error.5 (signals-error (nunion nil nil 1 2) program-error) t) (deftest nunion.error.6 (signals-error (nunion nil nil :bad t :allow-other-keys nil) program-error) t) (deftest nunion.error.7 (signals-error (nunion (list 1 2) (list 3 4) :test #'identity) program-error) t) (deftest nunion.error.8 (signals-error (nunion (list 1 2) (list 3 4) :test-not #'identity) program-error) t) (deftest nunion.error.9 (signals-error (nunion (list 1 2) (list 3 4) :key #'cons) program-error) t) (deftest nunion.error.10 (signals-error (nunion (list 1 2) (list 3 4) :key #'car) type-error) t) (deftest nunion.error.11 (signals-error (nunion (list 1 2 3) (list* 4 5 6)) type-error) t) (deftest nunion.error.12 (signals-error (nunion (list* 1 2 3) (list 4 5 6)) type-error) t) (deftest nunion.error.13 (check-type-error #'(lambda (x) (nunion x (list 1 2 3))) #'listp) nil) (deftest nunion.error.14 (check-type-error #'(lambda (x) (nunion (list 1 2 3) x)) #'listp) nil) gcl27-2.7.0/ansi-tests/oddp.lsp000066400000000000000000000026631454061450500162110ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 31 10:48:25 2003 ;;;; Contains: Tests of ODDP (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest oddp.error.1 (signals-error (oddp) program-error) t) (deftest oddp.error.2 (signals-error (oddp 0 nil) program-error) t) (deftest oddp.error.3 (check-type-error #'oddp #'integerp) nil) ;;; Non-error tests (deftest oddp.1 (loop for x in *numbers* when (integerp x) do (oddp x)) nil) (deftest oddp.3 (loop for x = (random-fixnum) repeat 10000 when (or (oddp (+ x x)) (not (oddp (+ x x 1))) (if (oddp x) (or (oddp (1+ x)) (oddp (1- x)) (/= (mod x 2) 1)) (or (not (oddp (1+ x))) (not (oddp (1- x))) (/= (mod x 2) 0)))) collect x) nil) (deftest oddp.4 (let ((upper-bound 1000000000000000) (lower-bound -1000000000000000)) (loop for x = (random-from-interval upper-bound lower-bound) repeat 10000 when (or (oddp (+ x x)) (not (oddp (+ x x 1))) (if (oddp x) (or (oddp (1+ x)) (oddp (1- x)) (/= (mod x 2) 1)) (or (not (oddp (1+ x))) (not (oddp (1- x))) (/= (mod x 2) 0)))) collect x)) nil) (deftest oddp.5 (notnot-mv (oddp 1)) t) (deftest oddp.6 (oddp 0) nil) (deftest oddp.7 (notnot-mv (oddp 100000000000000000000000000000001)) t) (deftest oddp.8 (oddp 100000000000000000000000000000000) nil) gcl27-2.7.0/ansi-tests/oneminus.lsp000066400000000000000000000070131454061450500171120ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Sep 1 20:14:34 2003 ;;;; Contains: Tests of 1- (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest 1-.error.1 (signals-error (1-) program-error) t) (deftest 1-.error.2 (signals-error (1- 0 0) program-error) t) (deftest 1-.error.3 (signals-error (1- 0 nil nil) program-error) t) ;;; Non-error tests (deftest 1-.1 (loop for x = (random-fixnum) for y = (1- x) for z = (- x 1) repeat 1000 unless (eql y z) collect (list x y z)) nil) (deftest 1-.2 (loop for x = (random-from-interval (ash 1 1000)) for y = (1- x) for z = (- x 1) repeat 1000 unless (eql y z) collect (list x y z)) nil) (deftest 1-.3 (loop for x = (random (1- most-positive-short-float)) for y = (1- x) for z = (- x 1.0s0) repeat 1000 unless (eql y z) collect (list x y z)) nil) (deftest 1-.4 (loop for x = (random (1- most-positive-single-float)) for y = (1- x) for z = (- x 1.0f0) repeat 1000 unless (eql y z) collect (list x y z)) nil) (deftest 1-.5 (loop for x = (random (1- most-positive-double-float)) for y = (1- x) for z = (- x 1.0d0) repeat 1000 unless (eql y z) collect (list x y z)) nil) (deftest 1-.6 (loop for x = (random (1- most-positive-long-float)) for y = (1- x) for z = (- x 1.0l0) repeat 1000 unless (eql y z) collect (list x y z)) nil) (deftest 1-.7 (loop for x = (random-fixnum) for y = (random-fixnum) for y2 = (if (zerop y) 1 y) for r = (/ x y2) for r1 = (1- r) for r2 = (- r 1) repeat 1000 unless (eql r1 r2) collect (list x y2 r1 r2)) nil) (deftest 1-.8 (let ((bound (ash 1 200))) (loop for x = (random-from-interval bound) for y = (random-from-interval bound) for y2 = (if (zerop y) 1 y) for r = (/ x y2) for r1 = (1- r) for r2 = (- r 1) repeat 1000 unless (eql r1 r2) collect (list x y2 r1 r2))) nil) ;;; Complex numbers (deftest 1-.9 (loop for xr = (random-fixnum) for xi = (random-fixnum) for xc = (complex xr xi) for xc1 = (1- xc) repeat 1000 unless (eql xc1 (complex (- xr 1) xi)) collect (list xr xi xc xc1)) nil) (deftest 1-.10 (let ((bound (ash 1 100))) (loop for xr = (random-from-interval bound) for xi = (random-from-interval bound) for xc = (complex xr xi) for xc1 = (1- xc) repeat 1000 unless (eql xc1 (complex (- xr 1) xi)) collect (list xr xi xc xc1))) nil) (deftest 1-.11 (let ((bound (1- most-positive-short-float))) (loop for xr = (random bound) for xi = (random bound) for xc = (complex xr xi) for xc1 = (1- xc) repeat 1000 unless (eql xc1 (complex (- xr 1) xi)) collect (list xr xi xc xc1))) nil) (deftest 1-.12 (let ((bound (1- most-positive-single-float))) (loop for xr = (random bound) for xi = (random bound) for xc = (complex xr xi) for xc1 = (1- xc) repeat 1000 unless (eql xc1 (complex (- xr 1) xi)) collect (list xr xi xc xc1))) nil) (deftest 1-.13 (let ((bound (1- most-positive-double-float))) (loop for xr = (random bound) for xi = (random bound) for xc = (complex xr xi) for xc1 = (1- xc) repeat 1000 unless (eql xc1 (complex (- xr 1) xi)) collect (list xr xi xc xc1))) nil) (deftest 1-.14 (let ((bound (1- most-positive-long-float))) (loop for xr = (random bound) for xi = (random bound) for xc = (complex xr xi) for xc1 = (1- xc) repeat 1000 unless (eql xc1 (complex (- xr 1) xi)) collect (list xr xi xc xc1))) nil) (deftest 1-.15 (macrolet ((%m (z) z)) (1- (expand-in-current-env (%m 2)))) 1) gcl27-2.7.0/ansi-tests/oneplus.lsp000066400000000000000000000067441454061450500167540ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Sep 1 19:53:34 2003 ;;;; Contains: Tests of 1+ (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (deftest 1+.error.1 (signals-error (1+) program-error) t) (deftest 1+.error.2 (signals-error (1+ 0 0) program-error) t) (deftest 1+.error.3 (signals-error (1+ 0 nil nil) program-error) t) (deftest 1+.1 (loop for x = (random-fixnum) for y = (1+ x) for z = (+ x 1) repeat 1000 unless (eql y z) collect (list x y z)) nil) (deftest 1+.2 (loop for x = (random-from-interval (ash 1 1000)) for y = (1+ x) for z = (+ x 1) repeat 1000 unless (eql y z) collect (list x y z)) nil) (deftest 1+.3 (loop for x = (random (1- most-positive-short-float)) for y = (1+ x) for z = (+ x 1.0s0) repeat 1000 unless (eql y z) collect (list x y z)) nil) (deftest 1+.4 (loop for x = (random (1- most-positive-single-float)) for y = (1+ x) for z = (+ x 1.0f0) repeat 1000 unless (eql y z) collect (list x y z)) nil) (deftest 1+.5 (loop for x = (random (1- most-positive-double-float)) for y = (1+ x) for z = (+ x 1.0d0) repeat 1000 unless (eql y z) collect (list x y z)) nil) (deftest 1+.6 (loop for x = (random (1- most-positive-long-float)) for y = (1+ x) for z = (+ x 1.0l0) repeat 1000 unless (eql y z) collect (list x y z)) nil) (deftest 1+.7 (loop for x = (random-fixnum) for y = (random-fixnum) for y2 = (if (zerop y) 1 y) for r = (/ x y2) for r1 = (1+ r) for r2 = (+ r 1) repeat 1000 unless (eql r1 r2) collect (list x y2 r1 r2)) nil) (deftest 1+.8 (let ((bound (ash 1 200))) (loop for x = (random-from-interval bound) for y = (random-from-interval bound) for y2 = (if (zerop y) 1 y) for r = (/ x y2) for r1 = (1+ r) for r2 = (+ r 1) repeat 1000 unless (eql r1 r2) collect (list x y2 r1 r2))) nil) ;;; Complex numbers (deftest 1+.9 (loop for xr = (random-fixnum) for xi = (random-fixnum) for xc = (complex xr xi) for xc1 = (1+ xc) repeat 1000 unless (eql xc1 (complex (+ xr 1) xi)) collect (list xr xi xc xc1)) nil) (deftest 1+.10 (let ((bound (ash 1 100))) (loop for xr = (random-from-interval bound) for xi = (random-from-interval bound) for xc = (complex xr xi) for xc1 = (1+ xc) repeat 1000 unless (eql xc1 (complex (+ xr 1) xi)) collect (list xr xi xc xc1))) nil) (deftest 1+.11 (let ((bound (1- most-positive-short-float))) (loop for xr = (random bound) for xi = (random bound) for xc = (complex xr xi) for xc1 = (1+ xc) repeat 1000 unless (eql xc1 (complex (+ xr 1) xi)) collect (list xr xi xc xc1))) nil) (deftest 1+.12 (let ((bound (1- most-positive-single-float))) (loop for xr = (random bound) for xi = (random bound) for xc = (complex xr xi) for xc1 = (1+ xc) repeat 1000 unless (eql xc1 (complex (+ xr 1) xi)) collect (list xr xi xc xc1))) nil) (deftest 1+.13 (let ((bound (1- most-positive-double-float))) (loop for xr = (random bound) for xi = (random bound) for xc = (complex xr xi) for xc1 = (1+ xc) repeat 1000 unless (eql xc1 (complex (+ xr 1) xi)) collect (list xr xi xc xc1))) nil) (deftest 1+.14 (let ((bound (1- most-positive-long-float))) (loop for xr = (random bound) for xi = (random bound) for xc = (complex xr xi) for xc1 = (1+ xc) repeat 1000 unless (eql xc1 (complex (+ xr 1) xi)) collect (list xr xi xc xc1))) nil) (deftest 1+.15 (macrolet ((%m (z) z)) (1+ (expand-in-current-env (%m 1)))) 2) gcl27-2.7.0/ansi-tests/open-stream-p.lsp000066400000000000000000000024131454061450500177430ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 13 19:52:30 2004 ;;;; Contains: Tests of OPEN-STREAM-P (in-package :cl-test) (deftest open-stream-p.1 (loop for s in (list *debug-io* *error-output* *query-io* *standard-input* *standard-output* *trace-output* *terminal-io*) for results = (multiple-value-list (open-stream-p s)) unless (and (eql (length results) 1) (car results)) collect s) nil) (deftest open-stream-p.2 (with-open-file (s "open-stream-p.lsp" :direction :input) (notnot-mv (open-stream-p s))) t) (deftest open-stream-p.3 (with-open-file (s "foo.txt" :direction :output :if-exists :supersede) (notnot-mv (open-stream-p s))) t) (deftest open-stream-p.4 (let ((s (open "open-stream-p.lsp" :direction :input))) (close s) (open-stream-p s)) nil) (deftest open-stream-p.5 (let ((s (open "foo.txt" :direction :output :if-exists :supersede))) (close s) (open-stream-p s)) nil) ;;; error tests (deftest open-stream-p.error.1 (signals-error (open-stream-p) program-error) t) (deftest open-stream-p.error.2 (signals-error (open-stream-p *standard-input* nil) program-error) t) (deftest open-stream-p.error.3 (check-type-error #'open-stream-p #'streamp) nil) gcl27-2.7.0/ansi-tests/open.lsp000066400000000000000000001072321454061450500162220ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Jan 23 05:36:55 2004 ;;;; Contains: Tests of OPEN (in-package :cl-test) ;;; Input streams (defun generator-for-element-type (type) (etypecase type ((member character base-char) #'(lambda (i) (aref "abcdefghijklmnopqrstuvwxyz" (mod i 26)))) ((member signed-byte unsigned-byte bit) #'(lambda (i) (logand i 1))) (cons (let ((op (car type)) (arg1 (cadr type)) (arg2 (caddr type))) (ecase op (unsigned-byte (let ((mask (1- (ash 1 arg1)))) #'(lambda (i) (logand i mask)))) (signed-byte (let ((mask (1- (ash 1 (1- arg1))))) #'(lambda (i) (logand i mask)))) (integer (let* ((lo arg1) (hi arg2) (lower-bound (etypecase lo (integer lo) (cons (1+ (car lo))))) (upper-bound (etypecase hi (integer hi) (cons (1- (car hi))))) (range (1+ (- upper-bound lower-bound)))) #'(lambda (i) (+ lower-bound (mod i range)))))))))) (compile 'generator-for-element-type) (defmacro def-open-test (name args form expected &key (notes nil notes-p) (build-form nil build-form-p) (element-type 'character element-type-p) (pathname #p"tmp.dat")) (when element-type-p (setf args (append args (list :element-type `',element-type)))) (unless build-form-p (let ((write-element-form (cond ((subtypep element-type 'integer) `(write-byte (funcall (the function (generator-for-element-type ',element-type)) i) os)) ((subtypep element-type 'character) `(write-char (funcall (the function (generator-for-element-type ',element-type)) i) os))))) (setq build-form `(with-open-file (os pn :direction :output ,@(if element-type-p `(:element-type ',element-type)) :if-exists :supersede) (assert (open-stream-p os)) (dotimes (i 10) ,write-element-form) (finish-output os) )))) `(deftest ,name ,@(when notes-p `(:notes ,notes)) (let ((pn ,pathname)) (delete-all-versions pn) ,build-form (let ((s (open pn ,@args))) (unwind-protect (progn (assert (open-stream-p s)) (assert (typep s 'file-stream)) ,@ (unless (member element-type '(signed-byte unsigned-byte)) #-allegro `((assert (subtypep ',element-type (stream-element-type s)))) #+allegro nil ) ,form) (close s)))) ,@expected)) ;; (compile 'def-open-test) (def-open-test open.1 () (values (read-line s nil)) ("abcdefghij")) (def-open-test open.2 (:direction :input) (values (read-line s nil)) ("abcdefghij") :element-type character) (def-open-test open.3 (:direction :input) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.4 (:direction :input) (values (read-line s nil)) ("abcdefghij") :element-type base-char) (def-open-test open.5 (:if-exists :error) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.6 (:if-exists :error :direction :input) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.7 (:if-exists :new-version) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.8 (:if-exists :new-version :direction :input) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.9 (:if-exists :rename) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.10 (:if-exists :rename :direction :input) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.11 (:if-exists :rename-and-delete) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.12 (:if-exists :rename-and-delete :direction :input) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.13 (:if-exists :overwrite) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.14 (:if-exists :overwrite :direction :input) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.15 (:if-exists :append) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.16 (:if-exists :append :direction :input) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.17 (:if-exists :supersede) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.18 (:if-exists :supersede :direction :input) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.19 (:if-exists nil) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.20 (:if-exists nil :direction :input) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.21 (:if-does-not-exist nil) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.22 (:if-does-not-exist nil :direction :input) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.23 (:if-does-not-exist :error) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.24 (:if-does-not-exist :error :direction :input) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.25 (:if-does-not-exist :create) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.26 (:if-does-not-exist :create :direction :input) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.27 (:external-format :default) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.28 (:external-format :default :direction :input) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.29 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 0 1 0 1 0 1 0 1)) :element-type (unsigned-byte 1)) (def-open-test open.30 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 0 1 0 1 0 1 0 1)) :element-type (unsigned-byte 1)) (def-open-test open.31 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 0 1 2 3 0 1)) :element-type (unsigned-byte 2)) (def-open-test open.32 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 0 1 2 3 0 1)) :element-type (unsigned-byte 2)) (def-open-test open.33 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 0 1)) :element-type (unsigned-byte 3)) (def-open-test open.34 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 0 1)) :element-type (unsigned-byte 3)) (def-open-test open.35 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 4)) (def-open-test open.36 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 4)) (def-open-test open.37 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 5)) (def-open-test open.38 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 5)) (def-open-test open.39 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 6)) (def-open-test open.40 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 6)) (def-open-test open.41 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 7)) (def-open-test open.42 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 7)) (def-open-test open.43 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 8)) (def-open-test open.44 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 8)) (def-open-test open.45 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 9)) (def-open-test open.46 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 9)) (def-open-test open.47 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 10)) (def-open-test open.48 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 10)) (def-open-test open.49 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 20)) (def-open-test open.50 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 20)) (def-open-test open.51 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 25)) (def-open-test open.52 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 25)) (def-open-test open.53 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 30)) (def-open-test open.54 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 30)) (def-open-test open.55 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 32)) (def-open-test open.56 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 32)) (def-open-test open.57 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 33)) (def-open-test open.58 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 33)) (def-open-test open.59 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 0 1 0 1 0 1 0 1)) :element-type unsigned-byte) (def-open-test open.60 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 0 1 0 1 0 1 0 1)) :element-type unsigned-byte) (def-open-test open.61 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 0 1 0 1 0 1 0 1)) :element-type signed-byte) (def-open-test open.62 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 0 1 0 1 0 1 0 1)) :element-type signed-byte) (def-open-test open.63 () (values (read-line s nil)) ("abcdefghij") :pathname "tmp.dat") (def-open-test open.64 () (values (read-line s nil)) ("abcdefghij") :pathname (logical-pathname "CLTEST:TMP.DAT")) ;;; It works on recognizable subtypes. (deftest open.65 (let ((type '(or (integer 0 1) (integer 100 200))) (pn #p"tmp.dat") (vals '(0 1 100 120 130 190 200 1 0 150))) (or (not (subtypep type 'integer)) (progn (with-open-file (os pn :direction :output :element-type type :if-exists :supersede) (dolist (e vals) (write-byte e os))) (let ((s (open pn :direction :input :element-type type)) (seq (make-array 10))) (unwind-protect (progn (read-sequence seq s) seq) (close s)) (notnot (every #'eql seq vals)))))) t) ;;; FIXME: Add -- tests for when the filespec is a stream (deftest open.66 (let ((pn #p"tmp.dat")) (delete-all-versions pn) (with-open-file (s pn :direction :io :if-exists :rename-and-delete :if-does-not-exist :create) (format s "some stuff~%") (finish-output s) (let ((is (open s :direction :input))) (unwind-protect (values (read-char is) (notnot (file-position s :start)) (read-line is) (read-line s)) (close is))))) #\s t "ome stuff" "some stuff") (deftest open.67 (let ((pn #p"tmp.dat")) (delete-all-versions pn) (let ((s (open pn :direction :output))) (unwind-protect (progn (format s "some stuff~%") (finish-output s) (close s) (let ((is (open s :direction :input))) (unwind-protect (values (read-line is)) (close is)))) (when (open-stream-p s) (close s))))) "some stuff") ;;; FIXME: Add -- tests for when element-type is :default ;;; Tests of file creation (defmacro def-open-output-test (name args form expected &rest keyargs &key (element-type 'character) (build-form `(dotimes (i 10) ,(cond ((subtypep element-type 'integer) `(write-byte (funcall (the function (generator-for-element-type ',element-type)) i) s)) ((subtypep element-type 'character) `(write-char (funcall (the function (generator-for-element-type ',element-type)) i) s))))) &allow-other-keys) `(def-open-test ,name (:direction :output ,@args) (progn ,build-form (assert (output-stream-p s)) ,form) ,expected :build-form nil ,@keyargs)) ;; (compile 'def-open-output-test) (def-open-output-test open.output.1 () (progn (close s) (with-open-file (is #p"tmp.dat") (values (read-line is nil)))) ("abcdefghij")) (def-open-output-test open.output.2 () (progn (close s) (with-open-file (is "tmp.dat") (values (read-line is nil)))) ("abcdefghij") :pathname "tmp.dat") (def-open-output-test open.output.3 () (progn (close s) (with-open-file (is (logical-pathname "CLTEST:TMP.DAT")) (values (read-line is nil)))) ("abcdefghij") :pathname (logical-pathname "CLTEST:TMP.DAT")) (def-open-output-test open.output.4 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type 'character) (values (read-line is nil)))) ("abcdefghij") :element-type character) (def-open-output-test open.output.5 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type 'base-char) (values (read-line is nil)))) ("abcdefghij") :element-type base-char) (def-open-output-test open.output.6 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type '(integer 0 1)) (let ((seq (make-array 10))) (read-sequence seq is) seq))) (#(0 1 0 1 0 1 0 1 0 1)) :element-type (integer 0 1)) (def-open-output-test open.output.7 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type 'bit) (let ((seq (make-array 10))) (read-sequence seq is) seq))) (#(0 1 0 1 0 1 0 1 0 1)) :element-type bit) (def-open-output-test open.output.8 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type '(unsigned-byte 1)) (let ((seq (make-array 10))) (read-sequence seq is) seq))) (#(0 1 0 1 0 1 0 1 0 1)) :element-type (unsigned-byte 1)) (def-open-output-test open.output.9 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type '(unsigned-byte 2)) (let ((seq (make-array 10))) (read-sequence seq is) seq))) (#(0 1 2 3 0 1 2 3 0 1)) :element-type (unsigned-byte 2)) (def-open-output-test open.output.10 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type '(unsigned-byte 3)) (let ((seq (make-array 10))) (read-sequence seq is) seq))) (#(0 1 2 3 4 5 6 7 0 1)) :element-type (unsigned-byte 3)) (def-open-output-test open.output.11 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type '(unsigned-byte 4)) (let ((seq (make-array 10))) (read-sequence seq is) seq))) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 4)) (def-open-output-test open.output.12 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type '(unsigned-byte 6)) (let ((seq (make-array 10))) (read-sequence seq is) seq))) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 6)) (def-open-output-test open.output.13 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type '(unsigned-byte 8)) (let ((seq (make-array 10))) (read-sequence seq is) seq))) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 8)) (def-open-output-test open.output.14 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type '(unsigned-byte 12)) (let ((seq (make-array 10))) (read-sequence seq is) seq))) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 12)) (def-open-output-test open.output.15 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type '(unsigned-byte 16)) (let ((seq (make-array 10))) (read-sequence seq is) seq))) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 16)) (def-open-output-test open.output.16 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type '(unsigned-byte 24)) (let ((seq (make-array 10))) (read-sequence seq is) seq))) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 24)) (def-open-output-test open.output.17 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type '(unsigned-byte 32)) (let ((seq (make-array 10))) (read-sequence seq is) seq))) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 32)) (def-open-output-test open.output.18 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type '(unsigned-byte 64)) (let ((seq (make-array 10))) (read-sequence seq is) seq))) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 64)) (def-open-output-test open.output.19 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type '(unsigned-byte 100)) (let ((seq (make-array 10))) (read-sequence seq is) seq))) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 100)) (deftest open.output.20 (let ((pn #p"tmp.dat")) (with-open-file (s pn :direction :output :if-exists :supersede)) (open pn :direction :output :if-exists nil)) nil) (def-open-test open.output.21 (:if-exists :new-version :direction :output) (progn (write-sequence "wxyz" s) (close s) (with-open-file (s pn :direction :input) (values (read-line s nil)))) ("wxyz") :notes (:open-if-exists-new-version-no-error) ) (def-open-test open.output.22 (:if-exists :rename :direction :output) (progn (write-sequence "wxyz" s) (close s) (with-open-file (s pn :direction :input) (values (read-line s nil)))) ("wxyz")) (def-open-test open.output.23 (:if-exists :rename-and-delete :direction :output) (progn (write-sequence "wxyz" s) (close s) (with-open-file (s pn :direction :input) (values (read-line s nil)))) ("wxyz")) (def-open-test open.output.24 (:if-exists :overwrite :direction :output) (progn (write-sequence "wxyz" s) (close s) (with-open-file (s pn :direction :input) (values (read-line s nil)))) ("wxyzefghij")) (def-open-test open.output.25 (:if-exists :append :direction :output) (progn (write-sequence "wxyz" s) (close s) (with-open-file (s pn :direction :input) (values (read-line s nil)))) ("abcdefghijwxyz")) (def-open-test open.output.26 (:if-exists :supersede :direction :output) (progn (write-sequence "wxyz" s) (close s) (with-open-file (s pn :direction :input) (values (read-line s nil)))) ("wxyz")) (def-open-output-test open.output.27 (:if-does-not-exist :create :direction :output) (progn (close s) (with-open-file (is pn :direction :input) (values (read-line is nil)))) ("abcdefghij")) (deftest open.output.28 (let ((pn #p"tmp.dat")) (delete-all-versions pn) (open pn :direction :output :if-does-not-exist nil)) nil) (def-open-output-test open.output.28a (:external-format :default) (progn (close s) (with-open-file (is #p"tmp.dat") (values (read-line is nil)))) ("abcdefghij")) (def-open-output-test open.output.29 (:external-format (prog1 (with-open-file (s "foo.dat" :direction :output :if-exists :supersede) (stream-external-format s)) (delete-all-versions "foo.dat") )) (progn (close s) (with-open-file (is #p"tmp.dat") (values (read-line is nil)))) ("abcdefghij")) ;;; Default behavior of open :if-exists is :create when the version ;;; of the filespec is :newest (deftest open.output.30 :notes (:open-if-exists-new-version-no-error) (let ((pn (make-pathname :name "tmp" :type "dat" :version :newest))) (or (not (eql (pathname-version pn) :newest)) (progn ;; Create file (let ((s1 (open pn :direction :output :if-exists :overwrite :if-does-not-exist :create))) (unwind-protect ;; Now try again (let ((s2 (open pn :direction :output))) (unwind-protect (write-line "abcdef" s2) (close s2)) (unwind-protect (progn (setq s2 (open s1 :direction :input)) (equalt (read-line s2 nil) "abcdef")) (close s2))) (close s1) (delete-all-versions pn) ))))) t) (def-open-output-test open.output.31 (:if-exists :rename :direction :output) (progn (close s) (with-open-file (is pn :direction :input) (values (read-line is nil)))) ("abcdefghij")) (def-open-output-test open.output.32 (:if-exists :rename-and-delete :direction :output) (progn (close s) (with-open-file (is pn :direction :input) (values (read-line is nil)))) ("abcdefghij")) (def-open-output-test open.output.33 (:if-exists :new-version :direction :output) (progn (close s) (with-open-file (is pn :direction :input) (values (read-line is nil)))) ("abcdefghij")) (def-open-output-test open.output.34 (:if-exists :supersede :direction :output) (progn (close s) (with-open-file (is pn :direction :input) (values (read-line is nil)))) ("abcdefghij")) (def-open-output-test open.output.35 (:if-exists nil :direction :output) (progn (close s) (with-open-file (is pn :direction :input) (values (read-line is nil)))) ("abcdefghij")) ;;; Add -- tests for when the filespec is a stream ;;; Tests of bidirectional IO (defmacro def-open-io-test (name args form expected &rest keyargs &key (element-type 'character) (build-form `(dotimes (i 10) ,(cond ((subtypep element-type 'integer) `(write-byte (funcall (the function (generator-for-element-type ',element-type)) i) s)) ((subtypep element-type 'character) `(write-char (funcall (the function (generator-for-element-type ',element-type)) i) s))))) &allow-other-keys) `(def-open-test ,name (:direction :io ,@args) (progn ,build-form (assert (input-stream-p s)) (assert (output-stream-p s)) ,form) ,expected :build-form nil ,@keyargs)) ;; (compile 'def-open-io-test) (def-open-io-test open.io.1 () (progn (file-position s :start) (values (read-line s nil))) ("abcdefghij")) (def-open-io-test open.io.2 () (progn (file-position s :start) (values (read-line s nil))) ("abcdefghij") :pathname "tmp.dat") (def-open-io-test open.io.3 () (progn (file-position s :start) (values (read-line s nil))) ("abcdefghij") :pathname (logical-pathname "CLTEST:TMP.DAT")) (def-open-io-test open.io.4 () (progn (file-position s :start) (values (read-line s nil))) ("abcdefghij") :element-type character) (def-open-io-test open.io.5 () (progn (file-position s :start) (values (read-line s nil))) ("abcdefghij") :element-type base-char) (def-open-io-test open.io.6 () (progn (file-position s :start) (let ((seq (make-array 10))) (read-sequence seq s) seq)) (#(0 1 0 1 0 1 0 1 0 1)) :element-type (integer 0 1)) (def-open-io-test open.io.7 () (progn (file-position s :start) (let ((seq (make-array 10))) (read-sequence seq s) seq)) (#(0 1 0 1 0 1 0 1 0 1)) :element-type bit) (def-open-io-test open.io.8 () (progn (file-position s :start) (let ((seq (make-array 10))) (read-sequence seq s) seq)) (#(0 1 0 1 0 1 0 1 0 1)) :element-type (unsigned-byte 1)) (def-open-io-test open.io.9 () (progn (file-position s :start) (let ((seq (make-array 10))) (read-sequence seq s) seq)) (#(0 1 2 3 0 1 2 3 0 1)) :element-type (unsigned-byte 2)) (def-open-io-test open.io.10 () (progn (file-position s :start) (let ((seq (make-array 10))) (read-sequence seq s) seq)) (#(0 1 2 3 4 5 6 7 0 1)) :element-type (unsigned-byte 3)) (def-open-io-test open.io.11 () (progn (file-position s :start) (let ((seq (make-array 10))) (read-sequence seq s) seq)) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 4)) (def-open-io-test open.io.12 () (progn (file-position s :start) (let ((seq (make-array 10))) (read-sequence seq s) seq)) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 6)) (def-open-io-test open.io.13 () (progn (file-position s :start) (let ((seq (make-array 10))) (read-sequence seq s) seq)) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 8)) (def-open-io-test open.io.14 () (progn (file-position s :start) (let ((seq (make-array 10))) (read-sequence seq s) seq)) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 12)) (def-open-io-test open.io.15 () (progn (file-position s :start) (let ((seq (make-array 10))) (read-sequence seq s) seq)) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 16)) (def-open-io-test open.io.16 () (progn (file-position s :start) (let ((seq (make-array 10))) (read-sequence seq s) seq)) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 24)) (def-open-io-test open.io.17 () (progn (file-position s :start) (let ((seq (make-array 10))) (read-sequence seq s) seq)) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 32)) (def-open-io-test open.io.18 () (progn (file-position s :start) (let ((seq (make-array 10))) (read-sequence seq s) seq)) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 64)) (def-open-io-test open.io.19 () (progn (file-position s :start) (let ((seq (make-array 10))) (read-sequence seq s) seq)) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 100)) (deftest open.io.20 (let ((pn #p"tmp.dat")) (with-open-file (s pn :direction :io :if-exists :supersede)) (open pn :direction :io :if-exists nil)) nil) (def-open-test open.io.21 (:if-exists :new-version :direction :io) (progn (write-sequence "wxyz" s) (file-position s :start) (values (read-line s nil))) ("wxyz") :notes (:open-if-exists-new-version-no-error) ) (def-open-test open.io.22 (:if-exists :rename :direction :io) (progn (write-sequence "wxyz" s) (file-position s :start) (values (read-line s nil))) ("wxyz")) (def-open-test open.io.23 (:if-exists :rename-and-delete :direction :io) (progn (write-sequence "wxyz" s) (file-position s :start) (values (read-line s nil))) ("wxyz")) (def-open-test open.io.24 (:if-exists :overwrite :direction :io) (progn (write-sequence "wxyz" s) (file-position s :start) (values (read-line s nil))) ("wxyzefghij")) (def-open-test open.io.25 (:if-exists :append :direction :io) (progn (write-sequence "wxyz" s) (file-position s :start) (values (read-line s nil))) ("abcdefghijwxyz")) (def-open-test open.io.26 (:if-exists :supersede :direction :io) (progn (write-sequence "wxyz" s) (file-position s :start) (values (read-line s nil))) ("wxyz")) (def-open-io-test open.io.27 (:if-does-not-exist :create :direction :io) (progn (file-position s :start) (values (read-line s nil))) ("abcdefghij")) (deftest open.io.28 (let ((pn #p"tmp.dat")) (delete-all-versions pn) (open pn :direction :io :if-does-not-exist nil)) nil) (def-open-io-test open.io.28a (:external-format :default) (progn (file-position s :start) (values (read-line s nil))) ("abcdefghij")) (def-open-io-test open.io.29 (:external-format (prog1 (with-open-file (s "foo.dat" :direction :io :if-exists :supersede) (stream-external-format s)) (delete-all-versions "foo.dat") )) (progn (file-position s :start) (values (read-line s nil))) ("abcdefghij")) ;;; Default behavior of open :if-exists is :create when the version ;;; of the filespec is :newest (deftest open.io.30 :notes (:open-if-exists-new-version-no-error) (let ((pn (make-pathname :name "tmp" :type "dat" :version :newest))) (or (not (eql (pathname-version pn) :newest)) (progn ;; Create file (let ((s1 (open pn :direction :io :if-exists :overwrite :if-does-not-exist :create))) (unwind-protect ;; Now try again (let ((s2 (open pn :direction :io))) (unwind-protect (write-line "abcdef" s2) (close s2)) (unwind-protect (progn (setq s2 (open s1 :direction :input)) (equalt (read-line s2 nil) "abcdef")) (close s2))) (close s1) (delete-all-versions pn) ))))) t) (def-open-io-test open.io.31 (:if-exists :rename :direction :io) (progn (file-position s :start) (values (read-line s nil))) ("abcdefghij")) (def-open-io-test open.io.32 (:if-exists :rename-and-delete :direction :io) (progn (file-position s :start) (values (read-line s nil))) ("abcdefghij")) (def-open-io-test open.io.33 (:if-exists :new-version :direction :io) (progn (file-position s :start) (values (read-line s nil))) ("abcdefghij")) (def-open-io-test open.io.34 (:if-exists :supersede :direction :io) (progn (file-position s :start) (values (read-line s nil))) ("abcdefghij")) (def-open-io-test open.io.35 (:if-exists nil :direction :io) (progn (file-position s :start) (values (read-line s nil))) ("abcdefghij")) ;;;; :PROBE tests (defmacro def-open-probe-test (name args form &key (build-form nil build-form-p) (pathname #p"tmp.dat")) (unless build-form-p (setf build-form `(with-open-file (s pn :direction :output :if-exists :supersede)))) `(deftest ,name (let ((pn ,pathname)) (delete-all-versions pn) ,build-form (let ((s (open pn :direction :probe ,@args))) (values ,(if build-form `(and (typep s 'file-stream) (not (open-stream-p s)) ) `(not s)) ,form))) t t)) (def-open-probe-test open.probe.1 () t) (def-open-probe-test open.probe.2 (:if-exists :error) t) (def-open-probe-test open.probe.3 (:if-exists :new-version) t) (def-open-probe-test open.probe.4 (:if-exists :rename) t) (def-open-probe-test open.probe.5 (:if-exists :rename-and-delete) t) (def-open-probe-test open.probe.6 (:if-exists :overwrite) t) (def-open-probe-test open.probe.7 (:if-exists :append) t) (def-open-probe-test open.probe.8 (:if-exists :supersede) t) (def-open-probe-test open.probe.9 (:if-does-not-exist :error) t) (def-open-probe-test open.probe.10 (:if-does-not-exist nil) t) (def-open-probe-test open.probe.11 (:if-does-not-exist :create) t) (def-open-probe-test open.probe.12 () t :build-form nil) (def-open-probe-test open.probe.13 (:if-exists :error) t :build-form nil) (def-open-probe-test open.probe.14 (:if-exists :new-version) t :build-form nil) (def-open-probe-test open.probe.15 (:if-exists :rename) t :build-form nil) (def-open-probe-test open.probe.16 (:if-exists :rename-and-delete) t :build-form nil) (def-open-probe-test open.probe.17 (:if-exists :overwrite) t :build-form nil) (def-open-probe-test open.probe.18 (:if-exists :append) t :build-form nil) (def-open-probe-test open.probe.19 (:if-exists :supersede) t :build-form nil) (def-open-probe-test open.probe.20 (:if-does-not-exist nil) t :build-form nil) (deftest open.probe.21 (let ((pn #p"tmp.dat")) (delete-all-versions pn) (let ((s (open pn :direction :probe :if-does-not-exist :create))) (values (notnot s) (notnot (probe-file pn))))) t t) (deftest open.probe.22 (let ((pn #p"tmp.dat")) (delete-all-versions pn) (let ((s (open pn :direction :probe :if-does-not-exist :create :if-exists :error))) (values (notnot s) (notnot (probe-file pn))))) t t) (def-open-probe-test open.probe.23 (:external-format :default) t) (def-open-probe-test open.probe.24 (:element-type 'character) t) (def-open-probe-test open.probe.25 (:element-type 'bit) t) (def-open-probe-test open.probe.26 (:element-type '(unsigned-byte 2)) t) (def-open-probe-test open.probe.27 (:element-type '(unsigned-byte 4)) t) (def-open-probe-test open.probe.28 (:element-type '(unsigned-byte 8)) t) (def-open-probe-test open.probe.29 (:element-type '(unsigned-byte 9)) t) (def-open-probe-test open.probe.30 (:element-type '(unsigned-byte 15)) t) (def-open-probe-test open.probe.31 (:element-type '(unsigned-byte 16)) t) (def-open-probe-test open.probe.32 (:element-type '(unsigned-byte 17)) t) (def-open-probe-test open.probe.33 (:element-type '(unsigned-byte 31)) t) (def-open-probe-test open.probe.34 (:element-type '(unsigned-byte 32)) t) (def-open-probe-test open.probe.35 (:element-type '(unsigned-byte 33)) t) (def-open-probe-test open.probe.36 (:element-type '(integer -1002 13112)) t) ;;;; Error tests (deftest open.error.1 (signals-error (open) program-error) t) (deftest open.error.2 (signals-error-always (let ((pn #p"tmp.dat")) (close (open pn :direction :output :if-does-not-exist :create)) (open pn :if-exists :error :direction :output)) file-error) t t) (deftest open.error.3 (signals-error-always (let ((pn #p"tmp.dat")) (close (open pn :direction :output :if-does-not-exist :create)) (open pn :if-exists :error :direction :io)) file-error) t t) (deftest open.error.4 (signals-error-always (let ((pn #p"tmp.dat")) (delete-all-versions pn) (open pn)) file-error) t t) (deftest open.error.5 (signals-error-always (let ((pn #p"tmp.dat")) (delete-all-versions pn) (open pn :if-does-not-exist :error)) file-error) t t) (deftest open.error.6 (signals-error-always (let ((pn #p"tmp.dat")) (delete-all-versions pn) (open pn :direction :input)) file-error) t t) (deftest open.error.7 (signals-error-always (let ((pn #p"tmp.dat")) (delete-all-versions pn) (open pn :if-does-not-exist :error :direction :input)) file-error) t t) (deftest open.error.8 (signals-error-always (let ((pn #p"tmp.dat")) (delete-all-versions pn) (open pn :direction :output :if-does-not-exist :error)) file-error) t t) (deftest open.error.9 (signals-error-always (let ((pn #p"tmp.dat")) (delete-all-versions pn) (open pn :direction :io :if-does-not-exist :error)) file-error) t t) (deftest open.error.10 (signals-error-always (let ((pn #p"tmp.dat")) (delete-all-versions pn) (open pn :direction :probe :if-does-not-exist :error)) file-error) t t) (deftest open.error.11 (signals-error-always (let ((pn #p"tmp.dat")) (delete-all-versions pn) (open pn :direction :output :if-exists :overwrite)) file-error) t t) (deftest open.error.12 (signals-error-always (let ((pn #p"tmp.dat")) (delete-all-versions pn) (open pn :direction :output :if-exists :append)) file-error) t t) (deftest open.error.13 (signals-error-always (let ((pn #p"tmp.dat")) (delete-all-versions pn) (open pn :direction :io :if-exists :overwrite)) file-error) t t) (deftest open.error.14 (signals-error-always (let ((pn #p"tmp.dat")) (delete-all-versions pn) (open pn :direction :io :if-exists :append)) file-error) t t) (deftest open.error.15 (signals-error-always (open (make-pathname :name :wild :type "lsp")) file-error) t t) (deftest open.error.16 (signals-error-always (open (make-pathname :name "open" :type :wild)) file-error) t t) (deftest open.error.17 (signals-error-always (let ((pn (make-pathname :name "open" :type "lsp" :version :wild))) (if (wild-pathname-p pn) (open pn) (error 'file-error))) file-error) t t) (deftest open.error.18 (signals-error-always (open #p"tmp.dat" :direction :output :if-exists :supersede :external-form (gensym)) error) t t) ;;; FIXME -- add tests for :element-type :default ;;; FIXME -- add tests for filespec being a specialized string gcl27-2.7.0/ansi-tests/optimize.lsp000066400000000000000000000022121454061450500171110ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 21 09:31:34 2005 ;;;; Contains: Tests of the OPTIMIZE declaration (in-package :cl-test) (deftest optimize.1 (locally (declare (optimize)) nil) nil) (deftest optimize.2 (locally (declare (optimize speed)) nil) nil) (deftest optimize.3 (locally (declare (optimize space)) nil) nil) (deftest optimize.4 (locally (declare (optimize safety)) nil) nil) (deftest optimize.5 (locally (declare (optimize debug)) nil) nil) (deftest optimize.6 (locally (declare (optimize compilation-speed)) nil) nil) (deftest optimize.7 (loop for d in '(speed space safety debug compilation-speed) nconc (loop for n from 0 to 3 for form = `(locally (declare (optimize (,d ,n))) t) for val = (eval form) unless (eql val t) collect (list d n val))) nil) (deftest optimize.8 (loop for d in '(speed space safety debug compilation-speed) nconc (loop for n from 0 to 3 for form = `(lambda () (declare (optimize (,d ,n))) t) for val = (funcall (compile nil form)) unless (eql val t) collect (list d n val))) nil) gcl27-2.7.0/ansi-tests/or.lsp000066400000000000000000000023751454061450500157030ustar00rootroot00000000000000;-*- 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) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest or.10 (macrolet ((%m (z) z)) (or (expand-in-current-env (%m 'x)) (expand-in-current-env (%m nil)) (expand-in-current-env (%m 'y)) t)) x) (deftest or.11 (macrolet ((%m (z) z)) (or (expand-in-current-env (%m nil)) (expand-in-current-env (%m 'a)) nil)) a) ;;; Error tests (deftest or.error.1 (signals-error (funcall (macro-function 'or)) program-error) t) (deftest or.error.2 (signals-error (funcall (macro-function 'or) '(or)) program-error) t) (deftest or.error.3 (signals-error (funcall (macro-function 'or) '(or) nil nil) program-error) t) gcl27-2.7.0/ansi-tests/output-stream-p.lsp000066400000000000000000000015761454061450500203530ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 13 19:46:12 2004 ;;;; Contains: Tests of OUTPUT-STREAM-P (in-package :cl-test) (deftest output-stream-p.1 (notnot-mv (output-stream-p *standard-output*)) t) (deftest output-stream-p.2 (notnot-mv (output-stream-p *terminal-io*)) t) (deftest output-stream-p.3 (with-open-file (s "output-stream-p.lsp" :direction :input) (output-stream-p s)) nil) (deftest output-stream-p.4 (with-open-file (s "foo.txt" :direction :output :if-exists :supersede) (notnot-mv (output-stream-p s))) t) ;;; Error tests (deftest output-stream-p.error.1 (signals-error (output-stream-p) program-error) t) (deftest output-stream-p.error.2 (signals-error (output-stream-p *standard-output* nil) program-error) t) (deftest output-stream-p.error.3 (check-type-error #'output-stream-p #'streamp) nil) gcl27-2.7.0/ansi-tests/package-aux.lsp000066400000000000000000000107451454061450500174510ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jun 21 20:59:17 2004 ;;;; Contains: Aux. functions for package tests (in-package :cl-test) (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 ~S ~S ~S ~S~%" sym p sym2 access (quote ,(copy-list symbol-types))) (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 num-external-symbols-in-package (p) (let ((num 0)) (declare (fixnum num)) (do-external-symbols (s p num) (declare (ignorable s)) (incf num)))) (defun external-symbols-in-package (p) (let ((symbols nil)) (do-external-symbols (s p) (push s symbols)) (sort symbols #'(lambda (s1 s2) (string< (symbol-name s1) (symbol-name s2)))))) (defun num-symbols-in-package (p) (let ((num 0)) (declare (fixnum num)) (do-symbols (s p num) (declare (ignorable s)) (incf num)))) (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 sort-package-list (x) (sort (copy-list x) #'string< :key #'package-name)) gcl27-2.7.0/ansi-tests/package-error-package.lsp000066400000000000000000000021751454061450500213740ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Feb 22 06:52:56 2004 ;;;; Contains: Tests of PACKAGE-ERROR-PACKAGE (in-package :cl-test) (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 (signals-error (package-error-package) program-error) t) (deftest package-error-package.error.2 (signals-error (package-error-package (make-condition 'package-error :package #\A) nil) program-error) t) gcl27-2.7.0/ansi-tests/package-error.lsp000066400000000000000000000011661454061450500200020ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Feb 22 06:52:21 2004 ;;;; Contains: Tests of the condition PACKAGE-ERROR (in-package :cl-test) (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) gcl27-2.7.0/ansi-tests/package-name.lsp000066400000000000000000000102301454061450500175610ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 21 17:48:05 2004 ;;;; Contains: Tests of PACKAGE-NAME (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; package-name (deftest package-name.1 (progn (set-up-packages) (package-name "A")) "A") (deftest package-name.2 (progn (set-up-packages) (package-name #\A)) "A") (deftest package-name.3 (progn (set-up-packages) (package-name "Q")) "A") (deftest package-name.4 (progn (set-up-packages) (package-name #\Q)) "A") (deftest package-name.5 (handler-case (locally (declare (optimize safety)) (eval '(package-name "NOT-THERE")) nil) (type-error () t) (package-error () t)) t) (deftest package-name.6 (handler-case (locally (declare (optimize safety)) (eval '(package-name #\*)) nil) (type-error () t) (package-error () t)) t) (deftest package-name.6a (handler-case (locally (declare (optimize safety)) (eval '(locally (package-name #\*) t)) nil) (type-error () t) (package-error () t)) 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) (package-name (package-name p))))) 0) ;;; Specialized sequence tests (defmacro def-package-name-test (test-name name-form expected-name-form) `(deftest ,test-name (let ((name ,name-form) (expected-name ,expected-name-form)) (assert (string= name expected-name)) (safely-delete-package name) (let ((p (make-package name :use nil))) (equalt (package-name p) expected-name))) t)) (def-package-name-test package-name.16 (make-array 5 :element-type 'base-char :initial-contents "TEST1") "TEST1") (def-package-name-test package-name.17 (make-array 10 :element-type 'base-char :fill-pointer 5 :initial-contents "TEST1?????") "TEST1") (def-package-name-test package-name.18 (make-array 10 :element-type 'character :fill-pointer 5 :initial-contents "TEST1?????") "TEST1") (def-package-name-test package-name.19 (make-array 5 :element-type 'base-char :adjustable t :initial-contents "TEST1") "TEST1") (def-package-name-test package-name.20 (make-array 5 :element-type 'character :adjustable t :initial-contents "TEST1") "TEST1") (def-package-name-test package-name.21 (let* ((etype 'base-char) (name0 (make-array 10 :element-type etype :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 2)) "TEST1") (def-package-name-test package-name.22 (let* ((etype 'character) (name0 (make-array 10 :element-type etype :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 2)) "TEST1") (deftest package-name.error.1 (signals-error (package-name) program-error) t) (deftest package-name.error.2 (signals-error (package-name "CL" nil) program-error) t) (deftest package-name.error.3 (check-type-error #'package-name #'package-designator-p) nil) gcl27-2.7.0/ansi-tests/package-nicknames.lsp000066400000000000000000000071731454061450500206250ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 07:51:26 1998 ;;;; Contains: Tests of PACKAGE-NICKNAMES (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; package-nicknames (deftest package-nicknames.1 (progn (set-up-packages) (package-nicknames "A")) ("Q")) (deftest package-nicknames.2 (progn (set-up-packages) (package-nicknames #\A)) ("Q")) (deftest package-nicknames.3 (progn (set-up-packages) (package-nicknames ':|A|)) ("Q")) (deftest package-nicknames.4 (progn (set-up-packages) (package-nicknames "B")) nil) (deftest package-nicknames.5 (progn (set-up-packages) (package-nicknames #\B)) nil) (deftest package-nicknames.6 (progn (set-up-packages) (package-nicknames '#:|B|)) nil) (deftest package-nicknames.7 (subsetp '(#.(string '#:cl)) (package-nicknames "COMMON-LISP") :test #'string=) t) (deftest package-nicknames.8 (notnot (subsetp '(#.(string '#:cl-user)) (package-nicknames "COMMON-LISP-USER") :test #'string=)) t) (deftest package-nicknames.9 (signals-error (package-nicknames 10) type-error) t) (deftest package-nicknames.9a (signals-error (locally (package-nicknames 10) t) type-error) t) (deftest package-nicknames.10 (progn (set-up-packages) (package-nicknames (find-package "A"))) ("Q")) (deftest package-nicknames.11 (handler-case (locally (declare (optimize safety)) (eval '(package-nicknames "NOT-A-PACKAGE-NAME")) nil) (type-error () t) (package-error () t)) 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) ;;; Specialized sequence names tests (defmacro def-package-nicknames-test (test-name name-form) `(deftest ,test-name (let ((name ,name-form)) (safely-delete-package name) (let ((p (make-package name :use nil))) (package-nicknames p))) nil)) (def-package-nicknames-test package-nicknames.16 (make-array 5 :element-type 'base-char :initial-contents "TEST1")) (def-package-nicknames-test package-nicknames.17 (make-array 10 :element-type 'base-char :fill-pointer 5 :initial-contents "TEST1?????")) (def-package-nicknames-test package-nicknames.18 (make-array 10 :element-type 'character :fill-pointer 5 :initial-contents "TEST1?????")) (def-package-nicknames-test package-nicknames.19 (make-array 5 :element-type 'base-char :adjustable t :initial-contents "TEST1")) (def-package-nicknames-test package-nicknames.20 (make-array 5 :element-type 'character :adjustable t :initial-contents "TEST1")) (def-package-nicknames-test package-nicknames.21 (let* ((etype 'base-char) (name0 (make-array 10 :element-type etype :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 2))) (def-package-nicknames-test package-nicknames.22 (let* ((etype 'character) (name0 (make-array 10 :element-type etype :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 2))) ;;; Error tests (deftest package-nicknames.error.1 (signals-error (package-nicknames) program-error) t) (deftest package-nicknames.error.2 (signals-error (package-nicknames "CL" nil) program-error) t) (deftest package-nicknames.error.3 (check-type-error #'package-nicknames #'package-designator-p) nil) gcl27-2.7.0/ansi-tests/package-shadowing-symbols.lsp000066400000000000000000000040521454061450500223170ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Feb 22 06:55:17 2004 ;;;; Contains: Tests of PACKAGE-SHADOWING-SYMBOLS (in-package :cl-test) ;;; Most tests of this function are in files for other package-related operators ;;; Specialized sequence tests (defmacro def-package-shadowing-symbols-test (test-name name-form) `(deftest ,test-name (let ((name ,name-form)) (safely-delete-package name) (let ((p (make-package name :use nil))) (package-shadowing-symbols p))) nil)) (def-package-shadowing-symbols-test package-shadowing-symbols.1 (make-array 5 :element-type 'base-char :initial-contents "TEST1")) (def-package-shadowing-symbols-test package-shadowing-symbols.2 (make-array 10 :element-type 'base-char :fill-pointer 5 :initial-contents "TEST1?????")) (def-package-shadowing-symbols-test package-shadowing-symbols.3 (make-array 10 :element-type 'character :fill-pointer 5 :initial-contents "TEST1?????")) (def-package-shadowing-symbols-test package-shadowing-symbols.4 (make-array 5 :element-type 'base-char :adjustable t :initial-contents "TEST1")) (def-package-shadowing-symbols-test package-shadowing-symbols.5 (make-array 5 :element-type 'character :adjustable t :initial-contents "TEST1")) (def-package-shadowing-symbols-test package-shadowing-symbols.6 (let* ((etype 'base-char) (name0 (make-array 10 :element-type etype :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 2))) (def-package-shadowing-symbols-test package-shadowing-symbols.7 (let* ((etype 'character) (name0 (make-array 10 :element-type etype :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 2))) ;;; Error tests (deftest package-shadowing-symbols.error.1 (signals-error (package-shadowing-symbols) program-error) t) (deftest package-shadowing-symbols.error.2 (signals-error (package-shadowing-symbols "CL" nil) program-error) t) gcl27-2.7.0/ansi-tests/package-use-list.lsp000066400000000000000000000035541454061450500204210ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Feb 22 06:55:56 2004 ;;;; Contains: Tests of PACKAGE-USE-LIST (in-package :cl-test) ;;; Most tests of this function are in files for other package-related operators ;;; Specialized sequence tests (defmacro def-package-use-list-test (test-name name-form) `(deftest ,test-name (let ((name ,name-form)) (safely-delete-package name) (let ((p (make-package name :use nil))) (package-use-list p))) nil)) (def-package-use-list-test package-use-list.1 (make-array 5 :element-type 'base-char :initial-contents "TEST1")) (def-package-use-list-test package-use-list.2 (make-array 10 :element-type 'base-char :fill-pointer 5 :initial-contents "TEST1?????")) (def-package-use-list-test package-use-list.3 (make-array 10 :element-type 'character :fill-pointer 5 :initial-contents "TEST1?????")) (def-package-use-list-test package-use-list.4 (make-array 5 :element-type 'base-char :adjustable t :initial-contents "TEST1")) (def-package-use-list-test package-use-list.5 (make-array 5 :element-type 'character :adjustable t :initial-contents "TEST1")) (def-package-use-list-test package-use-list.6 (let* ((etype 'base-char) (name0 (make-array 10 :element-type etype :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 2))) (def-package-use-list-test package-use-list.7 (let* ((etype 'character) (name0 (make-array 10 :element-type etype :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 2))) ;;; Error tests (deftest package-use-list.error.1 (signals-error (package-use-list) program-error) t) (deftest package-use-list.error.2 (signals-error (package-use-list "CL" nil) program-error) t) gcl27-2.7.0/ansi-tests/package-used-by-list.lsp000066400000000000000000000037011454061450500211670ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Feb 22 06:56:28 2004 ;;;; Contains: Tests of PACKAGE-USED-BY-LIST (in-package :cl-test) ;;; Most tests of this function are in files for other package-related operators ;;; Specialized sequence tests (defmacro def-package-used-by-list-test (test-name name-form) `(deftest ,test-name (let ((name ,name-form)) (safely-delete-package name) (let ((p (make-package name :use nil))) (package-used-by-list p))) nil)) (def-package-used-by-list-test package-used-by-list.1 (make-array 5 :element-type 'base-char :initial-contents "TEST1")) (def-package-used-by-list-test package-used-by-list.2 (make-array 10 :element-type 'base-char :fill-pointer 5 :initial-contents "TEST1?????")) (def-package-used-by-list-test package-used-by-list.3 (make-array 10 :element-type 'character :fill-pointer 5 :initial-contents "TEST1?????")) (def-package-used-by-list-test package-used-by-list.4 (make-array 5 :element-type 'base-char :adjustable t :initial-contents "TEST1")) (def-package-used-by-list-test package-used-by-list.5 (make-array 5 :element-type 'character :adjustable t :initial-contents "TEST1")) (def-package-used-by-list-test package-used-by-list.6 (let* ((etype 'base-char) (name0 (make-array 10 :element-type etype :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 2))) (def-package-used-by-list-test package-used-by-list.7 (let* ((etype 'character) (name0 (make-array 10 :element-type etype :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 2))) ;;; Error tests (deftest package-used-by-list.error.1 (signals-error (package-used-by-list) program-error) t) (deftest package-used-by-list.error.2 (signals-error (package-used-by-list "CL" nil) program-error) t) gcl27-2.7.0/ansi-tests/packagep.lsp000066400000000000000000000007301454061450500170270ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Feb 22 06:51:38 2004 ;;;; Contains: Tests of PACKAGEP (in-package :cl-test) (deftest packagep.1 (check-type-predicate #'packagep 'package) nil) ;;; *package* is always a package (deftest packagep.2 (not-mv (packagep *package*)) nil) (deftest packagep.error.1 (signals-error (packagep) program-error) t) (deftest packagep.error.2 (signals-error (packagep nil nil) program-error) t) gcl27-2.7.0/ansi-tests/packages-00.lsp000066400000000000000000000025401454061450500172500ustar00rootroot00000000000000;-*- 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))) (report-and-ignore-errors (defpackage "A" (:use) (:nicknames "Q") (:export "FOO"))) (report-and-ignore-errors (defpackage "B" (:use "A") (:export "BAR"))) (defun set-up-packages () (safely-delete-package "A") (safely-delete-package "B") (safely-delete-package "Q") (defpackage "A" (:use) (:nicknames "Q") (:export "FOO")) (defpackage "B" (:use "A") (:export "BAR"))) (report-and-ignore-errors (defpackage "FS-A" (:use) (:nicknames "FS-Q") (:export "FOO"))) (report-and-ignore-errors (defpackage "FS-B" (:use "FS-A") (:export "BAR"))) (report-and-ignore-errors (defpackage "DS1" (:use) (:intern "C" "D") (:export "A" "B"))) (report-and-ignore-errors (defpackage "DS2" (:use) (:intern "E" "F") (:export "G" "H" "A"))) (report-and-ignore-errors (defpackage "DS3" (:shadow "B") (:shadowing-import-from "DS1" "A") (:use "DS1" "DS2") (:export "A" "B" "G" "I" "J" "K") (:intern "L" "M"))) (report-and-ignore-errors (defpackage "DS4" (:shadowing-import-from "DS1" "B") (:use "DS1" "DS3") (:intern "X" "Y" "Z") (:import-from "DS2" "F"))) gcl27-2.7.0/ansi-tests/packages-01.lsp000066400000000000000000000036521454061450500172560ustar00rootroot00000000000000;-*- 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)gcl27-2.7.0/ansi-tests/packages-02.lsp000066400000000000000000000034551454061450500172600ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/packages-03.lsp000066400000000000000000000116711454061450500172600ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/packages-04.lsp000066400000000000000000000026361454061450500172620ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/packages-05.lsp000066400000000000000000000050331454061450500172550ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/packages-06.lsp000066400000000000000000000111421454061450500172540ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/packages-07.lsp000066400000000000000000000136651454061450500172710ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/packages-08.lsp000066400000000000000000000072601454061450500172640ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/packages-09.lsp000066400000000000000000000215451454061450500172670ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/packages-10.lsp000066400000000000000000000057241454061450500172600ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/packages-11.lsp000066400000000000000000000065221454061450500172560ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/packages-12.lsp000066400000000000000000000147321454061450500172610ustar00rootroot00000000000000();-*- 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) gcl27-2.7.0/ansi-tests/packages-13.lsp000066400000000000000000000023461454061450500172600ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/packages-14.lsp000066400000000000000000000134031454061450500172550ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/packages-15.lsp000066400000000000000000000137401454061450500172620ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/packages-16.lsp000066400000000000000000000416701454061450500172660ustar00rootroot00000000000000;-*- 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)) gcl27-2.7.0/ansi-tests/packages-17.lsp000066400000000000000000000062131454061450500172610ustar00rootroot00000000000000;-*- 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))) gcl27-2.7.0/ansi-tests/packages-18.lsp000066400000000000000000000044721454061450500172670ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/packages-19.lsp000066400000000000000000000027251454061450500172670ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/packages.lsp000066400000000000000000000012111454061450500170250ustar00rootroot00000000000000;-*- 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") gcl27-2.7.0/ansi-tests/pairlis.lsp000066400000000000000000000044321454061450500167220ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:30:55 2003 ;;;; Contains: Tests of PAIRLIS (in-package :cl-test) (compile-and-load "cons-aux.lsp") ;; 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) (def-fold-test pairlis.fold.1 (pairlis '(a b) '(c d))) ;;; Error tests (deftest pairlis.error.1 (signals-error (pairlis) program-error) t) (deftest pairlis.error.2 (signals-error (pairlis nil) program-error) t) (deftest pairlis.error.3 (signals-error (pairlis nil nil nil nil) program-error) t) (deftest pairlis.error.4 (signals-error (pairlis 'a '(1)) type-error) t) (deftest pairlis.error.5 (signals-error (pairlis '(a) 'b) type-error) t) (deftest pairlis.error.6 (signals-error (pairlis '(a . b) '(c . d)) type-error) t) (deftest pairlis.error.7 (check-type-error #'(lambda (x) (pairlis x '(a b))) #'listp) nil) (deftest pairlis.error.8 (check-type-error #'(lambda (x) (pairlis '(a b) x)) #'listp) nil) gcl27-2.7.0/ansi-tests/parse-integer.lsp000066400000000000000000000166451454061450500200350ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 7 10:24:13 2003 ;;;; Contains: Tests of PARSE-INTEGER (in-package :cl-test) (deftest parse-integer.error.1 (signals-error (parse-integer) program-error) t) (deftest parse-integer.error.2 (signals-error (parse-integer "123" :bogus) program-error) t) (deftest parse-integer.error.3 (signals-error (parse-integer "123" :bogus 'foo) program-error) t) (deftest parse-integer.error.4 (signals-error (parse-integer "") parse-error) t) (deftest parse-integer.error.5 (loop for x across +standard-chars+ unless (or (digit-char-p x) (eval `(signals-error (parse-integer ,(string x)) parse-error))) collect x) nil) (deftest parse-integer.error.5a (signals-error (parse-integer "") parse-error) t) (deftest parse-integer.error.6 (signals-error (parse-integer "1234a") parse-error) t) (deftest parse-integer.error.7 (signals-error (parse-integer "-") parse-error) t) (deftest parse-integer.error.8 (signals-error (parse-integer "+") parse-error) t) (deftest parse-integer.error.9 (signals-error (parse-integer "--10") parse-error) t) (deftest parse-integer.error.10 (signals-error (parse-integer "++10") parse-error) t) (deftest parse-integer.error.11 (signals-error (parse-integer "10.") parse-error) t) (deftest parse-integer.error.12 (signals-error (parse-integer "#O123") parse-error) t) (deftest parse-integer.error.13 (signals-error (parse-integer "#B0100") parse-error) t) (deftest parse-integer.error.14 (signals-error (parse-integer "#X0100") parse-error) t) (deftest parse-integer.error.15 (signals-error (parse-integer "#3R0100") parse-error) t) ;;; (deftest parse-integer.1 (parse-integer "123") 123 3) (deftest parse-integer.2 (parse-integer " 123") 123 4) (deftest parse-integer.3 (parse-integer " 12345678901234567890 ") 12345678901234567890 27) (deftest parse-integer.4 (parse-integer (concatenate 'string (string #\Newline) "17" (string #\Newline))) 17 4) (deftest parse-integer.5 (let ((c (name-char "Tab"))) (if c (parse-integer (concatenate 'string (string c) "6381" (string c))) (values 6381 6))) 6381 6) (deftest parse-integer.6 (let ((c (name-char "Linefeed"))) (if c (parse-integer (concatenate 'string (string c) "-123712" (string c))) (values -123712 9))) -123712 9) (deftest parse-integer.7 (let ((c (name-char "Page"))) (if c (parse-integer (concatenate 'string (string c) "0" (string c))) (values 0 3))) 0 3) (deftest parse-integer.8 (let ((c (name-char "Return"))) (if c (parse-integer (concatenate 'string (string c) "999" (string c))) (values 999 5))) 999 5) (deftest parse-integer.9 (parse-integer "-0") 0 2) (deftest parse-integer.10 (parse-integer "+0") 0 2) (deftest parse-integer.11 (parse-integer "-00") 0 3) (deftest parse-integer.12 (parse-integer "+000") 0 4) (deftest parse-integer.13 (parse-integer "00010") 10 5) (deftest parse-integer.14 (parse-integer "10110" :radix 2) 22 5) (deftest parse-integer.15 (parse-integer "1021" :radix 3) 34 4) (deftest parse-integer.16 (loop for radix from 2 to 36 for c across "123456789abcdefghijklmnopqrstuvwxyz" for s = (concatenate 'string (string c) "0") for vals = (multiple-value-list (parse-integer s :radix radix)) for (val pos) = vals always (and (= (length vals) 2) (= pos 2) (= val (* radix (1- radix))))) t) (deftest parse-integer.17 (parse-integer "10A" :junk-allowed t) 10 2) (deftest parse-integer.18 (parse-integer "10" :junk-allowed t) 10 2) (deftest parse-integer.19 (parse-integer "ABCDE" :junk-allowed t) nil 0) (deftest parse-integer.20 (parse-integer "" :junk-allowed t) nil 0) (deftest parse-integer.21 :notes (:nil-vectors-are-strings) (parse-integer (make-array 0 :element-type nil) :junk-allowed t) nil 0) (deftest parse-integer.22 (parse-integer "a1234b" :start 2 :end 4) 23 4) (deftest parse-integer.23 (parse-integer "a1234b" :start 2 :end 4 :end nil) 23 4) (deftest parse-integer.24 (parse-integer "a1234b" :start 2 :end 4 :start 1) 23 4) (deftest parse-integer.25 (parse-integer "a1234b" :start 2 :end 4 :allow-other-keys nil) 23 4) (deftest parse-integer.26 (parse-integer "a1234b" :start 2 :end 4 :allow-other-keys t :foo nil) 23 4) (deftest parse-integer.27 (parse-integer "a1234b" :start 2 :end 4 :allow-other-keys t :allow-other-keys nil :foo nil) 23 4) (deftest parse-integer.28 (let* ((s (make-array 5 :initial-contents "a123b" :element-type 'base-char)) (s2 (make-array 3 :displaced-to s :displaced-index-offset 1 :element-type 'base-char))) (values s2 (length s2) (equalpt "123" s2) (multiple-value-list (parse-integer s2)))) "123" 3 t (123 3)) (deftest parse-integer.28a (let* ((s (make-array 5 :initial-contents "a123b" :element-type 'character)) (s2 (make-array 3 :displaced-to s :displaced-index-offset 1 :element-type 'character))) (values s2 (length s2) (equalpt "123" s2) (multiple-value-list (parse-integer s2)))) "123" 3 t (123 3)) (deftest parse-integer.29 (let ((s (make-array 10 :initial-contents "1234567890" :fill-pointer 3 :element-type 'base-char))) (values (length s) (multiple-value-list (parse-integer s)))) 3 (123 3)) (deftest parse-integer.29a (let ((s (make-array 10 :initial-contents "1234567890" :fill-pointer 3 :element-type 'character))) (values (length s) (multiple-value-list (parse-integer s)))) 3 (123 3)) (deftest parse-integer.30 (let ((s (make-array 10 :initial-contents "1234567890" :adjustable t :element-type 'base-char))) (values (length s) (multiple-value-list (parse-integer s)) (progn (adjust-array s 3 :element-type 'base-char) (multiple-value-list (parse-integer s))))) 10 (1234567890 10) (123 3)) (deftest parse-integer.30a (let ((s (make-array 10 :initial-contents "1234567890" :adjustable t :element-type 'character))) (values (length s) (multiple-value-list (parse-integer s)) (progn (adjust-array s 3 :element-type 'character) (multiple-value-list (parse-integer s))))) 10 (1234567890 10) (123 3)) (deftest parse-integer.31 (parse-integer "1234" :start 1) 234 4) (deftest parse-integer.32 (parse-integer "1234" :start 1 :end nil) 234 4) (deftest parse-integer.33 (let* ((s (make-array 5 :initial-contents "a123b" :element-type 'base-char)) (s2 (make-array 3 :displaced-to s :displaced-index-offset 1 :element-type 'base-char)) (s3 (make-array 2 :displaced-to s2 :displaced-index-offset 1 :element-type 'base-char))) (values s3 (length s3) (equalpt "23" s3) (multiple-value-list (parse-integer s3)))) "23" 2 t (23 2)) (deftest parse-integer.34 (parse-integer "1234" :end 3) 123 3) (deftest parse-integer.35 (parse-integer "1234" :end 3 :end 1) 123 3) (deftest parse-integer.36 (parse-integer "1234" :end nil :end 3) 1234 4) ;;; Order of evaluation tests (deftest parse-integer.order.1 (let ((i 0) a b c d e) (values (multiple-value-list (parse-integer (progn (setf a (incf i)) "10001") :radix (progn (setf b (incf i)) 2) :start (progn (setf c (incf i)) 0) :end (progn (setf d (incf i)) 5) :junk-allowed (progn (setf e (incf i)) nil))) i a b c d e)) (17 5) 5 1 2 3 4 5) gcl27-2.7.0/ansi-tests/parse-namestring.lsp000066400000000000000000000047531454061450500205440ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 14 13:59:18 2004 ;;;; Contains: Tests of PARSE-NAMESTRING (in-package :cl-test) ;;; "Parsing a null string always succeeds, producing a pathname ;;; with all components (except the host) equal to nil." (deftest parse-namestring.1 (let ((vals (multiple-value-list (parse-namestring "")))) (assert (= (length vals) 2)) (let ((pn (first vals)) (pos (second vals))) (values (pathname-directory pn) (pathname-device pn) (pathname-name pn) (pathname-type pn) (pathname-version pn) pos))) nil nil nil nil nil 0) (deftest parse-namestring.2 (let ((vals (multiple-value-list (parse-namestring (make-array 0 :element-type 'base-char))))) (assert (= (length vals) 2)) (let ((pn (first vals)) (pos (second vals))) (values (pathname-directory pn) (pathname-device pn) (pathname-name pn) (pathname-type pn) (pathname-version pn) pos))) nil nil nil nil nil 0) (deftest parse-namestring.3 (let ((vals (multiple-value-list (parse-namestring (make-array 4 :element-type 'base-char :initial-element #\X :fill-pointer 0))))) (assert (= (length vals) 2)) (let ((pn (first vals)) (pos (second vals))) (values (pathname-directory pn) (pathname-device pn) (pathname-name pn) (pathname-type pn) (pathname-version pn) pos))) nil nil nil nil nil 0) (deftest parse-namestring.4 (loop for etype in '(standard-char base-char character) for s0 = (make-array 4 :element-type etype :initial-element #\X) for s = (make-array 0 :element-type etype :displaced-to s0 :displaced-index-offset 1) for vals = (multiple-value-list (parse-namestring s)) for pn = (first vals) for pos = (second vals) do (assert (= (length vals) 2)) nconc (let ((result (list (pathname-directory pn) (pathname-device pn) (pathname-name pn) (pathname-type pn) (pathname-version pn) pos))) (unless (equal result '(nil nil nil nil nil 0)) (list (list etype result))))) nil) ;;; Error tests (deftest parse-namestring.error.1 (signals-error (parse-namestring) program-error) t) (deftest parse-name-string.error.2 (signals-error (parse-namestring "" nil *default-pathname-defaults* :foo nil) program-error) t) (deftest parse-name-string.error.3 (signals-error (parse-namestring "" nil *default-pathname-defaults* :start) program-error) t) gcl27-2.7.0/ansi-tests/pathname-device.lsp000066400000000000000000000036361454061450500203160ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Dec 6 14:23:54 2003 ;;;; Contains: Tests for PATHNAME-DEVICE (in-package :cl-test) (compile-and-load "pathnames-aux.lsp") (deftest pathname-device.1 (loop for p in *pathnames* for device = (pathname-device p) unless (or (stringp device) (member device '(nil :wild :unspecific))) collect (list p device)) nil) (deftest pathname-device.2 (loop for p in *pathnames* for device = (pathname-device p :case :local) unless (or (stringp device) (member device '(nil :wild :unspecific))) collect (list p device)) nil) (deftest pathname-device.3 (loop for p in *pathnames* for device = (pathname-device p :case :common) unless (or (stringp device) (member device '(nil :wild :unspecific))) collect (list p device)) nil) (deftest pathname-device.4 (loop for p in *pathnames* for device = (pathname-device p :allow-other-keys nil) unless (or (stringp device) (member device '(nil :wild :unspecific))) collect (list p device)) nil) (deftest pathname-device.5 (loop for p in *pathnames* for device = (pathname-device p :foo 'bar :allow-other-keys t) unless (or (stringp device) (member device '(nil :wild :unspecific))) collect (list p device)) nil) (deftest pathname-device.6 (loop for p in *pathnames* for device = (pathname-device p :allow-other-keys t :allow-other-keys nil :foo 'bar) unless (or (stringp device) (member device '(nil :wild :unspecific))) collect (list p device)) nil) ;;; section 19.3.2.1 (deftest pathname-device.7 (loop for p in *logical-pathnames* always (eq (pathname-device p) :unspecific)) t) (deftest pathname-device.8 (do-special-strings (s "" nil) (pathname-device s)) nil) (deftest pathname-device.error.1 (signals-error (pathname-device) program-error) t) (deftest pathname-device.error.2 (check-type-error #'pathname-device #'could-be-pathname-designator) nil)gcl27-2.7.0/ansi-tests/pathname-directory.lsp000066400000000000000000000050431454061450500210550ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Dec 6 14:24:39 2003 ;;;; Contains: Tests for PATHNAME-DIRECTORY (in-package :cl-test) (compile-and-load "pathnames-aux.lsp") (deftest pathname-directory.1 (loop for p in *pathnames* for directory = (pathname-directory p) unless (or (stringp directory) (member directory '(nil :wild :unspecific)) (and (consp directory) (member (car directory) '(:absolute :relative)))) collect (list p directory)) nil) (deftest pathname-directory.2 (loop for p in *pathnames* for directory = (pathname-directory p :case :local) unless (or (stringp directory) (member directory '(nil :wild :unspecific)) (and (consp directory) (member (car directory) '(:absolute :relative)))) collect (list p directory)) nil) (deftest pathname-directory.3 (loop for p in *pathnames* for directory = (pathname-directory p :case :common) unless (or (stringp directory) (member directory '(nil :wild :unspecific)) (and (consp directory) (member (car directory) '(:absolute :relative)))) collect (list p directory)) nil) (deftest pathname-directory.4 (loop for p in *pathnames* for directory = (pathname-directory p :allow-other-keys nil) unless (or (stringp directory) (member directory '(nil :wild :unspecific)) (and (consp directory) (member (car directory) '(:absolute :relative)))) collect (list p directory)) nil) (deftest pathname-directory.5 (loop for p in *pathnames* for directory = (pathname-directory p :foo 'bar :allow-other-keys t) unless (or (stringp directory) (member directory '(nil :wild :unspecific)) (and (consp directory) (member (car directory) '(:absolute :relative)))) collect (list p directory)) nil) (deftest pathname-directory.6 (loop for p in *pathnames* for directory = (pathname-directory p :allow-other-keys t :allow-other-keys nil 'foo 'bar) unless (or (stringp directory) (member directory '(nil :wild :unspecific)) (and (consp directory) (member (car directory) '(:absolute :relative)))) collect (list p directory)) nil) ;;; section 19.3.2.1 (deftest pathname-directory.7 (loop for p in *logical-pathnames* when (eq (pathname-directory p) :unspecific) collect p) nil) (deftest pathname-directory.8 (do-special-strings (s "" nil) (pathname-directory s)) nil) (deftest pathname-directory.error.1 (signals-error (pathname-directory) program-error) t) (deftest pathname-directory.error.2 (check-type-error #'pathname-directory #'could-be-pathname-designator) nil) gcl27-2.7.0/ansi-tests/pathname-host.lsp000066400000000000000000000035511454061450500200300ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Dec 6 14:23:22 2003 ;;;; Contains: Tests for PATHNAME-HOST (in-package :cl-test) (compile-and-load "pathnames-aux.lsp") (deftest pathname-host.1 (loop for p in *pathnames* always (eql (length (multiple-value-list (pathname-host p))) 1)) t) (deftest pathname-host.2 (loop for p in *pathnames* always (eql (length (multiple-value-list (pathname-host p :case :local))) 1)) t) (deftest pathname-host.3 (loop for p in *pathnames* always (eql (length (multiple-value-list (pathname-host p :case :common))) 1)) t) (deftest pathname-host.4 (loop for p in *pathnames* always (eql (length (multiple-value-list (pathname-host p :allow-other-keys nil))) 1)) t) (deftest pathname-host.5 (loop for p in *pathnames* always (eql (length (multiple-value-list (pathname-host p :foo t :allow-other-keys t))) 1)) t) (deftest pathname-host.6 (loop for p in *pathnames* always (eql (length (multiple-value-list (pathname-host p :allow-other-keys t :allow-other-keys nil 'foo t))) 1)) t) ;;; section 19.3.2.1 (deftest pathname-host.7 (loop for p in *logical-pathnames* when (eq (pathname-host p) :unspecific) collect p) nil) (deftest pathname-host.8 (do-special-strings (s "" nil) (pathname-host s)) nil) #| (deftest pathname-host.9 (loop for p in *pathnames* for host = (pathname-host p) unless (or (stringp host) (and (listp host) (every #'stringp host)) (eql host :unspecific)) collect (list p host)) nil) |# ;;; Error cases (deftest pathname-host.error.1 (signals-error (pathname-host) program-error) t) (deftest pathname-host.error.2 (check-type-error #'pathname-host #'could-be-pathname-designator) nil) (deftest pathname-host.error.3 (signals-error (pathname-host *default-pathname-defaults* '#:bogus t) program-error) t) gcl27-2.7.0/ansi-tests/pathname-match-p.lsp000066400000000000000000000051771454061450500204120ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 15 07:46:22 2004 ;;;; Contains: Tests for PATHNAME-MATCH-P (in-package :cl-test) (compile-and-load "pathnames-aux.lsp") ;;; Much of the behavior cannot be tested portably. (deftest pathname-match-p.1 (let ((pn1 (make-pathname :name :wild)) (pn2 (make-pathname :name "foo"))) (pathname-match-p pn1 pn2)) nil) (deftest pathname-match-p.2 (let ((pn1 (make-pathname :type :wild)) (pn2 (make-pathname :type "txt"))) (pathname-match-p pn1 pn2)) nil) (deftest pathname-match-p.3 (let ((pn1 (make-pathname :directory '(:absolute :wild))) (pn2 (make-pathname :directory '(:absolute)))) (pathname-match-p pn1 pn2)) nil) (deftest pathname-match-p.4 (let ((pn1 (make-pathname :directory '(:relative :wild))) (pn2 (make-pathname :directory '(:relative)))) (pathname-match-p pn1 pn2)) nil) (deftest pathname-match-p.5 (let ((pn1 (make-pathname :directory '(:relative :wild))) (pn2 (make-pathname :directory nil))) (and (wild-pathname-p pn1) (not (pathname-directory pn2)) (not (pathname-match-p pn1 pn2)))) nil) (deftest pathname-match-p.6 (let ((pn1 (make-pathname :version :wild)) (pn2 (make-pathname))) (and (wild-pathname-p pn1) (not (pathname-version pn2)) (not (pathname-match-p pn1 pn2)))) nil) ;;; Specialized string tests (deftest pathname-match-p.7 (let ((wpn (parse-namestring "CLTEST:*.LSP"))) (assert (wild-pathname-p wpn)) (do-special-strings (s "CLTEST:FOO.LSP" nil) (assert (pathname-match-p s wpn)))) nil) (deftest pathname-match-p.8 (do-special-strings (s "CLTEST:*.LSP" nil) (assert (pathname-match-p "CLTEST:FOO.LSP" s))) nil) ;;; Add more tests here ;;; Here are error tests (deftest pathname-match-p.error.1 (signals-error (pathname-match-p) program-error) t) (deftest pathname-match-p.error.2 (signals-error (pathname-match-p #p"") program-error) t) (deftest pathname-match-p.error.3 (signals-error (pathname-match-p #p"" #p"" nil) program-error) t) (deftest pathname-match-p.error.4 (check-type-error #'(lambda (x) (pathname-match-p x #p"")) #'could-be-pathname-designator) nil) (deftest pathname-match-p.error.5 (check-type-error #'(lambda (x) (declare (optimize (safety 0))) (pathname-match-p x #p"")) #'could-be-pathname-designator) nil) (deftest pathname-match-p.error.6 (check-type-error #'(lambda (x) (pathname-match-p #p"" x)) #'could-be-pathname-designator) nil) (deftest pathname-match-p.error.7 (check-type-error #'(lambda (x) (declare (optimize (safety 0))) (pathname-match-p #p"" x)) #'could-be-pathname-designator) nil) gcl27-2.7.0/ansi-tests/pathname-name.lsp000066400000000000000000000035201454061450500177670ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Dec 6 14:45:16 2003 ;;;; Contains: Tests for PATHNAME-NAME (in-package :cl-test) (compile-and-load "pathnames-aux.lsp") (deftest pathname-name.1 (loop for p in *pathnames* for name = (pathname-name p) unless (or (stringp name) (member name '(nil :wild :unspecific))) collect (list p name)) nil) (deftest pathname-name.2 (loop for p in *pathnames* for name = (pathname-name p :case :local) unless (or (stringp name) (member name '(nil :wild :unspecific))) collect (list p name)) nil) (deftest pathname-name.3 (loop for p in *pathnames* for name = (pathname-name p :case :common) unless (or (stringp name) (member name '(nil :wild :unspecific))) collect (list p name)) nil) (deftest pathname-name.4 (loop for p in *pathnames* for name = (pathname-name p :allow-other-keys nil) unless (or (stringp name) (member name '(nil :wild :unspecific))) collect (list p name)) nil) (deftest pathname-name.5 (loop for p in *pathnames* for name = (pathname-name p :foo 'bar :allow-other-keys t) unless (or (stringp name) (member name '(nil :wild :unspecific))) collect (list p name)) nil) (deftest pathname-name.6 (loop for p in *pathnames* for name = (pathname-name p :allow-other-keys t :allow-other-keys nil :foo 'bar) unless (or (stringp name) (member name '(nil :wild :unspecific))) collect (list p name)) nil) ;;; section 19.3.2.1 (deftest pathname-name.7 (loop for p in *logical-pathnames* when (eq (pathname-name p) :unspecific) collect p) nil) (deftest pathname-name.8 (do-special-strings (s "" nil) (pathname-name s)) nil) (deftest pathname-name.error.1 (signals-error (pathname-name) program-error) t) (deftest pathname-name.error.2 (check-type-error #'pathname-name #'could-be-pathname-designator) nil) gcl27-2.7.0/ansi-tests/pathname-type.lsp000066400000000000000000000035201454061450500200300ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Dec 6 14:45:16 2003 ;;;; Contains: Tests for PATHNAME-TYPE (in-package :cl-test) (compile-and-load "pathnames-aux.lsp") (deftest pathname-type.1 (loop for p in *pathnames* for type = (pathname-type p) unless (or (stringp type) (member type '(nil :wild :unspecific))) collect (list p type)) nil) (deftest pathname-type.2 (loop for p in *pathnames* for type = (pathname-type p :case :local) unless (or (stringp type) (member type '(nil :wild :unspecific))) collect (list p type)) nil) (deftest pathname-type.3 (loop for p in *pathnames* for type = (pathname-type p :case :common) unless (or (stringp type) (member type '(nil :wild :unspecific))) collect (list p type)) nil) (deftest pathname-type.4 (loop for p in *pathnames* for type = (pathname-type p :allow-other-keys nil) unless (or (stringp type) (member type '(nil :wild :unspecific))) collect (list p type)) nil) (deftest pathname-type.5 (loop for p in *pathnames* for type = (pathname-type p :foo 'bar :allow-other-keys t) unless (or (stringp type) (member type '(nil :wild :unspecific))) collect (list p type)) nil) (deftest pathname-type.6 (loop for p in *pathnames* for type = (pathname-type p :allow-other-keys t :allow-other-keys nil :foo 'bar) unless (or (stringp type) (member type '(nil :wild :unspecific))) collect (list p type)) nil) ;;; section 19.3.2.1 (deftest pathname-type.7 (loop for p in *logical-pathnames* when (eq (pathname-type p) :unspecific) collect p) nil) (deftest pathname-type.8 (do-special-strings (s "" nil) (pathname-type s)) nil) (deftest pathname-type.error.1 (signals-error (pathname-type) program-error) t) (deftest pathname-type.error.2 (check-type-error #'pathname-type #'could-be-pathname-designator) nil) gcl27-2.7.0/ansi-tests/pathname-version.lsp000066400000000000000000000016611454061450500205400ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Dec 6 14:45:16 2003 ;;;; Contains: Tests for PATHNAME-VERSION (in-package :cl-test) (compile-and-load "pathnames-aux.lsp") (deftest pathname-version.1 (loop for p in *pathnames* for version = (pathname-version p) unless (or (integerp version) (symbolp version)) collect (list p version)) nil) ;;; section 19.3.2.1 (deftest pathname-version.2 (loop for p in *logical-pathnames* when (eq (pathname-version p) :unspecific) collect p) nil) (deftest pathname-version.3 (do-special-strings (s "" nil) (pathname-version s)) nil) (deftest pathname-version.error.1 (signals-error (pathname-version) program-error) t) (deftest pathname-version.error.2 (signals-error (pathname-version *default-pathname-defaults* nil) program-error) t) (deftest pathname-version.error.3 (check-type-error #'pathname-version #'could-be-pathname-designator) nil) gcl27-2.7.0/ansi-tests/pathname.lsp000066400000000000000000000040541454061450500170540ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Nov 29 05:06:57 2003 ;;;; Contains: Tests of the function PATHNAME (in-package :cl-test) (deftest pathname.1 (loop for x in *pathnames* always (eq x (pathname x))) t) (deftest pathname.2 (equalt #p"ansi-aux.lsp" (pathname "ansi-aux.lsp")) t) (deftest pathname.3 (let ((s (open "ansi-aux.lsp" :direction :input))) (prog1 (equalt (truename (pathname s)) (truename #p"ansi-aux.lsp")) (close s))) t) (deftest pathname.4 (let ((s (open "ansi-aux.lsp" :direction :input))) (close s) (equalt (truename (pathname s)) (truename #p"ansi-aux.lsp"))) t) (deftest pathname.5 (loop for x in *logical-pathnames* always (eq x (pathname x))) t) (deftest pathname.6 (equalt #p"ansi-aux.lsp" (pathname (make-array 12 :initial-contents "ansi-aux.lsp" :element-type 'base-char))) t) (deftest pathname.7 (equalt #p"ansi-aux.lsp" (pathname (make-array 15 :initial-contents "ansi-aux.lspXXX" :element-type 'base-char :fill-pointer 12))) t) (deftest pathname.8 (equalt #p"ansi-aux.lsp" (pathname (make-array 12 :initial-contents "ansi-aux.lsp" :element-type 'base-char :adjustable t))) t) (deftest pathname.9 (equalt #p"ansi-aux.lsp" (pathname (make-array 15 :initial-contents "ansi-aux.lspXXX" :element-type 'character :fill-pointer 12))) t) (deftest pathname.10 (equalt #p"ansi-aux.lsp" (pathname (make-array 12 :initial-contents "ansi-aux.lsp" :element-type 'character :adjustable t))) t) (deftest pathname.11 (loop for etype in '(standard-char base-char character) collect (equalt #p"ansi-aux.lsp" (pathname (let* ((s (make-array 15 :initial-contents "XXansi-aux.lspX" :element-type etype))) (make-array 12 :element-type etype :displaced-to s :displaced-index-offset 2))))) (t t t)) ;;; Error tests (deftest pathname.error.1 (signals-error (pathname) program-error) t) (deftest pathname.error.2 (signals-error (pathname (first *pathnames*) nil) program-error) t) gcl27-2.7.0/ansi-tests/pathnamep.lsp000066400000000000000000000013031454061450500172260ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Dec 6 10:26:45 2003 ;;;; Contains: Tests of PATHNAMEP (in-package :cl-test) (deftest pathnamep.1 (check-type-predicate #'pathnamep 'pathname) nil) (deftest pathnamep.2 (check-predicate #'(lambda (x) (eql (length (multiple-value-list (pathnamep x))) 1))) nil) (deftest pathnamep.3 (check-predicate (typef '(not logical-pathname)) #'pathnamep) nil) (deftest pathnamep.error.1 (signals-error (pathnamep) program-error) t) (deftest pathnamep.error.2 (signals-error (pathnamep nil nil) program-error) t) (deftest pathnamep.error.3 (signals-error (pathnamep *default-pathname-defaults* nil) program-error) t) gcl27-2.7.0/ansi-tests/pathnames-aux.lsp000066400000000000000000000011771454061450500200350ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Dec 6 15:05:05 2003 ;;;; Contains: Functions associated with pathname tests (in-package :cl-test) (defun could-be-pathname-designator (x) (or (stringp x) (pathnamep x) (typep x 'file-stream) (and (typep x 'synonym-stream) (could-be-pathname-designator (symbol-value (synonym-stream-symbol x)))))) (defun explode-pathname (pn) (list :host (pathname-host pn) :device (pathname-device pn) :directory (pathname-directory pn) :name (pathname-name pn) :type (pathname-type pn) :version (pathname-version pn))) gcl27-2.7.0/ansi-tests/pathnames.lsp000066400000000000000000000010101454061450500172240ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Nov 29 04:21:53 2003 ;;;; Contains: Various tests on pathnames (in-package :cl-test) (deftest pathnames-print-and-read-properly (with-standard-io-syntax (loop for p1 in *pathnames* for s = (handler-case (write-to-string p1 :readably t) (print-not-readable () :unreadable-error)) unless (eql s :unreadable-error) append (let ((p2 (read-from-string s))) (unless (equal p1 p2) (list (list p1 s p2)))))) nil) gcl27-2.7.0/ansi-tests/pattern-match.lsp000066400000000000000000000031401454061450500200210ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Dec 4 18:59:27 2004 ;;;; Contains: Macro for pattern matching on S-exprs (in-package :cl-test) (defmacro pmatch (pattern form) (cond ((consp pattern) (let ((pcar (car pattern)) (pcdr (cdr pattern)) (v (gensym))) (case pcar ((:or) `(let ((,v ,form)) (or ,@(mapcar (lambda (sub) `(pmatch ,sub ,v)) pcdr)))) ((:and) `(let ((,v ,form)) (and ,@(mapcar (lambda (sub) `(pmatch ,sub ,v)) pcdr)))) ((:not) (assert (eql (length pcdr) 1)) `(not (pmatch ,(car pcdr) ,form))) (t `(let ((,v ,form)) (and (pmatch ,pcar (car ,v)) (pmatch ,pcdr (cdr ,v)))))))) ((eql pattern '_) t) ((null pattern) `(null ,form)) ((symbolp pattern) `(eql (quote ,pattern) ,form)) (t `(eql ,pattern ,form)))) (defmacro matchcase (form &body cases) (let* ((v (gensym)) (cond-cases (mapcar #'(lambda (case) (assert (consp case)) (let ((pattern (car case)) (body (cdr case))) `((pmatch ,pattern ,v) ,@body))) cases))) `(let ((,v ,form)) (cond ,@cond-cases)))) (defmacro matchcase* (form &body cases) (let* ((block-name (gensym "DONE")) (v (gensym))) `(block ,block-name (let ((,v ,form)) (cond ,@(mapcar #'(lambda (case) (assert (consp case)) (let ((pat (car case)) (forms (cdr case)) (fail-name (gensym "FAIL"))) `((block ,fail-name (and (pmatch ,pat ,v) (macrolet ((fail () '(return-from ,fail-name nil))) (return-from ,block-name (progn ,@forms)))))))) cases)))))) gcl27-2.7.0/ansi-tests/peek-char.lsp000066400000000000000000000151121454061450500171130ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 17 21:02:13 2004 ;;;; Contains: Tests of PEEK-CHAR (in-package :cl-test) (deftest peek-char.1 (with-input-from-string (*standard-input* "abc") (values (peek-char) (read-char) (read-char) (peek-char) (read-char))) #\a #\a #\b #\c #\c) (deftest peek-char.2 (with-input-from-string (*standard-input* " ab") (values (peek-char) (read-char) (peek-char t) (read-char) (peek-char t) (read-char))) #\Space #\Space #\a #\a #\b #\b) (deftest peek-char.3 (with-input-from-string (*standard-input* (concatenate 'string (string #\Newline) (string #\Newline) " " (string #\Newline) "ab")) (values (peek-char) (read-char) (peek-char t) (read-char) (peek-char t) (read-char))) #\Newline #\Newline #\a #\a #\b #\b) (when (name-char "Linefeed") (deftest peek-char.4 (with-input-from-string (*standard-input* (concatenate 'string (string (name-char "Linefeed")) (string (name-char "Linefeed")) "abc")) (values (peek-char) (read-char) (peek-char t) (read-char))) #.(name-char "Linefeed") #.(name-char "Linefeed") #\a #\a)) (when (name-char "Page") (deftest peek-char.5 (with-input-from-string (*standard-input* (concatenate 'string (string (name-char "Page")) (string (name-char "Page")) "abc")) (values (peek-char) (read-char) (peek-char t) (read-char))) #.(name-char "Page") #.(name-char "Page") #\a #\a)) (when (name-char "Tab") (deftest peek-char.6 (with-input-from-string (*standard-input* (concatenate 'string (string (name-char "Tab")) (string (name-char "Tab")) "abc")) (values (peek-char) (read-char) (peek-char t) (read-char))) #.(name-char "Tab") #.(name-char "Tab") #\a #\a)) (when (name-char "Return") (deftest peek-char.7 (with-input-from-string (*standard-input* (concatenate 'string (string (name-char "Return")) (string (name-char "Return")) "abc")) (values (peek-char) (read-char) (peek-char t) (read-char))) #.(name-char "Return") #.(name-char "Return") #\a #\a)) (deftest peek-char.8 (with-input-from-string (s "a bcd") (values (peek-char nil s) (read-char s) (peek-char t s) (read-char s) (peek-char t s) (read-char s))) #\a #\a #\b #\b #\c #\c) (deftest peek-char.9 (with-input-from-string (*standard-input* " a bCcde") (values (peek-char #\c) (read-char) (read-char))) #\c #\c #\d) (deftest peek-char.10 (with-input-from-string (*standard-input* " ; foo") (values (peek-char t) (read-char))) #\; #\;) (deftest peek-char.11 (with-input-from-string (s "") (peek-char nil s nil)) nil) (deftest peek-char.12 (with-input-from-string (s "") (peek-char nil s nil 'foo)) foo) (deftest peek-char.13 (with-input-from-string (s " ") (peek-char t s nil)) nil) (deftest peek-char.14 (with-input-from-string (s " ") (peek-char t s nil 'foo)) foo) (deftest peek-char.15 (with-input-from-string (s "ab c d") (peek-char #\z s nil)) nil) (deftest peek-char.16 (with-input-from-string (s "ab c d") (peek-char #\z s nil 'foo)) foo) ;;; Interaction with echo streams (deftest peek-char.17 (block done (with-input-from-string (is "ab") (with-output-to-string (os) (let ((es (make-echo-stream is os))) (let ((pos1 (file-position os))) (unless (zerop pos1) (return-from done :good)) (peek-char nil es nil) (let ((pos2 (file-position os))) (return-from done (if (eql pos1 pos2) :good (list pos1 pos2))))))))) :good) (deftest peek-char.18 (block done (with-input-from-string (is " ab") (with-output-to-string (os) (let ((es (make-echo-stream is os))) (let ((pos1 (file-position os))) (unless (zerop pos1) (return-from done :good)) (peek-char t es nil) (let ((pos2 (file-position os))) (return-from done (if (eql pos1 pos2) pos1 :good)))))))) :good) (deftest peek-char.19 (block done (with-input-from-string (is "abcde") (with-output-to-string (os) (let ((es (make-echo-stream is os))) (let ((pos1 (file-position os))) (unless (zerop pos1) (return-from done :good)) (peek-char #\c es nil) (let ((pos2 (file-position os))) (return-from done (if (eql pos1 pos2) pos1 :good)))))))) :good) ;;; Interactions with the readtable (deftest peek-char.20 (let ((*readtable* (copy-readtable))) (set-syntax-from-char #\Space #\a) (with-input-from-string (*standard-input* " x") (values (peek-char) (read-char) (peek-char t) (read-char)))) #\Space #\Space #\Space #\Space ; *not* #\x #\x ) (deftest peek-char.21 (let ((*readtable* (copy-readtable))) (set-syntax-from-char #\x #\Space) (with-input-from-string (*standard-input* "xxa") (values (peek-char) (read-char) (peek-char t) (read-char)))) #\x #\x #\a #\a ; *not* #\x #\x ) ;;; Stream designators are accepted for the stream argument (deftest peek-char.22 (with-input-from-string (is "!?*") (let ((*terminal-io* (make-two-way-stream is (make-string-output-stream)))) (peek-char nil t))) #\!) (deftest peek-char.23 (with-input-from-string (*standard-input* "345") (peek-char nil nil)) #\3) ;;; Error tests (deftest peek-char.error.1 (signals-error (with-input-from-string (s "abc") (peek-char s nil nil nil nil 'nonsense)) program-error) t) (deftest peek-char.error.2 (signals-error-always (with-input-from-string (*standard-input* "") (peek-char)) end-of-file) t t) (deftest peek-char.error.3 (signals-error-always (with-input-from-string (s "") (peek-char nil s)) end-of-file) t t) (deftest peek-char.error.4 (signals-error-always (with-input-from-string (s " ") (peek-char t s)) end-of-file) t t) (deftest peek-char.error.5 (signals-error-always (with-input-from-string (s "abcd") (peek-char #\z s)) end-of-file) t t) ;;; There was a consensus on comp.lang.lisp that the requirement ;;; that an end-of-file error be thrown in the following case ;;; is a spec bug #| (deftest peek-char.error.6 (signals-error (with-input-from-string (s "") (peek-char nil s nil nil t)) end-of-file) t) |# gcl27-2.7.0/ansi-tests/phase.lsp000066400000000000000000000045301454061450500163560ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 6 21:15:54 2003 ;;;; Contains: Tests of PHASE (in-package :cl-test) (deftest phase.error.1 (signals-error (phase) program-error) t) (deftest phase.error.2 (signals-error (phase 0 0) program-error) t) (deftest phase.error.3 (check-type-error #'phase #'numberp) nil) (deftest phase.1 (eqlt (phase 0) 0.0f0) t) (deftest phase.2 (eqlt (phase 1) 0.0f0) t) (deftest phase.3 (eqlt (phase 1/2) 0.0f0) t) (deftest phase.4 (eqlt (phase 100.0f0) 0.0f0) t) (deftest phase.5 (eqlt (phase 100.0s0) 0.0s0) t) (deftest phase.6 (eqlt (phase 100.0d0) 0.0d0) t) (deftest phase.7 (eqlt (phase 100.0l0) 0.0l0) t) (deftest phase.8 (eqlt (phase -1) (coerce pi 'single-float)) t) (deftest phase.9 (eqlt (phase -1/2) (coerce pi 'single-float)) t) (deftest phase.10 (let ((p1 (phase #c(0 1))) (p2 (phase #c(0.0f0 1.0f0)))) (and (eql p1 p2) (approx= p1 (coerce (/ pi 2) 'single-float)))) t) (deftest phase.11 (let ((p (phase #c(0.0d0 1.0d0)))) (approx= p (coerce (/ pi 2) 'double-float))) t) (deftest phase.12 (let ((p (phase #c(0.0s0 1.0s0)))) (approx= p (coerce (/ pi 2) 'single-float))) t) (deftest phase.13 (let ((p (phase #c(0.0l0 1.0l0)))) (approx= p (/ pi 2))) t) (deftest phase.14 (let ((p1 (phase #c(1 1))) (p2 (phase #c(1.0f0 1.0f0)))) (and (eql p1 p2) (approx= p1 (coerce (/ pi 4) 'single-float) (* 2 single-float-epsilon)))) t) (deftest phase.15 (let ((p (phase #c(1.0d0 1.0d0)))) (approx= p (coerce (/ pi 4) 'double-float) (* 2 double-float-epsilon))) t) (deftest phase.16 (let ((p (phase #c(1.0s0 1.0s0)))) (approx= p (coerce (/ pi 4) 'single-float) (* 2 short-float-epsilon))) t) (deftest phase.17 (let ((p (phase #c(1.0l0 1.0l0)))) (approx= p (/ pi 4) (* 2 long-float-epsilon))) t) ;;; Negative zeros (deftest phase.18 (or (eqlt -0.0s0 0.0s0) (approx= (phase #c(-1.0 -0.0)) (coerce (- pi) 'short-float))) t) (deftest phase.19 (or (eqlt -0.0f0 0.0f0) (approx= (phase #c(-1.0 -0.0)) (coerce (- pi) 'single-float))) t) (deftest phase.20 (or (eqlt -0.0d0 0.0d0) (approx= (phase #c(-1.0 -0.0)) (coerce (- pi) 'double-float))) t) (deftest phase.21 (or (eqlt -0.0l0 0.0l0) (approx= (phase #c(-1.0 -0.0)) (coerce (- pi) 'long-float))) t) gcl27-2.7.0/ansi-tests/places.lsp000066400000000000000000000137771454061450500165420ustar00rootroot00000000000000;-*- 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.1 (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 incf.order.1 (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.1 (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) ;;; 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 setq.5 (let ((*x* 0)) (declare (special *x*)) (values *x* (setq *x* 1) *x*)) 0 1 1) (deftest setq.6 (let ((*x* 0)) (declare (special *x*)) (setq *x* 1)) 1) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest setq.7 (macrolet ((%m (z) z)) (let ((x nil)) (values (setq x (expand-in-current-env (%m :good))) x))) :good :good) ;;; Tests of SETF (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) (deftest setf.5 (let ((*x* 0)) (declare (special *x*)) (values *x* (setf *x* 1) *x*)) 0 1 1) (deftest setf.6 (let ((*x* 0)) (declare (special *x*)) (setf *x* 1)) 1) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest setf.7 (macrolet ((%m (z) z)) (let ((x nil)) (values x (setf (expand-in-current-env (%m x)) t) x))) nil t t) (deftest setf.8 (macrolet ((%m (z) z)) (let ((x nil)) (values x (setf x (expand-in-current-env (%m t))) x))) nil t t) gcl27-2.7.0/ansi-tests/plus.lsp000066400000000000000000000255431454061450500162500ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 31 04:34:17 2003 ;;;; Contains: Tests of the function + (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; (compile-and-load "plus-aux.lsp") (deftest plus.1 (+) 0) (deftest plus.2 (loop for x in *numbers* unless (eql x (+ x)) collect x) nil) (deftest plus.3 (loop for x in *numbers* for x1 = (+ x 0) for x2 = (+ 0 x) unless (and (eql x x1) (eql x x2) (eql x1 x2)) collect (list x x1 x2)) nil) (deftest plus.4 (loop for x in *numbers* for x1 = (- x x) unless (= x1 0) collect (list x x1)) nil) (deftest plus.5 (let* ((upper-bound most-positive-fixnum) (lower-bound most-negative-fixnum) (spread (- upper-bound lower-bound))) (flet ((%r () (+ (random spread) lower-bound))) (loop for x = (%r) for y = (%r) for z = (%r) for s1 = (+ x y z) for s2 = (+ z y x) for s3 = (+ y x z) for s4 = (+ x z y) for s5 = (+ z x y) for s6 = (+ y z x) repeat 1000 unless (and (eql s1 s2) (eql s1 s3) (eql s1 s4) (eql s1 s5) (eql s1 s6)) collect (list x y z s1 s2 s3 s4 s5 s6)))) nil) (deftest plus.6 (let* ((upper-bound 1000000000000000) (lower-bound -1000000000000000) (spread (- upper-bound lower-bound))) (flet ((%r () (+ (random spread) lower-bound))) (loop for x = (%r) for y = (%r) for z = (%r) for s1 = (+ x y z) for s2 = (+ z y x) for s3 = (+ y x z) for s4 = (+ x z y) for s5 = (+ z x y) for s6 = (+ y z x) repeat 1000 unless (and (eql s1 s2) (eql s1 s3) (eql s1 s4) (eql s1 s5) (eql s1 s6)) collect (list x y z s1 s2 s3 s4 s5 s6)))) nil) (deftest plus.7 (let* ((upper-bound most-positive-fixnum) (lower-bound most-negative-fixnum) (spread (- upper-bound lower-bound))) (flet ((%r () (+ (random spread) lower-bound))) (loop for x = (/ (%r) (max 1 (%r))) for y = (/ (%r) (max 1 (%r))) for z = (/ (%r) (max 1 (%r))) for s1 = (+ x y z) for s2 = (+ z y x) for s3 = (+ y x z) for s4 = (+ x z y) for s5 = (+ z x y) for s6 = (+ y z x) repeat 1000 unless (and (eql s1 s2) (eql s1 s3) (eql s1 s4) (eql s1 s5) (eql s1 s6)) collect (list x y z s1 s2 s3 s4 s5 s6) unless (= (+ x y) (let ((xn (numerator x)) (xd (denominator x)) (yn (numerator y)) (yd (denominator y))) (/ (+ (* xn yd) (* xd yn)) (* xd yd)))) collect (list x y)))) nil) (deftest plus.8 (let (args) (loop for i from 0 to (min 256 (1- call-arguments-limit)) unless (eql (apply #'+ args) (/ (* i (1+ i)) 2)) collect i do (push (1+ i) args))) nil) (deftest plus.9 (let* ((upper-bound most-positive-fixnum) (lower-bound most-negative-fixnum) (spread (- upper-bound lower-bound))) (flet ((%r () (+ (random spread) lower-bound))) (loop for xr = (%r) for xi = (%r) for yr = (%r) for yi = (%r) for x = (complex xr xi) for y = (complex yr yi) for s = (+ x y) repeat 1000 unless (eql s (complex (+ xr yr) (+ xi yi))) collect (list x y s)))) nil) (deftest plus.10 (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) for radix = (float-radix x) for (k eps-r eps-f) = (multiple-value-list (find-epsilon x)) nconc (loop for i from 1 to k for e1 = (expt radix (- i)) for y = (+ x e1) nconc (loop for j from 1 to (- k i) for e2 = (expt radix (- j)) for z = (+ x e2) unless (eql (+ y z) (+ x e1 e2)) collect (list x i j)))) nil) (deftest plus.11 (flet ((%r () (- (random most-positive-short-float) (/ most-positive-short-float 2)))) (loop for x = (%r) for y = (%r) for s = (+ x y) repeat 1000 unless (and (eql s (+ y x)) (typep s 'short-float)) collect (list x y s))) nil) (deftest plus.12 (flet ((%r () (- (random most-positive-single-float) (/ most-positive-single-float 2)))) (loop for x = (%r) for y = (%r) for s = (+ x y) repeat 1000 unless (and (eql s (+ y x)) (typep s 'single-float)) collect (list x y s))) nil) (deftest plus.13 (flet ((%r () (- (random most-positive-double-float) (/ most-positive-double-float 2)))) (loop for x = (%r) for y = (%r) for s = (+ x y) repeat 1000 unless (and (eql s (+ y x)) (typep s 'double-float)) collect (list x y s))) nil) (deftest plus.14 (flet ((%r () (- (random most-positive-long-float) (/ most-positive-long-float 2)))) (loop for x = (%r) for y = (%r) for s = (+ x y) repeat 1000 unless (and (eql s (+ y x)) (typep s 'long-float)) collect (list x y s))) nil) (deftest plus.15 (let ((bound most-positive-short-float) (bound2 most-positive-single-float)) (loop for x = (- (random bound) (/ bound 2)) for y = (- (random bound2)(/ bound2 2)) for p = (+ x y) repeat 1000 unless (and (eql p (+ y x)) (typep p 'single-float)) collect (list x y p))) nil) (deftest plus.16 (let ((bound most-positive-short-float) (bound2 most-positive-double-float)) (loop for x = (- (random bound) (/ bound 2)) for y = (- (random bound2)(/ bound2 2)) for p = (+ x y) repeat 1000 unless (and (eql p (+ y x)) (typep p 'double-float)) collect (list x y p))) nil) (deftest plus.17 (let ((bound most-positive-short-float) (bound2 most-positive-long-float)) (loop for x = (- (random bound) (/ bound 2)) for y = (- (random bound2)(/ bound2 2)) for p = (+ x y) repeat 1000 unless (and (eql p (+ y x)) (typep p 'long-float)) collect (list x y p))) nil) (deftest plus.18 (let ((bound most-positive-single-float) (bound2 most-positive-double-float)) (loop for x = (- (random bound) (/ bound 2)) for y = (- (random bound2)(/ bound2 2)) for p = (+ x y) repeat 1000 unless (and (eql p (+ y x)) (typep p 'double-float)) collect (list x y p))) nil) (deftest plus.19 (let ((bound most-positive-single-float) (bound2 most-positive-long-float)) (loop for x = (- (random bound) (/ bound 2)) for y = (- (random bound2)(/ bound2 2)) for p = (+ x y) repeat 1000 unless (and (eql p (+ y x)) (typep p 'long-float)) collect (list x y p))) nil) (deftest plus.20 (let ((bound most-positive-double-float) (bound2 most-positive-long-float)) (loop for x = (- (random bound) (/ bound 2)) for y = (- (random bound2)(/ bound2 2)) for p = (+ x y) repeat 1000 unless (and (eql p (+ y x)) (typep p 'long-float)) collect (list x y p))) nil) (deftest plus.21 (loop for type in '(short-float single-float double-float long-float) for bits in '(13 24 50 50) for bound = (ash 1 (1- bits)) nconc (loop for i = (random bound) for x = (coerce i type) for j = (random bound) for y = (coerce j type) for sum = (+ x y) repeat 1000 unless (and (eql sum (coerce (+ i j) type)) (eql sum (+ y x))) collect (list i j x y sum (coerce (+ i j) type)))) nil) (deftest plus.22 (loop for type in '(short-float single-float double-float long-float) for bits in '(13 24 50 50) for bound = (ash 1 (1- bits)) nconc (loop for one = (coerce 1 type) for i = (random bound) for x = (complex (coerce i type) one) for j = (random bound) for y = (complex (coerce j type) one) for sum = (+ x y) repeat 1000 unless (and (eql sum (complex (coerce (+ i j) type) (coerce 2 type))) (eql sum (+ y x))) collect (list i j x y sum))) nil) (deftest plus.23 (loop for type in '(short-float single-float double-float long-float) for bits in '(13 24 50 50) for bound = (ash 1 (1- bits)) nconc (loop for one = (coerce 1 type) for i = (random bound) for x = (complex one (coerce i type)) for j = (random bound) for y = (complex one (coerce j type)) for sum = (+ x y) repeat 1000 unless (and (eql sum (complex (coerce 2 type) (coerce (+ i j) type))) (eql sum (+ y x))) collect (list i j x y sum))) nil) ;;; Negative zero tests (suggested by R. Toy) (deftest plus.24 (funcall (compile nil '(lambda (x) (declare (type short-float x) (optimize (speed 3) (safety 0) (debug 0))) (+ 0.0s0 x))) -0.0s0) 0.0s0) (deftest plus.25 (funcall (compile nil '(lambda (x) (declare (type single-float x) (optimize (speed 3) (safety 0) (debug 0))) (+ 0.0f0 x))) -0.0f0) 0.0f0) (deftest plus.26 (funcall (compile nil '(lambda (x) (declare (type double-float x) (optimize (speed 3) (safety 0) (debug 0))) (+ 0.0d0 x))) -0.0d0) 0.0d0) (deftest plus.27 (funcall (compile nil '(lambda (x) (declare (type long-float x) (optimize (speed 3) (safety 0) (debug 0))) (+ 0.0l0 x))) -0.0l0) 0.0l0) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest plus.28 (macrolet ((%m (z) z)) (values (+ (expand-in-current-env (%m 1))) (+ (expand-in-current-env (%m 2)) 3) (+ 4 (expand-in-current-env (%m 5))) (+ 1/2 (expand-in-current-env (%m 6)) 2/3))) 1 5 9 43/6) ;;; Must test combinations of reals and complex arguments. ;;; Order of evaluation tests (deftest plus.order.1 (let ((i 0) x y) (values (+ (progn (setf x (incf i)) '8) (progn (setf y (incf i)) '11)) i x y)) 19 2 1 2) (deftest plus.order.2 (let ((i 0) x y z) (values (+ (progn (setf x (incf i)) '8) (progn (setf y (incf i)) '11) (progn (setf z (incf i)) '100)) i x y z)) 119 3 1 2 3) ;;; Test that compilation does not reassociate float additions (deftest plus.reassociation.1 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for eps2 = (* eps 9/10) when (eql (funcall (compile nil `(lambda () (+ ,x (+ ,eps2 ,eps2))))) x) collect (list x eps eps2)) nil) (deftest plus.reassociation.2 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for eps2 = (* eps 9/10) unless (equal (funcall (compile nil `(lambda () (list (+ (+ ,x ,eps2) ,eps2) (+ ,eps2 (+ ,eps2 ,x)))))) (list x x)) collect (list x eps eps2)) nil) (deftest plus.reassociation.3 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for eps2 = (* eps 9/10) when (eql (funcall (compile nil `(lambda (y e) (+ y (+ e e)))) x eps2) x) collect (list x eps eps2)) nil) (deftest plus.reassociation.4 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for eps2 = (* eps 9/10) unless (equal (funcall (compile nil `(lambda (y e) (list (+ (+ y e) e) (+ e (+ e y))))) x eps2) (list x x)) collect (list x eps eps2)) nil) gcl27-2.7.0/ansi-tests/plusp.lsp000066400000000000000000000024421454061450500164210ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Aug 4 21:42:14 2003 ;;;; Contains: Tests for PLUSP (in-package :cl-test) ;;; Error tests (deftest plusp.error.1 (signals-error (plusp) program-error) t) (deftest plusp.error.2 (signals-error (plusp 0 0) program-error) t) (deftest plusp.error.3 (signals-error (plusp 0 nil) program-error) t) (deftest plusp.error.4 (check-type-error #'plusp #'realp) nil) ;;; Non-error tests (deftest plusp.1 (plusp 0) nil) (deftest plusp.2 (plusp -1) nil) (deftest plusp.3 (notnot-mv (plusp 1)) t) (deftest plusp.4 (loop for x in *reals* when (if (plusp x) (<= x 0) (> x 0)) collect x) nil) (deftest plusp.5 (some #'plusp '(-0.0s0 -0.0f0 -0.0d0 -0.0l0)) nil) (deftest plusp.6 (some #'plusp '(0.0s0 0.0f0 0.0d0 0.0l0)) nil) (deftest plusp.7 (remove-if #'plusp (list least-positive-short-float least-positive-normalized-short-float least-positive-single-float least-positive-normalized-single-float least-positive-double-float least-positive-normalized-double-float least-positive-long-float least-positive-normalized-long-float most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float)) nil) gcl27-2.7.0/ansi-tests/pop.lsp000066400000000000000000000017731454061450500160620ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:27:18 2003 ;;;; Contains: Tests of POP (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest pop.3 (macrolet ((%m (z) z)) (let ((x (list 'a 'b 'c))) (values (pop (expand-in-current-env (%m x))) x))) a (b c)) ;;; 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) (def-macro-test pop.error.1 (pop x)) ;;; Need to add tests of POP vs. various accessors gcl27-2.7.0/ansi-tests/position-if-not.lsp000066400000000000000000000336311454061450500203200ustar00rootroot00000000000000;-*- 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) (deftest position-if-not-vector.14 (let* ((v1 #(x x x a b 1 d a b 2 d y y y y y)) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (values (position-if-not #'symbolp v2) (position-if-not #'symbolp v2 :from-end t))) 2 6) ;;; 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-string.14 (do-special-strings (s "12345a6 78b90" nil) (let ((pos (position-if-not (complement #'alpha-char-p) s))) (assert (eql pos 5) () "First alpha char in ~A is at position ~A" s pos))) nil) (deftest position-if-not-string.15 (do-special-strings (s "12345a6 78b90" nil) (let ((pos (position-if-not (complement #'alpha-char-p) s :from-end t))) (assert (eql pos 11) () "Last alpha char in ~A is at position ~A" s pos))) nil) (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 (check-type-error #'(lambda (x) (position-if-not #'identity x)) #'sequencep) nil) (deftest position-if-not.error.4 (signals-error (position-if-not 'identity '(a b c . d)) type-error) t) (deftest position-if-not.error.5 (signals-error (position-if-not) program-error) t) (deftest position-if-not.error.6 (signals-error (position-if-not #'null) program-error) t) (deftest position-if-not.error.7 (signals-error (position-if-not #'null nil :key) program-error) t) (deftest position-if-not.error.8 (signals-error (position-if-not #'null nil 'bad t) program-error) t) (deftest position-if-not.error.9 (signals-error (position-if-not #'null nil 'bad t :allow-other-keys nil) program-error) t) (deftest position-if-not.error.10 (signals-error (position-if-not #'null nil 1 2) program-error) t) (deftest position-if-not.error.11 (signals-error (locally (position-if-not #'identity 'b) t) type-error) t) (deftest position-if-not.error.12 (signals-error (position-if-not #'cons '(a b c d)) program-error) t) (deftest position-if-not.error.13 (signals-error (position-if-not #'car '(a b c d)) type-error) t) (deftest position-if-not.error.14 (signals-error (position-if-not #'identity '(a b c d) :key #'cdr) type-error) t) (deftest position-if-not.error.15 (signals-error (position-if-not #'identity '(a b c d) :key #'cons) program-error) t) gcl27-2.7.0/ansi-tests/position-if.lsp000066400000000000000000000321661454061450500175240ustar00rootroot00000000000000;-*- 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) (deftest position-if-vector.14 (let* ((v1 #(x x x a b 1 d a b 2 d y y y y y)) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (values (position-if #'integerp v2) (position-if #'integerp v2 :from-end t))) 2 6) ;;; 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-string.14 (do-special-strings (s "12345a6 78b90" nil) (let ((pos (position-if #'alpha-char-p s))) (assert (eql pos 5) () "First alpha char in ~A is at position ~A" s pos))) nil) (deftest position-if-string.15 (do-special-strings (s "12345a6 78b90" nil) (let ((pos (position-if #'alpha-char-p s :from-end t))) (assert (eql pos 11) () "Last alpha char in ~A is at position ~A" s pos))) nil) (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 (check-type-error #'(lambda (x) (position-if #'identity x)) #'sequencep) nil) (deftest position-if.error.4 (signals-error (position-if 'null '(a b c . d)) type-error) t) (deftest position-if.error.5 (signals-error (position-if) program-error) t) (deftest position-if.error.6 (signals-error (position-if #'null) program-error) t) (deftest position-if.error.7 (signals-error (position-if #'null nil :key) program-error) t) (deftest position-if.error.8 (signals-error (position-if #'null nil 'bad t) program-error) t) (deftest position-if.error.9 (signals-error (position-if #'null nil 'bad t :allow-other-keys nil) program-error) t) (deftest position-if.error.10 (signals-error (position-if #'null nil 1 2) program-error) t) (deftest position-if.error.11 (signals-error (locally (position-if #'identity 'b) t) type-error) t) (deftest position-if.error.12 (signals-error (position-if #'cons '(a b c d)) program-error) t) (deftest position-if.error.13 (signals-error (position-if #'car '(a b c d)) type-error) t) (deftest position-if.error.14 (signals-error (position-if #'identity '(a b c d) :key #'cdr) type-error) t) (deftest position-if.error.15 (signals-error (position-if #'identity '(a b c d) :key #'cons) program-error) t) gcl27-2.7.0/ansi-tests/position.lsp000066400000000000000000000471251454061450500171310ustar00rootroot00000000000000;-*- 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) (deftest position-list.29 (position 10 '(1 4 8 10 15 20) :test #'<) 4) (deftest position-list.30 (position 10 '(1 4 8 10 15 20) :test-not #'>=) 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) (deftest position-vector.32 (position 10 #(1 4 8 10 15 20) :test #'<) 4) (deftest position-vector.33 (position 10 #(1 4 8 10 15 20) :test-not #'>=) 4) (deftest position-vector.34 (let* ((v1 #(x x x a b c d a b c d y y y y y)) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (values (position 'c v2) (position 'c v2 :from-end t))) 2 6) ;;; 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) (deftest position-bit-vector.33 (position 0 #*1111000 :test #'>=) 4) (deftest position-bit-vector.34 (position 0 #*1111000 :test-not #'<) 4) ;;; 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-string.29 (position #\m "adfmpz" :test #'char<) 4) (deftest position-string.30 (position #\m "adfmpz" :test-not #'char>=) 4) (deftest position-string.31 (let* ((s1 (copy-seq "xxxabcdyyyyy")) (s2 (make-array '(4) :displaced-to s1 :displaced-index-offset 3 :element-type (array-element-type s1)))) (position #\c s2)) 2) (deftest position-string.32 (let* ((s1 (copy-seq "xxxabcdabcdyyyyyyyy")) (s2 (make-array '(8) :displaced-to s1 :displaced-index-offset 3 :element-type (array-element-type s1)))) (position #\c s2 :from-end t)) 6) (deftest position-string.33 (do-special-strings (s "abcdabcdabcd" nil) (let* ((c #\c) (pos (position c s))) (assert (eql pos 2) () "First position of ~A in ~A is ~A" c s pos))) nil) (deftest position-string.34 (do-special-strings (s "abcdabcdabcd" nil) (let* ((c #\c) (pos (position c s :from-end t))) (assert (eql pos 10) () "Last position of ~A in ~A is ~A" c s pos))) nil) (defharmless position.test-and-test-not.1 (position 'b '(a b c d) :test #'eql :test-not #'eql)) (defharmless position.test-and-test-not.2 (position 'b '(a b c d) :test-not #'eql :test #'eql)) (defharmless position.test-and-test-not.3 (position 'b #(a b c d) :test #'eql :test-not #'eql)) (defharmless position.test-and-test-not.4 (position 'b #(a b c d) :test-not #'eql :test #'eql)) (defharmless position.test-and-test-not.5 (position #\b "abcd" :test #'eql :test-not #'eql)) (defharmless position.test-and-test-not.6 (position #\b "abcd" :test-not #'eql :test #'eql)) (defharmless position.test-and-test-not.7 (position 1 #*001010010 :test #'eql :test-not #'eql)) (defharmless position.test-and-test-not.8 (position 0 #*1110010110111 :test-not #'eql :test #'eql)) (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 (check-type-error #'(lambda (x) (position 'a x)) #'sequencep) nil) (deftest position.error.4 (signals-error (position 'e '(a b c . d)) type-error) t) (deftest position.error.5 (signals-error (position) program-error) t) (deftest position.error.6 (signals-error (position 'a) program-error) t) (deftest position.error.7 (signals-error (position 'a nil :key) program-error) t) (deftest position.error.8 (signals-error (position 'a nil 'bad t) program-error) t) (deftest position.error.9 (signals-error (position 'a nil 'bad t :allow-other-keys nil) program-error) t) (deftest position.error.10 (signals-error (position 'a nil 1 2) program-error) t) (deftest position.error.11 (signals-error (locally (position 'a 'b) t) type-error) t) (deftest position.error.12 (signals-error (position 'b '(a b c d) :test #'identity) program-error) t) (deftest position.error.13 (signals-error (position 'b '(a b c d) :test-not #'not) program-error) t) (deftest position.error.14 (signals-error (position 'b '(a b c d) :key #'cdr) type-error) t) (deftest position.error.15 (signals-error (position 'b '(a b c d) :key #'cons) program-error) t) gcl27-2.7.0/ansi-tests/pprint-dispatch.lsp000066400000000000000000000203421454061450500203660ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jun 12 13:14:53 2004 ;;;; Contains: Tests of PPRINT-DISPATCH, SET-PPRINT-DISPATCH (in-package :cl-test) (deftest pprint-dispatch.1 (loop for x in (append *universe* *cl-symbols*) for vals = (multiple-value-list (pprint-dispatch x)) for vals2 = (multiple-value-list (pprint-dispatch x *print-pprint-dispatch*)) unless (and (= (length vals) 2) (= (length vals2) 2) (destructuring-bind (fun foundp) vals (if foundp (and (or (typep fun 'function) (and (symbolp fun) (symbol-function fun))) (destructuring-bind (fun2 foundp2) vals2 (and (equal fun fun2) foundp2))) (not (cadr vals2))))) collect (list x vals vals2)) nil) #| (deftest pprint-dispatch.2 (loop for sym in *cl-symbols* for x = (list sym nil nil) for vals = (multiple-value-list (pprint-dispatch x)) for vals2 = (multiple-value-list (pprint-dispatch x *print-pprint-dispatch*)) unless (and (= (length vals) 2) (= (length vals2) 2) (destructuring-bind (fun foundp) vals (if foundp (and (or (typep fun 'function) (and (symbolp fun) (symbol-function fun))) (destructuring-bind (fun2 foundp2) vals2 (and (equal fun fun2) foundp2))) (not (cadr vals2))))) collect (list x vals vals2)) nil) |# ;;; Test that setting the pprint dispatch of a symbol causes ;;; the printing to change, and that it can be unset. (deftest pprint-dispatch.3 (my-with-standard-io-syntax (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) (*print-readably* nil) (*print-escape* nil) (*print-pretty* t)) (let ((f #'(lambda (stream obj) (declare (ignore obj)) (write "ABC" :stream stream)))) (values (write-to-string '|X|) (set-pprint-dispatch '(eql |X|) f) (write-to-string '|X|) (set-pprint-dispatch '(eql |X|) nil) (write-to-string '|X|))))) "X" nil "ABC" nil "X") ;;; Test that setting the pprint dispatch of a symbol causes ;;; the printing to change for any real weight, and that it can be unset. (deftest pprint-dispatch.4 (my-with-standard-io-syntax (loop for v1 in (remove-if-not #'realp *universe*) unless (equal (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) (*print-readably* nil) (*print-escape* nil) (*print-pretty* t)) (let ((f #'(lambda (stream obj) (declare (ignore obj)) (write "ABC" :stream stream)))) (list (write-to-string '|X|) (set-pprint-dispatch '(eql |X|) f v1) (write-to-string '|X|) (set-pprint-dispatch '(eql |X|) nil) (write-to-string '|X|)))) '("X" nil "ABC" nil "X")) collect v1)) nil) ;;; Test that setting the pprint dispatch of a symbol causes ;;; the printing to change, and that it can be unset with any real weight (deftest pprint-dispatch.5 (my-with-standard-io-syntax (loop for v1 in (remove-if-not #'realp *universe*) unless (equal (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) (*print-readably* nil) (*print-escape* nil) (*print-pretty* t)) (let ((f #'(lambda (stream obj) (declare (ignore obj)) (write "ABC" :stream stream)))) (list (write-to-string '|X|) (set-pprint-dispatch '(eql |X|) f) (write-to-string '|X|) (set-pprint-dispatch '(eql |X|) nil v1) (write-to-string '|X|)))) '("X" nil "ABC" nil "X")) collect v1)) nil) ;;; Check that specifying the pprint-dispatch table argument to set-pprint-dispatch ;;; causes that table to be changed, not *print-pprint-dispatch*. (deftest pprint-dispatch.6 (my-with-standard-io-syntax (let ((other-ppd-table (copy-pprint-dispatch nil)) (*print-pprint-dispatch* (copy-pprint-dispatch nil)) (*print-readably* nil) (*print-escape* nil) (*print-pretty* t)) (let ((f #'(lambda (stream obj) (declare (ignore obj)) (write "ABC" :stream stream)))) (values (write-to-string '|X|) (set-pprint-dispatch '(eql |X|) f 0 other-ppd-table) (write-to-string '|X|) (let ((*print-pprint-dispatch* other-ppd-table)) (write-to-string '|X|)) (set-pprint-dispatch '(eql |X|) f) (write-to-string '|X|) (set-pprint-dispatch '(eql |X|) nil) (write-to-string '|X|))))) "X" nil "X" "ABC" nil "ABC" nil "X") ;;; Test that the default weight of set-pprint-dispatch is 0 (deftest pprint-dispatch.7 (my-with-standard-io-syntax (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) (*print-readably* nil) (*print-escape* nil) (*print-pretty* t)) (let ((f #'(lambda (stream obj) (declare (ignore obj)) (write "ABC" :stream stream))) (g #'(lambda (stream obj) (declare (ignore obj)) (write "DEF" :stream stream)))) (values (write-to-string '|X|) (set-pprint-dispatch '(eql |X|) f) (write-to-string '|X|) (set-pprint-dispatch '(member |X| |Y|) g .0001) (write-to-string '|X|) (write-to-string '|Y|))))) "X" nil "ABC" nil "DEF" "DEF") (deftest pprint-dispatch.8 (my-with-standard-io-syntax (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) (*print-readably* nil) (*print-escape* nil) (*print-pretty* t)) (let ((f #'(lambda (stream obj) (declare (ignore obj)) (write "ABC" :stream stream))) (g #'(lambda (stream obj) (declare (ignore obj)) (write "DEF" :stream stream)))) (values (write-to-string '|X|) (set-pprint-dispatch '(eql |X|) f) (write-to-string '|X|) (set-pprint-dispatch '(member |X| |Y|) g -.0001) (write-to-string '|X|) (write-to-string '|Y|))))) "X" nil "ABC" nil "ABC" "DEF") ;;; Funtion designators in pprint-dispatch (defun pprint-dispatch-test-fn.1 (stream obj) (declare (ignore obj)) (write "ABC" :stream stream)) (defun pprint-dispatch-test-fn.2 (stream obj) (declare (ignore obj)) (write "DEF" :stream stream)) (deftest pprint-dispatch.9 (my-with-standard-io-syntax (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) (*print-readably* nil) (*print-escape* nil) (*print-pretty* t)) (values (write-to-string '|X|) (multiple-value-list (set-pprint-dispatch '(eql |X|) 'pprint-dispatch-test-fn.1)) (write-to-string '|X|) (multiple-value-list (set-pprint-dispatch '(eql |X|) 'pprint-dispatch-test-fn.2)) (write-to-string '|X|)))) "X" (nil) "ABC" (nil) "DEF") #| (deftest pprint-dispatch.10 (my-with-standard-io-syntax (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) (*print-readably* nil) (*print-escape* nil) (*print-pretty* t)) (let ((f #'(lambda (stream obj) (declare (ignore obj)) (write "ABC" :stream stream))) (g #'(lambda (stream obj) (declare (ignore obj)) (write "DEF" :stream stream))) (sym (gensym))) (setf (symbol-function sym) f) (values (write-to-string '|X|) (set-pprint-dispatch '(eql |X|) sym) (write-to-string '|X|) (progn (setf (symbol-function sym) g) (write-to-string '|X|)))))) "X" nil "ABC" "DEF") |# ;;; Error tests (deftest pprint-dispatch.error.1 (signals-error (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))) (pprint-dispatch)) program-error) t) (deftest pprint-dispatch.error.2 (signals-error (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))) (pprint-dispatch nil nil nil)) program-error) t) (deftest set-pprint-dispatch.error.1 (signals-error (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))) (set-pprint-dispatch)) program-error) t) (deftest set-pprint-dispatch.error.2 (signals-error (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))) (set-pprint-dispatch t)) program-error) t) (deftest set-pprint-dispatch.error.3 (signals-error (let ((table (copy-pprint-dispatch nil))) (set-pprint-dispatch t 'identity 0 table nil)) program-error) t) (deftest set-pprint-dispatch.error.4 (loop for x in *mini-universe* unless (or (typep x 'real) (eval `(signals-error (let ((table (copy-pprint-dispatch nil))) (set-pprint-dispatch t 'identity ',x)) error))) collect x) nil) (deftest set-pprint-dispatch.error.4-unsafe (loop for x in *mini-universe* unless (or (typep x 'real) (eval `(signals-error (let ((table (copy-pprint-dispatch nil))) (declare (optimize (safety 0))) (set-pprint-dispatch t 'identity ',x)) error))) collect x) nil) gcl27-2.7.0/ansi-tests/pprint-exit-if-list-exhausted.lsp000066400000000000000000000201571454061450500231010ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jul 6 06:11:01 2004 ;;;; Contains: Tests of PPRINT-EXIT-IF-LIST-EXHAUSTED, PPRINT-POP (in-package :cl-test) (deftest pprint-exit-if-list-exhausted.1 (with-standard-io-syntax (let ((*print-pretty* nil) (*print-escape* nil) (*print-right-margin* 100) (*print-readably* nil) ) (with-output-to-string (os) (pprint-logical-block (os '(1 2)) (assert (equal (multiple-value-list (pprint-exit-if-list-exhausted)) '(nil))) (write (pprint-pop) :stream os) (assert (equal (multiple-value-list (pprint-exit-if-list-exhausted)) '(nil))) (write #\Space :stream os) (write (pprint-pop) :stream os) (pprint-exit-if-list-exhausted) (assert nil))))) "1 2") (deftest pprint-exit-if-list-exhausted.2 (with-standard-io-syntax (let ((*print-pretty* t) (*print-escape* nil) (*print-right-margin* 100) (*print-readably* nil) ) (with-output-to-string (os) (pprint-logical-block (os '(1 2)) (assert (equal (multiple-value-list (pprint-exit-if-list-exhausted)) '(nil))) (write (pprint-pop) :stream os) (assert (equal (multiple-value-list (pprint-exit-if-list-exhausted)) '(nil))) (write #\Space :stream os) (write (pprint-pop) :stream os) (pprint-exit-if-list-exhausted) (assert nil))))) "1 2") (deftest pprint-exit-if-list-exhausted.3 (with-standard-io-syntax (let ((*print-pretty* t) (*print-escape* nil) (*print-right-margin* 100) (*print-readably* nil) ) (with-output-to-string (os) (pprint-logical-block (os '(1 . 2)) (assert (equal (multiple-value-list (pprint-exit-if-list-exhausted)) '(nil))) (write (pprint-pop) :stream os) (write #\Space :stream os) (assert (equal (multiple-value-list (pprint-exit-if-list-exhausted)) '(nil))) (pprint-pop) (assert nil))))) "1 . 2") (deftest pprint-exit-if-list-exhausted.4 (with-standard-io-syntax (let ((*print-pretty* t) (*print-escape* nil) (*print-right-margin* 100) (*print-readably* nil) ) (with-output-to-string (os) (pprint-logical-block (os '(1 . 2) :prefix "[" :suffix "]") (assert (equal (multiple-value-list (pprint-exit-if-list-exhausted)) '(nil))) (write (pprint-pop) :stream os) (write #\Space :stream os) (assert (equal (multiple-value-list (pprint-exit-if-list-exhausted)) '(nil))) (pprint-pop) (assert nil))))) "[1 . 2]") ;;; Tests focusing on pprint-pop (deftest pprint-pop.1 (with-standard-io-syntax (let ((*print-pretty* t) (*print-escape* nil) (*print-right-margin* 100) (*print-readably* nil) (*print-length* 0)) (with-output-to-string (os) (pprint-logical-block (os nil) (pprint-pop) (assert nil))))) "...") (deftest pprint-pop.2 (with-standard-io-syntax (let ((*print-pretty* t) (*print-escape* nil) (*print-right-margin* 100) (*print-readably* nil) (*print-length* 0)) (with-output-to-string (os) (pprint-logical-block (os 1) (pprint-pop))))) "1") (deftest pprint-pop.3 (with-standard-io-syntax (let ((*print-pretty* t) (*print-escape* nil) (*print-right-margin* 100) (*print-readably* nil) (*print-length* 1)) (with-output-to-string (os) (pprint-logical-block (os '(1)) (assert (equal '(1) (multiple-value-list (pprint-pop)))))))) "") (deftest pprint-pop.4 (with-standard-io-syntax (let ((*print-pretty* t) (*print-escape* nil) (*print-right-margin* 100) (*print-readably* nil) (*print-length* 0)) (with-output-to-string (os) (pprint-logical-block (os '(1 2 3) :prefix "{" :suffix "}") (pprint-pop) (assert nil))))) "{...}") (deftest pprint-pop.5 (flet ((%f (len) (with-standard-io-syntax (let ((*print-pretty* t) (*print-escape* nil) (*print-right-margin* 100) (*print-readably* nil) (*print-length* len)) (with-output-to-string (os) (pprint-logical-block (os '(1 2 3 4 5) :prefix "{" :suffix "}") (pprint-exit-if-list-exhausted) (write (pprint-pop) :stream os) (loop (pprint-exit-if-list-exhausted) (write #\Space :stream os) (write (pprint-pop) :stream os)))))))) (values (%f 0) (%f 1) (%f 2) (%f 3) (%f 4) (%f 5) (%f 6))) "{...}" "{1 ...}" "{1 2 ...}" "{1 2 3 ...}" "{1 2 3 4 ...}" "{1 2 3 4 5}" "{1 2 3 4 5}") (deftest pprint-pop.6 (flet ((%f (len) (with-standard-io-syntax (let ((*print-pretty* t) (*print-escape* nil) (*print-right-margin* 100) (*print-readably* nil) (*print-length* len)) (with-output-to-string (os) (pprint-logical-block (os '(1 2 . 3) :prefix "{" :suffix "}") (pprint-exit-if-list-exhausted) (write (pprint-pop) :stream os) (loop (pprint-exit-if-list-exhausted) (write #\Space :stream os) (write (pprint-pop) :stream os)))))))) (values (%f 0) (%f 1) (%f 2) (%f 3) (%f 4))) "{...}" "{1 ...}" "{1 2 . 3}" "{1 2 . 3}" "{1 2 . 3}") ;;; pprint-pop and circularity/sharing (deftest pprint-pop.7 (flet ((%f (len) (with-standard-io-syntax (let ((*print-pretty* t) (*print-escape* nil) (*print-right-margin* 100) (*print-readably* nil) (*print-length* len) (*print-circle* t)) (with-output-to-string (os) (let* ((tail (list 1)) (x (list* tail 2 tail))) (pprint-logical-block (os x :prefix "<" :suffix ">") (pprint-exit-if-list-exhausted) (write (pprint-pop) :stream os) (loop (pprint-exit-if-list-exhausted) (write #\Space :stream os) (write (pprint-pop) :stream os))))))))) (values (%f nil) (%f 0) (%f 1) (%f 2) (%f 3) (%f 4))) "<#1=(1) 2 . #1#>" "<...>" "<(1) ...>" "<(1) 2 ...>" "<#1=(1) 2 . #1#>" "<#1=(1) 2 . #1#>") (deftest pprint-pop.8 (flet ((%f (len) (with-standard-io-syntax (let ((*print-pretty* t) (*print-escape* nil) (*print-right-margin* 100) (*print-readably* nil) (*print-length* len) (*print-circle* t)) (with-output-to-string (os) (let* ((tail (list 2)) (x (list* 1 tail))) (setf (cdr tail) tail) (pprint-logical-block (os x :prefix "[[" :suffix "]]") (pprint-exit-if-list-exhausted) (write (pprint-pop) :stream os) (loop (pprint-exit-if-list-exhausted) (write #\Space :stream os) (write (pprint-pop) :stream os))))))))) (values (%f 0) (%f 1) (%f 2) (%f 3) (%f 10) (%f 20))) "[[...]]" "[[1 ...]]" "[[1 2 ...]]" "[[1 . #1=(2 . #1#)]]" "[[1 . #1=(2 . #1#)]]" "[[1 . #1=(2 . #1#)]]") ;;; pprint-pop when pprint-logical-block is given NIL (deftest pprint-pop.9 (flet ((%f (len) (with-standard-io-syntax (let ((*print-pretty* t) (*print-escape* nil) (*print-right-margin* 100) (*print-readably* nil) (*print-length* len)) (with-output-to-string (os) (pprint-logical-block (os nil :prefix "{" :suffix "}") (let ((vals (multiple-value-list (pprint-pop)))) (assert (equal vals '(nil)) () "First call returned ~A" vals)) (write 1 :stream os) (write #\Space :stream os) (let ((vals (multiple-value-list (pprint-pop)))) (assert (equal vals '(nil)) () "Second call returned ~A" vals)) (write 2 :stream os) (write #\Space :stream os) (let ((vals (multiple-value-list (pprint-pop)))) (assert (equal vals '(nil)) () "Third call returned ~A" vals)) (write 3 :stream os) )))))) (values (%f nil) (%f 0) (%f 1) (%f 2) (%f 3) (%f 4))) "{1 2 3}" "{...}" "{1 ...}" "{1 2 ...}" "{1 2 3}" "{1 2 3}") ;;; Error cases (deftest pprint-exit-if-list-exhausted.error.1 (signals-error (pprint-exit-if-list-exhausted) error) t) (deftest pprint-exit-if-list-exhausted.error.1-unsafe (locally (declare (optimize (safety 0))) (signals-error (locally (declare (optimize (safety 0))) (pprint-exit-if-list-exhausted)) error)) t) (deftest pprint-pop.error.1 (signals-error (pprint-pop) error) t) (deftest pprint-pop.error.1-unsafe (locally (declare (optimize (safety 0))) (signals-error (locally (declare (optimize (safety 0))) (pprint-pop)) error)) t) gcl27-2.7.0/ansi-tests/pprint-fill.lsp000066400000000000000000000116001454061450500175120ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Jun 25 22:03:01 2004 ;;;; Contains: Tests of PPRINT-FILL (in-package :cl-test) ;;; When printing a non-list, the result is the same as calling WRITE." (deftest pprint-fill.1 (my-with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil)) (loop for obj in *mini-universe* nconc (and (not (listp obj)) (let ((s1 (write-to-string obj)) (s2 (with-output-to-string (s) (pprint-fill s obj)))) (unless (equal s1 s2) (list (list obj s1 s2)))))))) nil) (deftest pprint-fill.2 (my-with-standard-io-syntax (let ((*print-pretty* nil) (*print-readably* nil)) (loop for obj in *mini-universe* nconc (and (not (listp obj)) (let ((s1 (write-to-string obj)) (s2 (with-output-to-string (s) (pprint-fill s obj)))) (unless (equal s1 s2) (list (list obj s1 s2)))))))) nil) (defmacro def-pprint-fill-test (name args expected-value &key (margin 100) (circle nil) (len nil)) `(deftest ,name (my-with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* ,margin) (*package* (find-package "CL-TEST")) (*print-length* ,len) (*print-circle* ,circle)) (with-output-to-string (s) (pprint-fill s ,@args)))) ,expected-value)) (def-pprint-fill-test pprint-fill.3 ('(|A|)) "(A)") (def-pprint-fill-test pprint-fill.4 ('(|A|) t) "(A)") (def-pprint-fill-test pprint-fill.5 ('(|A|) nil) "A") (def-pprint-fill-test pprint-fill.6 ('(1 2 3 4 5)) "(1 2 3 4 5)") (def-pprint-fill-test pprint-fill.7 ('((1) (2) #(3) "abc" 5) nil) "(1) (2) #(3) \"abc\" 5") ;;; The fourth argument is ignored (def-pprint-fill-test pprint-fill.8 ('(1 2 3 4 5) t nil) "(1 2 3 4 5)") (def-pprint-fill-test pprint-fill.9 ('(1 2 3 4 5) nil t) "1 2 3 4 5") ;;; Takes T, NIL as stream designators (deftest pprint-fill.10 (my-with-standard-io-syntax (let ((*print-pretty* nil) (*print-readably* nil) (*print-right-margin* 100)) (with-output-to-string (os) (with-input-from-string (is "") (with-open-stream (*terminal-io* (make-two-way-stream is os)) (pprint-fill t '(1 2 3))))))) "(1 2 3)") (deftest pprint-fill.11 (my-with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100)) (with-output-to-string (*standard-output*) (pprint-fill nil '(1 2 3))))) "(1 2 3)") ;;; Now tests for cases that should be wrapped ;;; It's not entirely clear what they should be doing ;;; but check for some obvious properties (deftest pprint-fill.12 (my-with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*package* (find-package :cl-test)) (obj '(|M| |M| |M| |M| |M| |M| |M| |M| |M| |M|))) (loop for i from 1 to 10 for result = (let* ((*print-right-margin* i) (s (with-output-to-string (os) (terpri os) (pprint-fill os obj)))) (cond ((not (eql (elt s 0) #\Newline)) (list :bad1 s)) ((not (equal (read-from-string s) obj)) (list :bad2 s)) ((not (find #\Newline s :start 1)) (list :bad3 s)) (t t))) unless (eql result t) collect (list i result)))) nil) (deftest pprint-fill.13 (my-with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*package* (find-package :cl-test)) (obj '(|M| |M| |M| |M| |M| |M| |M| |M| |M| |M| |M|))) (loop for i from 1 to 10 for result = (let* ((*print-right-margin* i) (s (with-output-to-string (os) (terpri os) (pprint-fill os obj nil)))) (cond ((not (eql (elt s 0) #\Newline)) (list :bad1 s)) ((not (equal (read-from-string (concatenate 'string "(" s ")")) obj)) (list :bad2 s)) ((not (find #\Newline s :start 1)) (list :bad3 s)) (t t))) unless (eql result t) collect (list i result)))) nil) ;;; (def-pprint-fill-test pprint-fill.14 ((let ((x (list '|A|))) (list x x))) "(#1=(A) #1#)" :circle t) (def-pprint-fill-test pprint-fill.15 ((let ((x (list '|A|))) (setf (cdr x) x) x)) "#1=(A . #1#)" :circle t :len 500) ;;; Test that pprint-fill returns NIL (deftest pprint-fill.return-values.1 (my-with-standard-io-syntax (let ((*print-pretty* nil) (*package* (find-package "CL-TEST"))) (with-open-stream (s (make-broadcast-stream)) (pprint-fill s '(a b))))) nil) (deftest pprint-fill.return-values.2 (my-with-standard-io-syntax (let ((*print-pretty* nil) (*package* (find-package :cl-test))) (with-open-stream (s (make-broadcast-stream)) (pprint-fill s 10 nil t)))) nil) ;;; Error tests (deftest pprint-fill.error.1 (signals-error (pprint-fill) program-error) t) (deftest pprint-fill.error.2 (signals-error (pprint-fill *standard-output*) program-error) t) (deftest pprint-fill.error.3 (signals-error (pprint-fill *standard-output* nil t t t) program-error) t) gcl27-2.7.0/ansi-tests/pprint-indent.lsp000066400000000000000000000232541454061450500200550ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jul 3 08:50:40 2004 ;;;; Contains: Tests of PPRINT-INDENT (in-package :cl-test) (deftest pprint-indent.1 (with-standard-io-syntax (let ((*print-pretty* nil)) (with-open-stream (*standard-output* (make-string-output-stream)) (pprint-indent :block 0)))) nil) (deftest pprint-indent.2 (with-standard-io-syntax (let ((*print-pretty* nil)) (with-open-stream (*standard-output* (make-broadcast-stream)) (pprint-indent :current 0)))) nil) (deftest pprint-indent.3 (with-standard-io-syntax (let ((*print-pretty* nil)) (with-open-stream (s (make-string-output-stream)) (pprint-indent :current 10 s)))) nil) (deftest pprint-indent.4 (with-standard-io-syntax (let ((*print-pretty* nil)) (with-open-stream (s (make-string-output-stream)) (pprint-indent :block 1/2 s)))) nil) (deftest pprint-indent.5 (with-standard-io-syntax (let ((*print-pretty* nil)) (with-open-stream (s (make-string-output-stream)) (pprint-indent :block 0.1 s)))) nil) (deftest pprint-indent.6 (with-standard-io-syntax (let ((*print-pretty* nil)) (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) unless (equal (multiple-value-list (with-open-stream (s (make-string-output-stream)) (pprint-indent :block x s))) '(nil)) collect x))) nil) (deftest pprint-indent.7 (with-standard-io-syntax (let ((*print-pretty* nil)) (with-open-stream (*standard-output* (make-broadcast-stream)) (pprint-indent :current 0 nil)))) nil) (deftest pprint-indent.8 (with-standard-io-syntax (let ((*print-pretty* nil)) (with-open-stream (os (make-string-output-stream)) (with-open-stream (is (make-string-input-stream "")) (with-open-stream (*terminal-io* (make-two-way-stream is os)) (pprint-indent :current 0 t)))))) nil) ;;; Now test with pprint-logical-block ;;; :current (deftest pprint-indent.9 (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(|M| |M|)) (write '|M| :stream os) (pprint-indent :current 3 os) (pprint-newline :mandatory os) (write '|M| :stream os))))) "M M") (deftest pprint-indent.10 (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(|M| |M|) :prefix "(" :suffix ")") (write '|M| :stream os) (pprint-indent :current 1 os) (pprint-newline :mandatory os) (write '|M| :stream os))))) "(M M)") (deftest pprint-indent.11 (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(|M| |M|) :prefix "(" :suffix ")") (write '|M| :stream os) (pprint-indent :current -1 os) (pprint-newline :mandatory os) (write '|M| :stream os))))) "(M M)") (deftest pprint-indent.12 (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(|M| |M|) :prefix "(" :suffix ")") (write '|M| :stream os) (pprint-indent :current -2.0 os) (pprint-newline :mandatory os) (write '|M| :stream os))))) "(M M)") ;;; :block (deftest pprint-indent.13 (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(|M| |M|)) (write '|MMM| :stream os) (pprint-indent :block 0 os) (pprint-newline :mandatory os) (write '|MMMMM| :stream os))))) "MMM MMMMM") (deftest pprint-indent.13a (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(|M| |M|) :prefix "(" :suffix ")") (write '|MMM| :stream os) (pprint-indent :block 0 os) (pprint-newline :mandatory os) (write '|MMMMM| :stream os))))) "(MMM MMMMM)") (deftest pprint-indent.14 (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(|M| |M|)) (write '|MMM| :stream os) (pprint-indent :block 1 os) (pprint-newline :mandatory os) (write '|MMMMM| :stream os))))) "MMM MMMMM") (deftest pprint-indent.15 (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(|M| |M|)) (write '|MMM| :stream os) (pprint-indent :block -1 os) (pprint-newline :mandatory os) (write '|MMMMM| :stream os))))) "MMM MMMMM") (deftest pprint-indent.16 (loop for n in '(3.0s0 3.0f0 3.0d0 3.0l0) unless (string= (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(|M| |M|)) (write '|MMM| :stream os) (pprint-indent :block n os) (pprint-newline :mandatory os) (write '|MMMMM| :stream os))))) "MMM MMMMM") collect n) nil) ;;; *print-pretty* must be true for pprint-indent to have an effect (deftest pprint-indent.17 (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(|M| |M|)) (write '|M| :stream os) (let ((*print-pretty* nil)) (pprint-indent :current 3 os)) (pprint-newline :mandatory os) (write '|M| :stream os))))) "M M") (deftest pprint-indent.18 (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(|M| |M|)) (write '|M| :stream os) (let ((*print-pretty* nil)) (pprint-indent :block 3 os)) (pprint-newline :mandatory os) (write '|M| :stream os))))) "M M") ;;; indentation interaction with :per-line-prefix (deftest pprint-indent.19 (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(|M| |M| |M|) :per-line-prefix ">>>>") (write '|M| :stream os) (pprint-indent :block 2 os) (write #\Space :stream os) (write '|M| :stream os) (pprint-newline :mandatory os) (write '|M| :stream os))))) ">>>>M M >>>> M") (deftest pprint-indent.20 (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(|M| |M|) :per-line-prefix ">>>>") (write '|M| :stream os) (pprint-indent :block -1 os) (pprint-newline :mandatory os) (write '|M| :stream os))))) ">>>>M >>>>M") (deftest pprint-indent.21 (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(|M| |M| |M| |M|) :per-line-prefix ">>>>") (write '|M| :stream os) (pprint-indent :block 3 os) (pprint-newline :mandatory os) (write '|M| :stream os) (pprint-indent :current -2 os) (pprint-newline :mandatory os) (write '|M| :stream os) (pprint-indent :current -5 os) (pprint-newline :mandatory os) (write '|M| :stream os) )))) ">>>>M >>>> M >>>> M >>>>M") ;;; In miser mode, indentation is ignored (deftest pprint-indent.22 (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-miser-width* 200) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(1 2 3) :prefix "(" :suffix ")") (write 1 :stream os) (pprint-indent :current 1 os) (pprint-newline :mandatory os) (write 2 :stream os) (pprint-indent :block 3 os) (pprint-newline :mandatory os) (write 3 :stream os))))) "(1 2 3)") ;;; TERPRI or printing newline characters does not invoke indentation (deftest pprint-indent.23 (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(1 2 3 4)) (pprint-indent :block 2 os) (write 1 :stream os) (terpri os) (write 2 :stream os) (write #\Newline :stream os) (write 3 :stream os) (pprint-newline :mandatory os) (write 4 :stream os))))) "1 2 3 4") ;;; Error cases (deftest pprint-indent.error.1 (signals-error (pprint-indent) program-error) t) (deftest pprint-indent.error.2 (signals-error (pprint-indent :current) program-error) t) (deftest pprint-indent.error.3 (signals-error (pprint-indent :block 0 *standard-output* nil) program-error) t) (deftest pprint-indent.error.4 (loop for x in *mini-universe* when (and (not (member x '(:block :current))) (not (eval `(signals-error (pprint-indent ',x 0) error)))) collect x) nil) (deftest pprint-indent.error.4-unsafe (loop for x in *mini-universe* when (and (not (member x '(:block :current))) (not (eval `(signals-error (locally (declare (optimize (safety 0))) (pprint-indent ',x 0)) error)))) collect x) nil) gcl27-2.7.0/ansi-tests/pprint-linear.lsp000066400000000000000000000104761454061450500200500ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jun 26 21:55:26 2004 ;;;; Contains: Tests of PPRINT-LINEAR (in-package :cl-test) ;;; When printing a non-list, the result is the same as calling WRITE." (deftest pprint-linear.1 (my-with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil)) (loop for obj in *mini-universe* nconc (and (not (listp obj)) (let ((s1 (write-to-string obj)) (s2 (with-output-to-string (s) (assert (equal (multiple-value-list (pprint-linear s obj)) '(nil)))))) (unless (equal s1 s2) (list (list obj s1 s2)))))))) nil) (deftest pprint-linear.2 (my-with-standard-io-syntax (let ((*print-pretty* nil) (*print-readably* nil)) (loop for obj in *mini-universe* nconc (and (not (listp obj)) (let ((s1 (write-to-string obj)) (s2 (with-output-to-string (s) (assert (equal (multiple-value-list (pprint-linear s obj)) '(nil)))))) (unless (equal s1 s2) (list (list obj s1 s2)))))))) nil) (defmacro def-pprint-linear-test (name args expected-value &key (margin 100) (circle nil)) `(deftest ,name (my-with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* ,margin) (*package* (find-package "CL-TEST")) (*print-circle* ,circle)) (with-output-to-string (s) (pprint-linear s ,@args)))) ,expected-value)) (def-pprint-linear-test pprint-linear.3 ('(|A|)) "(A)") (def-pprint-linear-test pprint-linear.4 ('(|A|) t) "(A)") (def-pprint-linear-test pprint-linear.5 ('(|A|) nil) "A") (def-pprint-linear-test pprint-linear.6 ('(1 2 3 4 5)) "(1 2 3 4 5)") (def-pprint-linear-test pprint-linear.7 ('((1) (2) #(3) "abc" 5) nil) "(1) (2) #(3) \"abc\" 5") ;;; The fourth argument is ignored (def-pprint-linear-test pprint-linear.8 ('(1 2 3 4 5) t nil) "(1 2 3 4 5)") (def-pprint-linear-test pprint-linear.9 ('(1 2 3 4 5) nil t) "1 2 3 4 5") ;;; Takes T, NIL as stream designators (deftest pprint-linear.10 (my-with-standard-io-syntax (let ((*print-pretty* nil) (*print-readably* nil) (*print-right-margin* 100)) (with-output-to-string (os) (with-input-from-string (is "") (with-open-stream (*terminal-io* (make-two-way-stream is os)) (pprint-linear t '(1 2 3))))))) "(1 2 3)") (deftest pprint-linear.11 (my-with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100)) (with-output-to-string (*standard-output*) (pprint-linear nil '(1 2 3))))) "(1 2 3)") (deftest pprint-linear.12 (my-with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*package* (find-package :cl-test)) (obj '(|M| |M| |M| |M| |M| |M| |M| |M| |M| |M|))) (loop for i from 1 to 10 for result = (let* ((*print-right-margin* i) (s (with-output-to-string (os) (terpri os) (pprint-linear os obj)))) (cond ((not (eql (elt s 0) #\Newline)) (list :bad1 s)) ((not (equal (read-from-string s) obj)) (list :bad2 s)) ((< (count #\Newline s) (length obj)) (list :bad3 s)) (t t))) unless (eql result t) collect (list i result)))) nil) (deftest pprint-linear.13 (my-with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*package* (find-package :cl-test)) (obj '(|M| |M| |M| |M| |M| |M| |M| |M| |M| |M| |M|))) (loop for i from 1 to 10 for result = (let* ((*print-right-margin* i) (s (with-output-to-string (os) (terpri os) (pprint-linear os obj nil)))) (cond ((not (eql (elt s 0) #\Newline)) (list :bad1 s)) ((not (equal (read-from-string (concatenate 'string "(" s ")")) obj)) (list :bad2 s)) ((< (count #\Newline s) (length obj)) (list :bad3 s)) (t t))) unless (eql result t) collect (list i result)))) nil) ;;; (def-pprint-linear-test pprint-linear.14 ((let ((x (list '|A|))) (list x x))) "(#1=(A) #1#)" :circle t) ;;; Error tests (deftest pprint-linear.error.1 (signals-error (pprint-linear) program-error) t) (deftest pprint-linear.error.2 (signals-error (pprint-linear *standard-output*) program-error) t) (deftest pprint-linear.error.3 (signals-error (pprint-linear *standard-output* nil t t t) program-error) t) gcl27-2.7.0/ansi-tests/pprint-logical-block.lsp000066400000000000000000000175231454061450500213000ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jul 4 07:17:52 2004 ;;;; Contains: Tests of PPRINT-LOGICAL-BLOCK (in-package :cl-test) (deftest pprint-logical-block.1 (with-standard-io-syntax (let ((*print-pretty* t) (*print-right-margin* 100) (*print-readably* nil)) (with-open-stream (os (make-string-output-stream)) (values (multiple-value-list (pprint-logical-block (os 1))) (get-output-stream-string os))))) (nil) "1") (deftest pprint-logical-block.2 (with-standard-io-syntax (let ((*print-pretty* nil) (*print-right-margin* 100) (*print-readably* nil) (val '(1 a (b) (c . d) 1.0s0 2.0f0 -3.0d0 4.0l0 1/2 #(x y z)))) (string=t (with-output-to-string (s) (write val :stream s)) (with-output-to-string (s) (pprint-logical-block (s val) (write val :stream s)))))) t) (deftest pprint-logical-block.3 (with-standard-io-syntax (let ((*print-pretty* nil) (*print-right-margin* 100) (*print-readably* nil)) (with-output-to-string (*standard-output*) (pprint-logical-block (nil 1))))) "1") (deftest pprint-logical-block.4 (with-standard-io-syntax (let ((*print-pretty* nil) (*print-right-margin* 100) (*print-readably* nil)) (with-output-to-string (os) (with-input-from-string (is "") (with-open-stream (*terminal-io* (make-two-way-stream is os)) (pprint-logical-block (t 1))))))) "1") (deftest pprint-logical-block.5 (with-standard-io-syntax (let ((*print-pretty* t) (*print-right-margin* 100) (*print-readably* nil) (val '(1))) (with-output-to-string (os) (pprint-logical-block (os val) (write (car val) :stream os))))) "1") (deftest pprint-logical-block.6 (with-standard-io-syntax (let ((*print-pretty* t) (*print-right-margin* 100) (*print-readably* nil) (val '(2))) (with-output-to-string (os) (pprint-logical-block (os val :prefix "[" :suffix "]") (write (car val) :stream os))))) "[2]") (deftest pprint-logical-block.7 :notes (:nil-vectors-are-strings) (with-standard-io-syntax (let ((*print-pretty* t) (*print-right-margin* 100) (*print-readably* nil) (val '(3))) (with-output-to-string (os) (pprint-logical-block (os val :prefix (make-array '(0) :element-type nil) :suffix (make-array '(0) :element-type nil)) (write (car val) :stream os))))) "3") (deftest pprint-logical-block.8 (with-standard-io-syntax (let ((*print-pretty* t) (*print-right-margin* 100) (*print-readably* nil) (val '(4))) (with-output-to-string (os) (pprint-logical-block (os val :prefix (make-array '(10) :element-type 'character :initial-contents "abcdefghij" :fill-pointer 3) :suffix (make-array '(2) :element-type 'base-char :initial-contents "!?" :adjustable t)) (write (car val) :stream os))))) "abc4!?") (deftest pprint-logical-block.9 (with-standard-io-syntax (let ((*print-pretty* t) (*print-right-margin* 100) (*print-readably* nil) (*print-level* 1) (val '((4)))) (with-output-to-string (os) (pprint-logical-block (os val :prefix "{" :suffix "}") (pprint-logical-block (os (car val) :prefix "[" :suffix "]") (write (caar val) :stream os)))))) "{#}") (deftest pprint-logical-block.10 (with-standard-io-syntax (let ((*print-pretty* t) (*print-right-margin* 100) (*print-readably* nil) (*print-level* 0) (val '(5))) (with-output-to-string (os) (pprint-logical-block (os val :prefix "[" :suffix "]") (write (car val) :stream os))))) "#") (deftest pprint-logical-block.11 (with-standard-io-syntax (let ((*print-pretty* t) (*print-right-margin* 100) (*print-readably* nil) (val '(6))) (with-output-to-string (os) (pprint-logical-block (os val :per-line-prefix "abcd") (write (car val) :stream os))))) "abcd6") (deftest pprint-logical-block.12 (with-standard-io-syntax (let ((*print-pretty* t) (*print-right-margin* 100) (*print-readably* nil) (val '(a b c))) (with-output-to-string (os) (pprint-logical-block (os val :per-line-prefix "abcd") (write 1 :stream os) (terpri os) (terpri os) (write 2 :stream os) (terpri os) (write 3 :stream os))))) "abcd1 abcd abcd2 abcd3") ;;; Same as pprint-logical-block.10, but *print-pretty* is bound to nil (deftest pprint-logical-block.13 (with-standard-io-syntax (let ((*print-pretty* nil) (*print-right-margin* 100) (*print-readably* nil) (*print-level* 0) (val '(5))) (with-output-to-string (os) (pprint-logical-block (os val :prefix "[" :suffix "]") (write (car val) :stream os))))) "#") ;;; Both :suffix and :per-line-prefix may be supplied (deftest pprint-logical-block.14 (with-standard-io-syntax (let ((*print-pretty* t) (*print-right-margin* 100) (*print-readably* nil) (val '(6))) (with-output-to-string (os) (pprint-logical-block (os val :per-line-prefix "[" :suffix "]") (write (car val) :stream os))))) "[6]") ;;; Declarations are allowed (deftest pprint-logical-block.15 (with-standard-io-syntax (let ((*print-pretty* t) (x 0)) (with-output-to-string (os) (declare (integer x)) (declare (optimize (safety 3)))))) "") ;;; Two conditions that cause :prefix, :suffix to be omitted (deftest pprint-logical-block.16 (with-standard-io-syntax (let ((*print-pretty* t) (*print-right-margin* 100) (*print-readably* nil) (val 9)) (with-output-to-string (os) (pprint-logical-block (os val :prefix "[" :suffix "]") (write val :stream os))))) "9") (deftest pprint-logical-block.17 (with-standard-io-syntax (let* ((*print-pretty* t) (*print-right-margin* 100) (*print-readably* nil) (*print-circle* t) (v1 '(8)) (val (list v1 v1))) (with-output-to-string (os) (pprint-logical-block (os val :prefix "(" :suffix ")") (pprint-logical-block (os (car val) :prefix "(" :suffix ")") (write (caar val) :stream os)) (write-char #\Space os) (pprint-logical-block (os (cadr val) :prefix "(" :suffix ")") (write (caadr val) :stream os)))))) "(#1=(8) #1#)") ;;; Error cases (deftest pprint-logical-block.error.1 (check-type-error #'(lambda (x) (pprint-logical-block (*standard-output* '(1) :prefix x))) #'stringp) nil) (deftest pprint-logical-block.error.1-unsafe (check-type-error #'(lambda (x) (declare (optimize (safety 0))) (pprint-logical-block (*standard-output* '(1) :prefix x))) #'stringp) nil) (deftest pprint-logical-block.error.2 (check-type-error #'(lambda (x) (pprint-logical-block (*standard-output* '(1) :suffix x))) #'stringp) nil) (deftest pprint-logical-block.error.2-unsafe (check-type-error #'(lambda (x) (declare (optimize (safety 0))) (pprint-logical-block (*standard-output* '(1) :suffix x))) #'stringp) nil) (deftest pprint-logical-block.error.3 (check-type-error #'(lambda (x) (pprint-logical-block (*standard-output* '(1) :per-line-prefix x))) #'stringp) nil) (deftest pprint-logical-block.error.3-unsafe (check-type-error #'(lambda (x) (declare (optimize (safety 0))) (pprint-logical-block (*standard-output* '(1) :per-line-prefix x))) #'stringp) nil) (deftest pprint-logical-block.error.4 (signals-error (with-standard-io-syntax (let ((*print-pretty* t) (*print-right-margin* 100) (*print-readably* nil) (val '(7))) (pprint-logical-block (os val :prefix "" :per-line-prefix "") (write (car val) :stream os)))) error) t) (deftest pprint-logical-block.error.4-unsafe (signals-error (with-standard-io-syntax (let ((*print-pretty* t) (*print-right-margin* 100) (*print-readably* nil) (val '(7))) (pprint-logical-block (os val :prefix "" :per-line-prefix "") (write (car val) :stream os)))) error :safety 0) t) gcl27-2.7.0/ansi-tests/pprint-newline.lsp000066400000000000000000000232601454061450500202320ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jul 7 07:48:01 2004 ;;;; Contains: Tests of PPRINT-NEWLINE (in-package :cl-test) (compile-and-load "printer-aux.lsp") (defmacro def-pprint-newline-test (name form expected-value &rest key-args) `(def-pprint-test ,name (with-output-to-string (*standard-output*) (pprint-logical-block (*standard-output* nil) ,form)) ,expected-value ,@key-args)) ;;; NIL designates the standard output (def-pprint-test pprint-newline.1 (with-output-to-string (*standard-output*) (pprint-logical-block (*standard-output* nil) (dotimes (i 8) (write-char #\A) (write-char #\Space) (pprint-newline :fill nil)))) "A A A A A A A A " :margin 10) ;;; T designates the stream *terminal-io* (def-pprint-test pprint-newline.2 (with-output-to-string (os) (with-input-from-string (is "") (with-open-stream (*terminal-io* (make-two-way-stream is os)) (pprint-logical-block (*terminal-io* nil) (dotimes (i 8) (write "A " :stream t) (pprint-newline :fill t)))))) "A A A A A A A A " :margin 10) ;;; No stream is standard output (def-pprint-test pprint-newline.3 (with-output-to-string (*standard-output*) (pprint-logical-block (*standard-output* nil) (dotimes (i 8) (write-char #\A) (write-char #\Space) (pprint-newline :fill)))) "A A A A A A A A " :margin 10) ;;; :linear (def-ppblock-test pprint-newline.linear.1 (progn (dotimes (i 2) (write "A ") (pprint-newline :fill)) (write "B ") (pprint-newline :linear) (dotimes (i 3) (write "A ") (pprint-newline :fill))) "A A B A A A " :margin 10) (def-ppblock-test pprint-newline.linear.2 (progn (dotimes (i 2) (write "A ") (pprint-newline :fill)) (write "B ") (pprint-newline :linear) (dotimes (i 2) (write "C ") (pprint-newline :fill)) (write "D ") (pprint-newline :linear) (dotimes (i 3) (write "A ") (pprint-newline :fill))) "A A B C C D A A A " :margin 10) (def-ppblock-test pprint-newline.linear.3 (dotimes (i 4) (write "A ") (pprint-newline :linear)) "A A A A " :margin 10) (def-ppblock-test pprint-newline.linear.4 (dotimes (i 4) (write "A ") (pprint-newline :linear)) "A A A A " :margin 10 :miser 10) (def-ppblock-test pprint-newline.linear.5 (dotimes (i 10) (write "A ") (pprint-newline :linear)) "A A A A A A A A A A " :margin 10 :pretty nil) (def-ppblock-test pprint-newline.linear.6 (dotimes (i 4) (write "A ") (pprint-newline :linear)) "A A A A " :margin 10) (def-ppblock-test pprint-newline.linear.7 (progn (dotimes (i 4) (write "A ") (pprint-newline :linear)) (terpri) (dotimes (i 4) (write "A ") (pprint-newline :linear))) "A A A A A A A A " :margin 10) (def-ppblock-test pprint-newline.linear.8 (progn (pprint-logical-block (*standard-output* nil) (dotimes (i 4) (write "A ") (pprint-newline :linear))) (pprint-newline :linear) (pprint-logical-block (*standard-output* nil) (dotimes (i 4) (write "A ") (pprint-newline :linear)))) "A A A A A A A A " :margin 10) (def-ppblock-test pprint-newline.linear.9 (dotimes (i 10) (write "A ") (let ((*print-pretty* nil)) (pprint-newline :linear))) "A A A A A A A A A A " :margin 10) (deftest pprint-newline.linear.10 (with-standard-io-syntax (let ((*print-readably* nil) (*print-escape* nil) (*print-pretty* t) (*print-right-margin* 4) (*print-miser-width* nil)) (with-output-to-string (*standard-output*) (dotimes (i 5) (write "A ") (pprint-newline :linear))))) "A A A A A ") ;;; :miser (def-ppblock-test pprint-newline.miser.1 (dotimes (i 10) (write "A ") (pprint-newline :miser)) "A A A A A A A A A A " :margin 10) (def-ppblock-test pprint-newline.miser.2 (dotimes (i 10) (write "A ") (pprint-newline :miser)) "A A A A A A A A A A " :margin 10 :miser 0) (def-ppblock-test pprint-newline.miser.3 (dotimes (i 10) (write "A ") (pprint-newline :miser)) "A A A A A A A A A A " :margin 10 :miser 9) (def-ppblock-test pprint-newline.miser.4 (dotimes (i 10) (write "A ") (pprint-newline :miser)) "A A A A A A A A A A " :margin 10 :miser 10) (def-ppblock-test pprint-newline.miser.5 (dotimes (i 10) (write "A ") (pprint-newline :miser)) "A A A A A A A A A A " :margin 10 :miser 10 :pretty nil) (def-ppblock-test pprint-newline.miser.6 (progn (terpri) (write "A") (pprint-newline :miser)) " A " :margin 20 :miser 20) (def-ppblock-test pprint-newline.miser.7 (progn (pprint-newline :miser) (write "A") (terpri)) " A " :margin 20 :miser 20) (def-ppblock-test pprint-newline.miser.8 (progn (write "AAAA ") (pprint-newline :linear) (pprint-logical-block (*standard-output* nil) (dotimes (i 4) (write "A ") (pprint-newline :miser)))) "AAAA A A A A " :margin 10 :miser 8) (def-ppblock-test pprint-newline.miser.9 (progn (write "AAAA ") (pprint-newline :fill) (pprint-logical-block (*standard-output* nil) (dotimes (i 4) (write "A ") (pprint-newline :miser)))) "AAAA A A A A " :margin 10 :miser 8) (def-ppblock-test pprint-newline.miser.10 (pprint-logical-block (*standard-output* nil :prefix "(" :suffix ")") (write "A") (pprint-newline :miser) (pprint-newline :mandatory)) "(A )" :margin 20 :miser 20) (def-ppblock-test pprint-newline.miser.11 (pprint-logical-block (*standard-output* nil :prefix "(" :suffix ")") (write "A") (pprint-newline :miser) (pprint-newline :mandatory)) "(A )" :margin 20 :miser 19) (def-ppblock-test pprint-newline.miser.12 (pprint-logical-block (*standard-output* nil :prefix "(" :suffix ")") (write "A") (pprint-newline :miser) (pprint-newline :mandatory)) "(A )" :margin 20 :miser 18) (deftest pprint-newline.miser.13 (with-standard-io-syntax (let ((*print-readably* nil) (*print-escape* nil) (*print-pretty* t) (*print-right-margin* 4) (*print-miser-width* 4)) (with-output-to-string (*standard-output*) (dotimes (i 5) (write "A ") (pprint-newline :miser))))) "A A A A A ") ;;; :fill (def-ppblock-test pprint-newline.fill.1 (dotimes (i 10) (write "A ") (pprint-newline :fill)) "A A A A A A A A A A " :margin 10) (def-ppblock-test pprint-newline.fill.2 (dotimes (i 10) (write "A ") (pprint-newline :fill)) "A A A A A A A A A A " :margin 6) (def-ppblock-test pprint-newline.fill.3 (dotimes (i 10) (write "A ") (pprint-newline :fill)) "A A A A A A A A A A " :margin 7) (def-ppblock-test pprint-newline.fill.4 (dotimes (i 10) (write "A ") (pprint-newline :fill)) "A A A A A A A A A A " :margin 10 :miser 9) (def-ppblock-test pprint-newline.fill.5 (dotimes (i 10) (write "A ") (pprint-newline :fill)) "A A A A A A A A A A " :margin 10 :miser 10) (def-ppblock-test pprint-newline.fill.6 (dotimes (i 5) (write '(A B)) (write #\Space) (pprint-newline :fill)) "(A B) (A B) (A B) (A B) (A B) " :margin 12) (def-ppblock-test pprint-newline.fill.7 (dolist (x '(A (A B) (A A A A A A A A) X (C D) (E F))) (pprint-fill nil x) (write #\Space) (pprint-newline :fill)) "A (A B) (A A A A A A A A) X (C D) (E F) " :margin 12) (def-ppblock-test pprint-newline.fill.8 (dotimes (i 5) (write '(A B) :pretty nil) (write #\Space) (let ((*print-pretty* nil)) (pprint-newline :fill))) "(A B) (A B) (A B) (A B) (A B) " :margin 12) (deftest pprint-newline.fill.9 (with-standard-io-syntax (let ((*print-readably* nil) (*print-escape* nil) (*print-right-margin* 4) (*print-pretty* t) (*print-miser-width* nil)) (with-output-to-string (*standard-output*) (dotimes (i 5) (write "A ") (pprint-newline :fill))))) "A A A A A ") (deftest pprint-newline.fill.10 (with-standard-io-syntax (let ((*print-readably* nil) (*print-escape* nil) (*print-right-margin* 4) (*print-pretty* t) (*print-miser-width* 4)) (with-output-to-string (*standard-output*) (dotimes (i 5) (write "A ") (pprint-newline :fill))))) "A A A A A ") ;;; :mandatory (def-ppblock-test pprint-newline.mandatory.1 (dotimes (i 4) (write "A ") (pprint-newline :mandatory)) "A A A A ") (def-ppblock-test pprint-newline.mandatory.2 (dotimes (i 4) (write "A ") (pprint-newline :mandatory)) "A A A A " :margin 10) (def-ppblock-test pprint-newline.mandatory.3 (progn (write "A ") (pprint-newline :mandatory) (write "A ")) "A A " :margin 1) (def-ppblock-test pprint-newline.mandatory.4 (dotimes (i 4) (write "A ") (pprint-newline :mandatory)) "A A A A " :pretty nil) (def-ppblock-test pprint-newline.mandatory.5 (pprint-logical-block (*standard-output* nil :prefix "<<<" :suffix ">>>") (dotimes (i 4) (write "A ") (pprint-newline :mandatory)) (write "A")) "<<>>") (deftest pprint-newline.mandatory.6 (with-standard-io-syntax (let ((*print-readably* nil) (*print-escape* nil) (*print-pretty* t) (*print-right-margin* 4) (*print-miser-width* nil)) (with-output-to-string (*standard-output*) (dotimes (i 5) (write "A ") (pprint-newline :mandatory))))) "A A A A A ") ;;; Error cases (deftest pprint-newline.error.1 (check-type-error #'pprint-newline (typef '(member :linear :miser :fill :mandatory))) nil) (deftest pprint-newline.error.1-unsafe (check-type-error #'(lambda (x) (declare (optimize (safety 0))) (pprint-newline x)) (typef '(member :linear :miser :fill :mandatory))) nil) (deftest pprint-newline.error.2 (signals-error (pprint-newline) program-error) t) (deftest pprint-newline.error.3 (signals-error (pprint-newline :fill nil nil) program-error) t) gcl27-2.7.0/ansi-tests/pprint-tab.lsp000066400000000000000000000145001454061450500173340ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jul 10 14:08:08 2004 ;;;; Contains: Tests of PPRINT-TAB (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; No effect in a non-pprint stream (def-pprint-test pprint-tab.non-pretty.1 (with-output-to-string (*standard-output*) (write "A") (pprint-tab :line 10 3) (write "B")) "AB") (def-pprint-test pprint-tab.non-pretty.2 (with-output-to-string (*standard-output*) (write "A") (pprint-tab :section 10 3) (write "B")) "AB") (def-pprint-test pprint-tab.non-pretty.3 (with-output-to-string (*standard-output*) (write "A") (pprint-tab :line-relative 10 3) (write "B")) "AB") (def-pprint-test pprint-tab.non-pretty.4 (with-output-to-string (*standard-output*) (write "A") (pprint-tab :section-relative 10 3) (write "B")) "AB") (def-ppblock-test pprint-tab.non-pretty.5 (progn (write "A") (pprint-tab :line 10 3) (write "B")) "AB" :pretty nil) (def-ppblock-test pprint-tab.non-pretty.6 (progn (write "A") (pprint-tab :section 10 3) (write "B")) "AB" :pretty nil) (def-ppblock-test pprint-tab.non-pretty.7 (progn (write "A") (pprint-tab :line-relative 10 3) (write "B")) "AB" :pretty nil) (def-ppblock-test pprint-tab.non-pretty.8 (progn (write "A") (pprint-tab :section-relative 10 3) (write "B")) "AB" :pretty nil) ;;; nil designates *standard-output* (def-ppblock-test pprint-tab.nil.1 (progn (write "A") (pprint-tab :line 10 1 nil) (write "B")) "A B") ;;; t designates *terminal-io* (def-pprint-test pprint-tab.t.1 (with-output-to-string (os) (with-input-from-string (is "") (with-open-stream (*terminal-io* (make-two-way-stream is os)) (pprint-logical-block (*terminal-io* nil) (write "A" :stream t) (pprint-tab :line 10 1 t) (write "B" :stream t))))) "A B") ;;; Now test actual tabbing behavior ;;; NOTE ;;; I am assuming that when colnum <= current column, ;;; and the current column == colnum + k * colinc for some positive integer k, ;;; then pprint-tab :line will tab at least 1 space. (def-pprint-test pprint-tab.line.1 (loop for offset = (random 100) for colnum = (random 100) for colinc = (min (random 50) (random 50)) for s = (with-output-to-string (*standard-output*) (pprint-logical-block (*standard-output* nil) (dotimes (i offset) (write #\Space)) (pprint-tab :line colnum colinc) (write #\A))) for expected-col = (cond ((< offset colnum) colnum) ((= colinc 0) offset) ((= offset colnum) (+ offset colinc)) (t (let ((k (mod (- colnum offset) colinc))) (if (= k 0) (+ offset colinc) (+ offset k))))) repeat 200 nconc (unless (string= s (concatenate 'string (make-string expected-col :initial-element #\Space) "A")) (list (list offset colnum colinc expected-col (count #\Space s) s)))) nil :margin 1000) (def-pprint-test pprint-tab.section.1 (loop for prefix-length = (random 50) for offset = (random 50) for colnum = (random 50) for colinc = (min (random 50) (random 50)) for s = (with-output-to-string (*standard-output*) (pprint-logical-block (*standard-output* nil :prefix (make-string prefix-length :initial-element #\Space)) (dotimes (i offset) (write #\Space)) (pprint-tab :section colnum colinc) (write #\A))) for expected-col = (+ prefix-length (cond ((< offset colnum) colnum) ((= colinc 0) offset) ((= offset colnum) (+ offset colinc)) (t (let ((k (mod (- colnum offset) colinc))) (if (= k 0) (+ offset colinc) (+ offset k)))))) repeat 200 nconc (unless (string= s (concatenate 'string (make-string expected-col :initial-element #\Space) "A")) (list (list offset colnum colinc expected-col (count #\Space s) s)))) nil :margin 1000) (def-pprint-test pprint-tab.line-relative.1 (loop for offset = (random 100) for colrel = (random 100) for colinc = (1+ (min (random 50) (random 50))) for extra = (mod (- (+ offset colrel)) colinc) for s = (with-output-to-string (*standard-output*) (pprint-logical-block (*standard-output* nil) (dotimes (i offset) (write #\Space)) (pprint-tab :line-relative colrel colinc) (write #\A))) for expected-col = (+ offset colrel extra) repeat 200 nconc (unless (string= s (concatenate 'string (make-string expected-col :initial-element #\Space) "A")) (list (list offset colrel colinc expected-col (count #\Space s) s)))) nil :margin 1000) (def-pprint-test pprint-tab.section-relative.1 (loop for prefix-length = (random 50) for offset = (random 50) for colrel = (random 50) for colinc = (1+ (min (random 50) (random 50))) for extra = (mod (- (+ offset colrel)) colinc) for s = (with-output-to-string (*standard-output*) (pprint-logical-block (*standard-output* nil :prefix (make-string prefix-length :initial-element #\Space)) (dotimes (i offset) (write #\Space)) (pprint-tab :section-relative colrel colinc) (write #\A))) for expected-col = (+ prefix-length offset colrel extra) repeat 200 nconc (unless (string= s (concatenate 'string (make-string expected-col :initial-element #\Space) "A")) (list (list prefix-length offset colrel colinc extra expected-col (count #\Space s) s)))) nil :margin 1000) ;;; Error cases (deftest pprint-tab.error.1 (signals-error (pprint-tab) program-error) t) (deftest pprint-tab.error.2 (signals-error (pprint-tab :line) program-error) t) (deftest pprint-tab.error.3 (signals-error (pprint-tab :line 1) program-error) t) (deftest pprint-tab.error.4 (signals-error (pprint-tab :line 1 1 nil nil) program-error) t) (deftest pprint-tab.error.5 (loop for x in *mini-universe* unless (or (member x '(:line :section :line-relative :section-relative)) (eval `(signals-error (pprint-tab ',x 1 1) error))) collect x) nil) (deftest pprint-tab.error.5-unsafe (loop for x in *mini-universe* unless (or (member x '(:line :section :line-relative :section-relative)) (eval `(signals-error (locally (declare (optimize (safety 0))) (pprint-tab ',x 1 1)) error))) collect x) nil) gcl27-2.7.0/ansi-tests/pprint-tabular.lsp000066400000000000000000000115171454061450500202250ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jun 27 06:29:39 2004 ;;;; Contains: Tests of PPRINT-TABULAR (in-package :cl-test) ;;; When printing a non-list, the result is the same as calling WRITE." (deftest pprint-tabular.1 (my-with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil)) (loop for obj in *mini-universe* nconc (and (not (listp obj)) (let ((s1 (write-to-string obj)) (s2 (with-output-to-string (s) (pprint-tabular s obj)))) (unless (equal s1 s2) (list (list obj s1 s2)))))))) nil) (deftest pprint-tabular.2 (my-with-standard-io-syntax (let ((*print-pretty* nil) (*print-readably* nil)) (loop for obj in *mini-universe* nconc (and (not (listp obj)) (let ((s1 (write-to-string obj)) (s2 (with-output-to-string (s) (pprint-tabular s obj)))) (unless (equal s1 s2) (list (list obj s1 s2)))))))) nil) (defmacro def-pprint-tabular-test (name args expected-value &key (margin 100) (circle nil) (pre nil)) `(deftest ,name (my-with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* ,margin) (*package* (find-package :cl-test)) (*print-circle* ,circle)) (with-output-to-string (s) ,@(when pre (list pre)) (pprint-tabular s ,@args)))) ,expected-value)) ;;; ;;; Note ;;; The prefix and suffix "(" and ")" are not considered part of the ;;; logical block they enclose (see the spec page for pprint-logical-block. ;;; (def-pprint-tabular-test pprint-tabular.3 ('(|M|)) "(M)") (def-pprint-tabular-test pprint-tabular.4 ('(|M|) t) "(M)") (def-pprint-tabular-test pprint-tabular.5 ('(|M|) nil) "M") (def-pprint-tabular-test pprint-tabular.6 ('(|M| |M|)) "(M M)") (def-pprint-tabular-test pprint-tabular.7 ('(|M| |M|) t nil 1) "(M M)") (def-pprint-tabular-test pprint-tabular.8 ('(|M| |M|) t t 3) "(M M)") (def-pprint-tabular-test pprint-tabular.9 ('(|M| |M|) t nil 4) "(M M)") (def-pprint-tabular-test pprint-tabular.10 ('(|MM| |MM|) t nil 4) "(MM MM)") (def-pprint-tabular-test pprint-tabular.11 ('(|MM| |MM|) t nil 5) "(MM MM)") (def-pprint-tabular-test pprint-tabular.12 ('(|M| |MM|) t nil 5) "(M MM)") (def-pprint-tabular-test pprint-tabular.13 ((let ((x (list '|A|))) (list x x)) t nil 1) "(#1=(A) #1#)" :circle t) (def-pprint-tabular-test pprint-tabular.14 ('(|M| |M|) t t 4) "(M M)") (def-pprint-tabular-test pprint-tabular.15 ('(1 2 3 4) t t 1) "(1 2 3 4)") (def-pprint-tabular-test pprint-tabular.16 ('(10 20 30 40) t t 1) "(10 20 30 40)") (def-pprint-tabular-test pprint-tabular.17 ('(10 200 3000 40000) t t 1) "(10 200 3000 40000)") (def-pprint-tabular-test pprint-tabular.18 ('(10 20 30 40) t t 2) "(10 20 30 40)") (def-pprint-tabular-test pprint-tabular.19 ('(10 200 3000 40000) t t 2) "(10 200 3000 40000)") (def-pprint-tabular-test pprint-tabular.20 ('(1 2 3) t nil 1) " (1 2 3)" :pre (write " " :stream s :escape nil)) (def-pprint-tabular-test pprint-tabular.21 ('(1 2 3) t nil 1) " (1 2 3)" :pre (write " " :stream s :escape nil) :margin 9) (def-pprint-tabular-test pprint-tabular.22 ('(1 2 3) t nil 1) " (1 2 3)" :pre (write " " :stream s :escape nil) :margin 10) ;;; Takes T, NIL as stream designators (deftest pprint-tabular.23 (my-with-standard-io-syntax (let ((*print-pretty* nil) (*print-readably* nil) (*print-right-margin* 100)) (with-output-to-string (os) (with-input-from-string (is "") (with-open-stream (*terminal-io* (make-two-way-stream is os)) (pprint-tabular t '(1 2 3) t nil 1)))))) "(1 2 3)") (deftest pprint-tabular.24 (my-with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100)) (with-output-to-string (*standard-output*) (pprint-tabular nil '(1 2 3) t nil 1)))) "(1 2 3)") ;;; FIXME: add test for colon-p argument of NIL ;;; Test that pprint-tabular returns NIL (deftest pprint-tabular.return-values.1 (my-with-standard-io-syntax (let ((*print-pretty* nil) (*package* (find-package :cl-test))) (with-open-stream (s (make-broadcast-stream)) (pprint-tabular s '(a b))))) nil) (deftest pprint-tabular.return-values.2 (my-with-standard-io-syntax (let ((*print-pretty* nil) (*package* (find-package :cl-test))) (with-open-stream (s (make-broadcast-stream)) (pprint-tabular s 10 nil nil 100)))) nil) ;;; Error tests (deftest pprint-tabular.error.1 (signals-error (pprint-tabular) program-error) t) (deftest pprint-tabular.error.2 (signals-error (pprint-tabular *standard-output*) program-error) t) (deftest pprint-tabular.error.3 (signals-error (pprint-tabular *standard-output* nil t nil 1 nil) program-error) t) (deftest pprint-tabular.error.4 (signals-error (pprint-tabular *standard-output* '(a b c) t t 1 nil) program-error) t) gcl27-2.7.0/ansi-tests/pprint.lsp000066400000000000000000000015651454061450500165770ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jul 25 11:42:48 2004 ;;;; Contains: Tests of PPRINT (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; This function is mostly tested elsewhere (deftest pprint.1 (random-pprint-test 1000) nil) (deftest pprint.2 (with-standard-io-syntax (with-output-to-string (os) (with-input-from-string (is "") (with-open-stream (*terminal-io* (make-two-way-stream is os)) (pprint 2 t))))) " 2") (deftest pprint.3 (with-standard-io-syntax (with-output-to-string (*standard-output*) (pprint 3 nil))) " 3") ;;; Error tests (deftest pprint.error.1 (signals-error (with-output-to-string (*standard-output*) (pprint)) program-error) t) (deftest pprint.error.2 (signals-error (with-output-to-string (s) (pprint nil s nil)) program-error) t) gcl27-2.7.0/ansi-tests/prin1-to-string.lsp000066400000000000000000000010421454061450500202260ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jul 26 12:18:22 2004 ;;;; Contains: Tests of PRIN1-TO-STRING (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest prin1-to-string.1 (random-prin1-to-string-test 5) nil) (deftest prin1-to-string.2 (with-standard-io-syntax (prin1-to-string 2)) "2") ;;; Error tests (deftest prin1-to-string.error.1 (signals-error (prin1-to-string) program-error) t) (deftest prin1-to-string.error.2 (signals-error (prin1-to-string nil nil) program-error) t) gcl27-2.7.0/ansi-tests/prin1.lsp000066400000000000000000000015461454061450500163130ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jul 25 11:33:40 2004 ;;;; Contains: Tests of PRIN1 (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; This function is mostly tested elsewhere (deftest prin1.1 (random-prin1-test 1000) nil) (deftest prin1.2 (with-standard-io-syntax (with-output-to-string (os) (with-input-from-string (is "") (with-open-stream (*terminal-io* (make-two-way-stream is os)) (prin1 2 t))))) "2") (deftest prin1.3 (with-standard-io-syntax (with-output-to-string (*standard-output*) (prin1 3 nil))) "3") ;;; Error tests (deftest prin1.error.1 (signals-error (with-output-to-string (*standard-output*) (prin1)) program-error) t) (deftest prin1.error.2 (signals-error (with-output-to-string (s) (prin1 nil s nil)) program-error) t) gcl27-2.7.0/ansi-tests/princ-to-string.lsp000066400000000000000000000010461454061450500203140ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jul 26 12:19:32 2004 ;;;; Contains: Tests of PRINC-TO-STRING (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest princ-to-string.1 (random-princ-to-string-test 1000) nil) (deftest princ-to-string.2 (with-standard-io-syntax (princ-to-string 2)) "2") ;;; Error tests (deftest princ-to-string.error.1 (signals-error (princ-to-string) program-error) t) (deftest princ-to-string.error.2 (signals-error (princ-to-string nil nil) program-error) t) gcl27-2.7.0/ansi-tests/princ.lsp000066400000000000000000000015431454061450500163720ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jul 25 11:40:37 2004 ;;;; Contains: Tests of PRINC (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; This function is mostly tested elsewhere (deftest princ.1 (random-princ-test 5) nil) (deftest princ.2 (with-standard-io-syntax (with-output-to-string (os) (with-input-from-string (is "") (with-open-stream (*terminal-io* (make-two-way-stream is os)) (princ 2 t))))) "2") (deftest princ.3 (with-standard-io-syntax (with-output-to-string (*standard-output*) (princ 3 nil))) "3") ;;; Error tests (deftest princ.error.1 (signals-error (with-output-to-string (*standard-output*) (princ)) program-error) t) (deftest princ.error.2 (signals-error (with-output-to-string (s) (princ nil s nil)) program-error) t) gcl27-2.7.0/ansi-tests/print-array.lsp000066400000000000000000000366371454061450500175430ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Apr 22 22:38:11 2004 ;;;; Contains: Tests of printing of arrays (other than vectors) (compile-and-load "printer-aux.lsp") (in-package :cl-test) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Zero dimensional arrays (deftest print.array.0.1 (let ((a (make-array nil :initial-element 0))) (with-standard-io-syntax (write-to-string a :readably nil :array t))) "#0A0") (deftest print.array.0.2 (with-standard-io-syntax (let ((a (make-array nil :initial-element '|A|)) (*package* (find-package "CL-TEST"))) (write-to-string a :readably nil :array t))) "#0AA") (deftest print.array.0.3 (let* ((a (make-array nil :initial-element 0)) (result (write-to-string a :readably nil :array nil))) (values (subseq result 0 2) (subseq result (1- (length result))))) "#<" ">") (deftest print.array.0.4 (let ((a (make-array nil :initial-element 0 :adjustable t))) (with-standard-io-syntax (write-to-string a :readably nil :array t))) "#0A0") (deftest print.array.0.5 (let* ((a (make-array nil :initial-element 0 :adjustable t)) (b (make-array nil :displaced-to a :displaced-index-offset 0))) (with-standard-io-syntax (write-to-string b :readably nil :array t))) "#0A0") (deftest print.array.0.6 (let ((a (make-array nil :initial-element 0 :element-type '(integer 0 2)))) (with-standard-io-syntax (write-to-string a :readably nil :array t))) "#0A0") (deftest print.array.0.7 (loop for a = (make-array nil :initial-element (- (random 1000000) 500000)) repeat 30 nconc (randomly-check-readability a :test #'is-similar)) nil) (deftest print.array.0.8 (loop for i from 1 to 64 for type = `(unsigned-byte ,i) nconc (let ((a (make-array nil :initial-element 1 :element-type type))) (loop repeat 5 nconc (randomly-check-readability a :test #'is-similar :can-fail t)))) nil) (deftest print.array.0.9 (loop for a = (make-array nil :initial-element (random 1000000) :adjustable t) repeat 30 nconc (randomly-check-readability a :test #'is-similar)) nil) (deftest print.array.0.10 (loop for a = (make-array nil :initial-element (random 1000000000)) for b = (make-array nil :displaced-to a :displaced-index-offset 0) repeat 30 nconc (randomly-check-readability b :test #'is-similar)) nil) (deftest print.array.0.11 (loop for type in '(short-float single-float double-float long-float float) for zero = (coerce 0 type) for a = (make-array nil :initial-element zero :element-type type) nconc (loop repeat 30 nconc (randomly-check-readability a :test #'is-similar :can-fail t))) nil) (deftest print.array.0.12 (loop for type0 in '(short-float single-float double-float long-float float) for type = `(complex ,type0) for zero = (complex (coerce 0.0s0 type0)) for a = (make-array nil :initial-element zero :element-type type) nconc (loop repeat 30 nconc (randomly-check-readability a :test #'is-similar :can-fail t))) nil) (deftest print.array.0.13 (let ((result (write-to-string (make-array nil :initial-element 0) :readably nil :array nil))) (values (subseq result 0 2) (subseq result (1- (length result))))) "#<" ">") (deftest print.array.0.14 (loop for i from 1 to 64 for type = `(unsigned-byte ,i) for a = (make-array nil :element-type type :initial-element 1) for result = (write-to-string a :readably nil :array nil) unless (and (string= (subseq result 0 2) "#<") (string= (subseq result (1- (length result))) ">")) collect (list i result)) nil) (deftest print.array.0.15 (loop for i from 1 to 64 for type = `(signed-byte ,i) for a = (make-array nil :element-type type :initial-element -1) for result = (write-to-string a :readably nil :array nil) unless (and (string= (subseq result 0 2) "#<") (string= (subseq result (1- (length result))) ">")) collect (list i result)) nil) (deftest print.array.0.16 (loop for type in '(short-float single-float double-float long-float) for a = (make-array nil :element-type type :initial-element (coerce 17 type)) for result = (write-to-string a :readably nil :array nil) unless (and (string= (subseq result 0 2) "#<") (string= (subseq result (1- (length result))) ">")) collect (list type result)) nil) (deftest print.array.0.17 (loop for type0 in '(short-float single-float double-float long-float float real) for type = `(complex ,type0) for a = (make-array nil :element-type type :initial-element (complex 0 (coerce 3 type0))) for result = (write-to-string a :readably nil :array nil) unless (and (string= (subseq result 0 2) "#<") (string= (subseq result (1- (length result))) ">")) collect (list type result)) nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Two-d arrays (deftest print.array.2.1 (let ((a (make-array '(1 1) :initial-contents '((1))))) (with-standard-io-syntax (write-to-string a :readably nil :array t))) "#2A((1))") (deftest print.array.2.2 (let ((a (make-array '(2 3) :initial-contents '((1 3 8)(2 6 10))))) (with-standard-io-syntax (write-to-string a :readably nil :array t))) "#2A((1 3 8) (2 6 10))") (deftest print.array.2.3 (let ((a (make-array '(0 1)))) (with-standard-io-syntax (write-to-string a :readably nil :array t))) "#2A()") (deftest print.array.2.4 (let ((a (make-array '(1 0)))) (with-standard-io-syntax (write-to-string a :readably nil :array t))) "#2A(())") (deftest print.array.2.5 (let ((a (make-array '(0 0)))) (with-standard-io-syntax (write-to-string a :readably nil :array t))) "#2A()") (deftest print.array.2.6 (let ((a (make-array '(10 0)))) (with-standard-io-syntax (write-to-string a :readably nil :array t))) "#2A(() () () () () () () () () ())") (deftest print.array.2.7 (let* ((a (make-array '(3 3) :initial-contents '((1 3 8) (2 67 121) (65 432 6)))) (b (make-array '(3 3) :displaced-to a :displaced-index-offset 0))) (with-standard-io-syntax (write-to-string b :readably nil :array t))) "#2A((1 3 8) (2 67 121) (65 432 6))") (deftest print.array.2.8 (let* ((a (make-array '(3 3) :initial-contents '((1 3 8) (2 67 121) (65 432 6)))) (b (make-array '(2 3) :displaced-to a :displaced-index-offset 0))) (with-standard-io-syntax (write-to-string b :readably nil :array t))) "#2A((1 3 8) (2 67 121))") (deftest print.array.2.9 (let* ((a (make-array '(3 3) :initial-contents '((1 3 8) (2 67 121) (65 432 6)))) (b (make-array '(2 2) :displaced-to a :displaced-index-offset 4))) (with-standard-io-syntax (write-to-string b :readably nil :array t))) "#2A((67 121) (65 432))") (deftest print.array.2.10 (let* ((a (make-array '(3 3) :initial-contents '((1 3 8) (2 67 121) (65 432 6)))) (b (make-array '(2 2) :displaced-to a :displaced-index-offset 4 :adjustable t))) (with-standard-io-syntax (write-to-string b :readably nil :array t))) "#2A((67 121) (65 432))") (deftest print.array.2.11 (let* ((a (make-array '(3 4) :initial-contents '((7 8 9 10) (65 12 42 -1) (:|W| :|X| :|Y| :|Z| )) :adjustable t))) (with-standard-io-syntax (write-to-string a :readably nil :array t))) "#2A((7 8 9 10) (65 12 42 -1) (:W :X :Y :Z))") (deftest print.array.2.12 (let ((desired-result "#2A((0 1 1) (1 1 0))")) (loop for i from 2 to 64 for a = (make-array '(2 3) :element-type `(unsigned-byte ,i) :initial-contents '((0 1 1) (1 1 0))) for result = (with-standard-io-syntax (write-to-string a :readably nil :array t)) unless (string= desired-result result) collect (list i a result))) nil) (deftest print.array.2.13 (let ((desired-result "#2A((0 -1 -1) (-1 -1 0))")) (loop for i from 1 to 64 for a = (make-array '(2 3) :element-type `(signed-byte ,i) :initial-contents '((0 -1 -1) (-1 -1 0))) for result = (with-standard-io-syntax (write-to-string a :readably nil :array t)) unless (string= desired-result result) collect (list i a result))) nil) (deftest print.array.2.14 (let ((desired-result "#2A((0 1 1) (1 1 0))")) (loop for i from 2 to 64 for a = (make-array '(2 3) :element-type `(unsigned-byte ,i) :adjustable t :initial-contents '((0 1 1) (1 1 0))) for result = (with-standard-io-syntax (write-to-string a :readably nil :array t)) unless (string= desired-result result) collect (list i a result))) nil) (deftest print.array.2.15 (let ((desired-result "#2A((0 -1 -1) (-1 -1 0))")) (loop for i from 1 to 64 for a = (make-array '(2 3) :element-type `(signed-byte ,i) :adjustable t :initial-contents '((0 -1 -1) (-1 -1 0))) for result = (with-standard-io-syntax (write-to-string a :readably nil :array t)) unless (string= desired-result result) collect (list i a result))) nil) (deftest print.array.2.16 (let ((desired-result "#2A((1 1) (1 0))")) (loop for i from 2 to 64 for type = `(unsigned-byte ,i) for a = (make-array '(2 3) :element-type type :adjustable t :initial-contents '((0 1 1) (1 1 0))) for b = (make-array '(2 2) :displaced-to a :displaced-index-offset 2 :element-type type) for result = (with-standard-io-syntax (write-to-string b :readably nil :array t)) unless (string= desired-result result) collect (list i b result))) nil) (deftest print.array.2.17 (let ((desired-result "#2A((1 -1) (-2 0))")) (loop for i from 2 to 64 for type = `(signed-byte ,i) for a = (make-array '(2 3) :element-type type :adjustable t :initial-contents '((0 1 1) (-1 -2 0))) for b = (make-array '(2 2) :displaced-to a :displaced-index-offset 2 :element-type type) for result = (with-standard-io-syntax (write-to-string b :readably nil :array t)) unless (string= desired-result result) collect (list i b result))) nil) (deftest print.array.2.20 (let* ((a (make-array '(9) :initial-contents '(1 3 8 2 67 121 65 432 6))) (b (make-array '(2 2) :displaced-to a :displaced-index-offset 1))) (with-standard-io-syntax (write-to-string b :readably nil :array t))) "#2A((3 8) (2 67))") (deftest print.array.2.21 (trim-list (loop for dims = (list (random 4) (random 4)) for a = (make-array dims :initial-element (- (random 1000000) 500000)) repeat 100 nconc (let ((result (randomly-check-readability a :test #'is-similar :can-fail t))) (and result (list (cons dims (first result)))))) 10) nil) (deftest print.array.2.22 (loop for a = (make-array (list (random 4) (random 4)) :initial-element (- (random 1000000) 500000) :adjustable t) repeat 100 nconc (randomly-check-readability a :test #'is-similar :can-fail t)) nil) (deftest print.array.2.23 (loop for d1 = (random 10) for d2 = (random 10) for a = (make-array (list d1 d2) :initial-element (- (random 1000000) 500000)) for d1a = (random (1+ d1)) for d2a = (random (1+ d2)) for offset = (random (1+ (- (* d1 d2) (* d1a d2a)))) for b = (make-array (list d1a d2a) :displaced-to a :displaced-index-offset offset) repeat 100 nconc (randomly-check-readability b :test #'is-similar :can-fail t)) nil) (deftest print.array.2.24 (loop for i from 1 to 64 for type = `(unsigned-byte ,i) nconc (let ((a (make-array '(3 4) :initial-element 1 :element-type type))) (loop repeat 5 nconc (randomly-check-readability a :test #'is-similar :can-fail t)))) nil) (deftest print.array.2.25 (let ((a (make-array '(3 4) :initial-element #\a :element-type 'character))) (loop repeat 10 nconc (randomly-check-readability a :test #'is-similar :can-fail t))) nil) (deftest print.array.2.26 (let ((a (make-array '(3 4) :initial-element #\a :element-type 'base-char))) (loop repeat 10 nconc (randomly-check-readability a :test #'is-similar :can-fail t))) nil) (deftest print.array.2.27 (let ((str (write-to-string (make-array '(2 3) :initial-element 0) :readably nil :array nil))) (values (subseq str 0 2) (subseq str (1- (length str))))) "#<" ">") (deftest print.array.2.28 (loop for i from 1 to 64 for type = `(unsigned-byte ,i) for a = (make-array '(4 3) :element-type type :initial-element 1) for result = (write-to-string a :readably nil :array nil) unless (and (string= (subseq result 0 2) "#<") (string= (subseq result (1- (length result))) ">")) collect (list i result)) nil) (deftest print.array.2.29 (loop for i from 1 to 64 for type = `(signed-byte ,i) for a = (make-array '(4 8) :element-type type :initial-element -1) for result = (write-to-string a :readably nil :array nil) unless (and (string= (subseq result 0 2) "#<") (string= (subseq result (1- (length result))) ">")) collect (list i result)) nil) (deftest print.array.2.30 (loop for type in '(short-float single-float double-float long-float) for a = (make-array '(5 7) :element-type type :initial-element (coerce 17 type)) for result = (write-to-string a :readably nil :array nil) unless (and (string= (subseq result 0 2) "#<") (string= (subseq result (1- (length result))) ">")) collect (list type result)) nil) (deftest print.array.2.31 (loop for type0 in '(short-float single-float double-float long-float float real) for type = `(complex ,type0) for a = (make-array '(13 5) :element-type type :initial-element (complex 0 (coerce 3 type0))) for result = (write-to-string a :readably nil :array nil) unless (and (string= (subseq result 0 2) "#<") (string= (subseq result (1- (length result))) ">")) collect (list type result)) nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Three D arrays (deftest print.array.3.1 (let* ((a (make-array '(1 2 3) :initial-contents '(((:|A| :|B| :|C|) (:|D| :|E| :|F|))))) (b (make-array '(3 2 1) :displaced-to a :displaced-index-offset 0))) (with-standard-io-syntax (values (write-to-string a :readably nil :array t) (write-to-string b :readably nil :array t)))) "#3A(((:A :B :C) (:D :E :F)))" "#3A(((:A) (:B)) ((:C) (:D)) ((:E) (:F)))") ;;; Multidimensional arrays (deftest print.array.multi-dim.1 (with-standard-io-syntax (loop for d in (remove array-rank-limit '(4 5 6 7 8 9 10 12 16 20 30 40 100 200 400 600 800 1023) :test #'<=) for dims = (make-list d :initial-element 1) for a = (make-array dims :initial-element 0) for result = (with-standard-io-syntax (write-to-string a :readably nil :array t)) for expected-result = (concatenate 'string (format nil "#~DA" d) (make-string d :initial-element #\() "0" (make-string d :initial-element #\))) unless (string= result expected-result) collect (list d result expected-result))) nil) (deftest print.array.multi-dim.2 (with-standard-io-syntax (loop for d = (+ 4 (random (min (- array-rank-limit 4) 1000))) for p = (random d) for dims = (let ((list (make-list d :initial-element 1))) (setf (elt list p) 0) list) for a = (make-array dims :initial-element 0) for result = (with-standard-io-syntax (write-to-string a :readably nil :array t)) for expected-result = (concatenate 'string (format nil "#~DA" d) (make-string (1+ p) :initial-element #\() (make-string (1+ p) :initial-element #\))) repeat 50 unless (string= result expected-result) collect (list d result expected-result))) nil) ;;; To add: more tests for high dimensional arrays, including arrays with ;;; element types gcl27-2.7.0/ansi-tests/print-backquote.lsp000066400000000000000000000062541454061450500203730ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jun 10 19:31:01 2004 ;;;; Contains: Tests of printing of backquote forms (and fragments thereof) (in-package :cl-test) (compile-and-load "printer-aux.lsp") (compile-and-load "backquote-aux.lsp") (deftest print.backquote.random.1 (let* ((x '`(a ,b ,@c (d . ,e) ,.f #(1 2 ,p ,@q ,.r s) g)) (y (copy-tree x))) (or (loop repeat 20 nconc (randomly-check-readability y :test #'is-similar)) (and (not (equal x y)) (list :modified x y)))) nil) (deftest print.backquote.random.2 (let* ((x '`(,@a ,@b)) (y (copy-tree x))) (or (loop repeat 20 nconc (randomly-check-readability y :test #'is-similar)) (and (not (is-similar x y)) (list :modified x y)))) nil) (deftest print.backquote.random.3 (let* ((x '`(,.a ,.b)) (y (copy-tree x))) (or (loop repeat 20 nconc (randomly-check-readability y :test #'is-similar)) (and (not (is-similar x y)) (list :modified x y)))) nil) (deftest print.backquote.random.4 (let* ((x '`(,a ,b)) (y (copy-tree x))) (or (loop repeat 20 nconc (randomly-check-readability y :test #'is-similar)) (and (not (is-similar x y)) (list :modified x y)))) nil) (deftest print.backquote.random.5 (let* ((x '`#(,a ,b)) (y (copy-tree x))) (or (loop repeat 20 nconc (randomly-check-readability y :test #'is-similar)) (and (not (is-similar x y)) (list :modified x y)))) nil) (deftest print.backquote.random.6 (let ((x '`(,@a ,@b))) (and (consp x) (symbolp (car x)) (loop repeat 20 nconc (randomly-check-readability (list (car x)) :test #'is-similar)))) nil) (deftest print.backquote.random.7 (let ((x '`(,.a ,.b))) (and (consp x) (symbolp (car x)) (loop repeat 20 nconc (randomly-check-readability (list (car x)) :test #'is-similar)))) nil) (deftest print.backquote.random.8 (let ((x '`(,a ,b))) (and (consp x) (symbolp (car x)) (loop repeat 20 nconc (randomly-check-readability (list (car x)) :test #'is-similar)))) nil) (deftest print.backquote.random.9 (let ((x '`#(,a ,b))) (and (consp x) (symbolp (car x)) (loop repeat 20 nconc (randomly-check-readability (list (car x)) :test #'is-similar)))) nil) (deftest print.backquote.random.10 (let ((x '`#(,a , .b))) (loop repeat 20 nconc (randomly-check-readability x :test #'is-similar))) nil) (deftest print.backquote.random.11 (let ((x '`#(,a , @b))) (loop repeat 20 nconc (randomly-check-readability x :test #'is-similar))) nil) (deftest print.backquote.random.12 (let ((x '`#(,a ,b c))) (and (consp x) (symbolp (car x)) (loop repeat 20 nconc (randomly-check-readability (list (car x)) :test #'is-similar)))) nil) (deftest print.backquote.random.13 (let* ((x '`#(,a ,b c)) (y (copy-tree x))) (or (loop repeat 20 nconc (randomly-check-readability x :test #'is-similar)) (and (not (is-similar x y)) (list :modified x y)))) nil) (deftest print.backquote.random.14 (loop for x = (make-random-backquoted-form 100) repeat 500 nconc (randomly-check-readability x :test #'is-similar)) nil)gcl27-2.7.0/ansi-tests/print-bit-vector.lsp000066400000000000000000000032651454061450500204720ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Apr 20 22:10:53 2004 ;;;; Contains: Tests for printing of bit vectors (compile-and-load "printer-aux.lsp") (in-package :cl-test) (deftest print.bit-vector.1 (with-standard-io-syntax (write-to-string #* :readably nil :escape nil)) "#*") (deftest print.bit-vector.2 (with-standard-io-syntax (subseq (write-to-string #* :readably nil :escape nil :array nil) 0 2)) "#<") (deftest print.bit-vector.3 (with-standard-io-syntax (write-to-string #*001101010011011 :readably nil :escape nil)) "#*001101010011011") (deftest print.bit-vector.4 (with-standard-io-syntax (subseq (write-to-string #*11010011010110101 :readably nil :escape nil :array nil) 0 2)) "#<") (deftest print.bit-vector.5 (let* ((bv1 #*0001100101) (bv2 (make-array 5 :displaced-to bv1 :displaced-index-offset 1 :element-type 'bit))) (with-standard-io-syntax (write-to-string bv2 :readably nil :escape nil))) "#*00110") (deftest print.bit-vector.6 (let* ((bv (make-array 10 :element-type 'bit :initial-contents '(1 0 0 1 0 0 1 1 1 0) :fill-pointer 5))) (with-standard-io-syntax (write-to-string bv :readably nil :escape nil))) "#*10010") (deftest print.bit-vector.7 (let* ((bv (make-array 10 :element-type 'bit :initial-contents '(1 0 0 1 0 0 1 1 1 0) :adjustable t))) (with-standard-io-syntax (write-to-string bv :readably nil :escape nil))) "#*1001001110") (deftest print.bit-vector.random (loop for len = (random 100) for bv = (coerce (loop repeat len collect (random 2)) 'bit-vector) repeat 1000 nconc (randomly-check-readability bv)) nil) gcl27-2.7.0/ansi-tests/print-characters.lsp000066400000000000000000000057361454061450500205400ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Mar 5 07:12:20 2004 ;;;; Contains: Tests for printing of characters (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; See CLtS section 22.1.3.2, "Printing Characters" (deftest print.char.1 (with-standard-io-syntax (loop for c across +standard-chars+ unless (equal (string c) (with-output-to-string (s) (princ c s))) collect c)) nil) (deftest print.char.2 (with-standard-io-syntax (loop for c across +code-chars+ unless (equal (string c) (with-output-to-string (s) (princ c s))) collect c)) nil) (deftest print.char.3 (with-standard-io-syntax (let ((*print-readably* nil)) (loop for c across +base-chars+ unless (or (eql c #\Space) (equal (format nil "#\\~C" c) (with-output-to-string (s) (prin1 c s)))) collect c))) nil) (deftest print.char.4 (with-standard-io-syntax (let ((*print-readably* nil)) (with-output-to-string (s) (prin1 #\Space s)))) "#\\ ") (deftest print.char.5 (with-standard-io-syntax (let ((*print-readably* nil)) (with-output-to-string (s) (prin1 #\Newline s)))) "#\\Newline") (deftest print.char.6 (with-standard-io-syntax (let ((*print-readably* nil)) (with-output-to-string (s) (princ #\Newline s)))) #.(string #\Newline)) (deftest print.char.7 (with-standard-io-syntax (let ((*print-readably* nil)) (loop for c across +code-chars+ for str = (with-output-to-string (s) (prin1 c s)) for len = (length str) unless (and (>= len 3) (equal (subseq str 0 2) "#\\") (or (= len 3) (let ((name (subseq str 2))) (eql c (name-char name))))) collect c))) nil) (deftest print.char.8 (loop for i = (random (min char-code-limit (ash 1 16))) for c = (code-char i) repeat 1000 unless (null c) nconc (let ((result (randomly-check-readability c))) (and result (list (cons i (first result)))))) nil) (deftest print.char.9 (loop for i = (random (min char-code-limit (ash 1 32))) for c = (code-char i) repeat 1000 unless (null c) nconc (let ((result (randomly-check-readability c))) (and result (list (cons i (first result)))))) nil) (deftest print.char.10 (with-standard-io-syntax (let ((*print-readably* nil)) (loop for c across +standard-chars+ for str = (with-output-to-string (s) (prin1 c s)) unless (or (eql c #\Newline) (equal str (concatenate 'string "#\\" (string c)))) collect (list c str)))) nil) (deftest print.char.11 (with-standard-io-syntax (let ((*print-readably* nil)) (let ((names '("Newline" "Tab" "Rubout" "Linefeed" "Page" "Backspace" "Return"))) (loop for name in names for c = (name-char name) for str = (with-output-to-string (s) (prin1 c s)) unless (or (null c) (and (>= (length str) 3) (equal (subseq str 0 2) "#\\") (member (subseq str 2) names :test #'equal))) collect (list c str))))) nil)gcl27-2.7.0/ansi-tests/print-complex.lsp000066400000000000000000000024271454061450500200620ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Mar 3 06:44:04 2004 ;;;; Contains: Tests of printing complex numbers (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest print.complex.1 (equalt (with-standard-io-syntax (let ((*print-readably* nil)) (with-output-to-string (s) (prin1 (complex 1 2) s)))) "#C(1 2)") t) (deftest print.complex.2 (equalt (with-standard-io-syntax (let ((*print-readably* nil)) (with-output-to-string (s) (prin1 (complex 1.0 2.0) s)))) "#C(1.0 2.0)") t) (deftest print.complex.random.1 (loop for numbits = (random 40) for bound = (ash 1 numbits) for r = (- (random (+ bound bound)) bound) for i = (- (random (+ bound bound)) bound) repeat 1000 unless (= i 0) nconc (randomly-check-readability (complex r i))) nil) (deftest print.complex.random.2 (loop for numbits = (random 40) for bound = (ash 1 numbits) for num1 = (- (random (+ bound bound)) bound) for num2 = (- (random (+ bound bound)) bound) for denom1 = (1+ (random bound)) for denom2 = (1+ (random bound)) for r = (/ num1 denom1) for i = (/ num2 denom2) repeat 1000 unless (= i 0) nconc (randomly-check-readability (complex r i))) nil) ;; General floating point complex printing tests will go here gcl27-2.7.0/ansi-tests/print-cons.lsp000066400000000000000000000105501454061450500173510ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Apr 19 07:28:40 2004 ;;;; Contains: Tests of printing of conses (compile-and-load "printer-aux.lsp") (in-package :cl-test) (deftest print.cons.1 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(|A|) :case :upcase :pretty nil :escape nil))) "(A)") (deftest print.cons.2 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(|A| |B|) :case :upcase :pretty nil :escape nil))) "(A B)") (deftest print.cons.3 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string (cons '|A| '|B|) :case :upcase :pretty nil :escape nil))) "(A . B)") (deftest print.cons.4 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string (let ((s '#:|X|)) (cons s s)) :case :upcase :pretty nil :escape t))) "(#:X . #:X)") (deftest print.cons.5 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string (let ((s '#:|X|)) (cons s s)) :case :upcase :pretty nil :escape t :circle t))) "(#1=#:X . #1#)") (deftest print.cons.6 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string (let ((s1 (make-symbol "X")) (s2 (make-symbol "X"))) (list s1 s2 s1 s2)) :case :upcase :pretty nil :escape t :circle t))) "(#1=#:X #2=#:X #1# #2#)") (deftest print.cons.7 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string (let ((a (list 17 nil))) (setf (cdr a) a) a) :circle t :pretty nil :escape nil))) "#1=(17 . #1#)") ;;; Random printing (deftest print.cons.random.1 (trim-list (loop for x = (make-random-cons-tree (random 100)) repeat 50 nconc (randomly-check-readability x)) 10) nil) ;; random circular cons graphs #-lispworks (deftest print.cons.random.2 (loop repeat 50 nconc (let* ((n 20) (conses (apply #'vector (loop repeat n collect (cons nil nil))))) (loop for x across conses for j = (random n) for k = (random n) do (setf (car x) (elt conses j) (cdr x) (elt conses k))) (randomly-check-readability (elt conses 0) :test #'is-similar :circle t))) nil) ;;; Printing with *print-length* (deftest print.cons.length.1 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(a) :length 0 :pretty nil :escape nil))) "(...)") (deftest print.cons.length.2 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(81) :length 1 :pretty nil :escape nil))) "(81)") (deftest print.cons.length.3 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(4 . 8) :length 1 :pretty nil :escape nil))) "(4 . 8)") (deftest print.cons.length.4 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(4 8) :length 1 :pretty nil :escape nil))) "(4 ...)") (deftest print.cons.length.5 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(a b c d e f g h i j k l m n o p) :case :downcase :length 10 :pretty nil :escape nil))) "(a b c d e f g h i j ...)") (deftest print.cons.length.6 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(((((((0))))))) :case :downcase :length 3 :pretty nil :escape nil))) "(((((((0)))))))") ;;; Printing with *print-level* (deftest print.cons.level.1 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(a) :case :downcase :level 0 :escape nil :pretty nil))) "#") (deftest print.cons.level.2 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(a) :case :downcase :level 1 :escape nil :pretty nil))) "(a)") (deftest print.cons.level.3 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '((a)) :case :downcase :level 1 :escape nil :pretty nil))) "(#)") (deftest print.cons.level.4 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(a) :case :downcase :level 2 :escape nil :pretty nil))) "(a)") (deftest print.cons.level.5 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(#(a) #*1101 "abc") :case :downcase :level 1 :pretty nil))) "(# #*1101 \"abc\")") gcl27-2.7.0/ansi-tests/print-floats.lsp000066400000000000000000000310221454061450500176740ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Mar 2 07:32:57 2004 ;;;; Contains: Tests of printing of floating point numbers (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest print.short-float.1 (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* 'short-float)) (loop for i from -4000 to 4000 for f = (float i 0.0s0) for s1 = (with-output-to-string (s) (prin1 f s)) for s2 = (format nil "~A.0" i) unless (equalp s1 s2) collect (list i f s1 s2)))) nil) (deftest print.short-float.2 (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* 'short-float)) (loop for i = (- (random 20000000) 10000000) for f = (float i 0.0s0) for s1 = (with-output-to-string (s) (prin1 f s)) for s2 = (format nil "~A.0" i) repeat 10000 unless (or (/= i (rational f)) ; not enough bits ;; (> (nth-value 1 (integer-decode-float f)) 0) (equalp s1 s2)) collect (list i f s1 s2)))) nil) (defparameter *possible-short-float-exponent-markers* (loop for type in '(short-float single-float double-float long-float) for c across "SFDL" when (subtypep 'short-float type) nconc (list c (char-downcase c)))) (deftest print.short-float.3 (let ((chars *possible-short-float-exponent-markers*)) (loop for type in '(single-float double-float long-float) nconc (and (not (subtypep 'short-float type)) (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* type)) (loop for i from -4000 to 4000 for f = (float i 0.0s0) for s1 = (with-output-to-string (s) (prin1 f s)) for len1 = (length s1) for s2 = (format nil "~A.0" i) unless (and (> len1 4) (string-equal s1 s2 :start1 0 :end1 (- len1 2)) (eql (char s1 (- len1 1)) #\0) (member (char s1 (- len1 2)) chars)) collect (list type i f s1 s2))))))) nil) (deftest print.short-float.4 (let ((chars *possible-short-float-exponent-markers*)) (loop for type in '(single-float double-float long-float) nconc (and (not (subtypep 'short-float type)) (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* type)) (loop for i = (- (random 20000000) 10000000) for f = (float i 0.0s0) for s1 = (with-output-to-string (s) (prin1 f s)) for len1 = (length s1) for s2 = (format nil "~A.0" i) repeat 10000 unless (or (/= i (rational f)) ;; not enough bits ;; (> (nth-value 1 (integer-decode-float f)) 0) (and (> len1 4) (string-equal s1 s2 :start1 0 :end1 (- len1 2)) (eql (char s1 (- len1 1)) #\0) (member (char s1 (- len1 2)) chars))) collect (list type i f s1 s2))))))) nil) (deftest print.short-float.random (let ((lower-bound (if (< (log least-positive-short-float 10) -100) (expt 0.1s0 100) least-positive-short-float)) (upper-bound (/ (if (> (log most-positive-short-float 10) 100) (expt 10.0s0 100) most-positive-short-float) 10))) (loop for sf = lower-bound then (* 10 sf) while (< sf upper-bound) nconc (loop for x = (handler-case (random sf) (arithmetic-error (c) 0.0s0)) for y = (if (coin) (- x) x) repeat 10 nconc (randomly-check-readability y)))) nil) ;;; single floats (deftest print.single-float.1 (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* 'single-float)) (loop for i from -4000 to 4000 for f = (float i 0.0f0) for s1 = (with-output-to-string (s) (prin1 f s)) for s2 = (format nil "~A.0" i) unless (equalp s1 s2) collect (list i f s1 s2)))) nil) (deftest print.single-float.2 (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* 'single-float)) (loop for i = (- (random 20000000) 10000000) for f = (float i 0.0f0) for s1 = (with-output-to-string (s) (prin1 f s)) for s2 = (format nil "~A.0" i) repeat 10000 unless (or (/= i (rational f)) ;; not enough bits ;; (> (nth-value 1 (integer-decode-float f)) 0) (equalp s1 s2)) collect (list i f s1 s2)))) nil) (defparameter *possible-single-float-exponent-markers* (loop for type in '(short-float single-float double-float long-float) for c across "SFDL" when (subtypep 'single-float type) nconc (list c (char-downcase c)))) (deftest print.single-float.3 (let ((chars *possible-single-float-exponent-markers*)) (loop for type in '(short-float double-float long-float) nconc (and (not (subtypep 'single-float type)) (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* type)) (loop for i from -4000 to 4000 for f = (float i 0.0f0) for s1 = (with-output-to-string (s) (prin1 f s)) for len1 = (length s1) for s2 = (format nil "~A.0" i) unless (and (> len1 4) (string-equal s1 s2 :start1 0 :end1 (- len1 2)) (eql (char s1 (- len1 1)) #\0) (member (char s1 (- len1 2)) chars)) collect (list type i f s1 s2))))))) nil) (deftest print.single-float.4 (let ((chars *possible-single-float-exponent-markers*)) (loop for type in '(short-float double-float long-float) nconc (and (not (subtypep 'single-float type)) (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* type)) (loop for i = (- (random 20000000) 10000000) for f = (float i 0.0f0) for s1 = (with-output-to-string (s) (prin1 f s)) for len1 = (length s1) for s2 = (format nil "~A.0" i) repeat 10000 unless (or (/= i (rational f)) ;; not enough bits ;; (> (nth-value 1 (integer-decode-float f)) 0) (and (> len1 4) (string-equal s1 s2 :start1 0 :end1 (- len1 2)) (eql (char s1 (- len1 1)) #\0) (member (char s1 (- len1 2)) chars))) collect (list type i f s1 s2))))))) nil) (deftest print.single-float.random (let ((lower-bound (if (< (log least-positive-single-float 10) -100) (expt 0.1f0 100) least-positive-single-float)) (upper-bound (/ (if (> (log most-positive-single-float 10) 100) (expt 10.0f0 100) most-positive-single-float) 10))) (loop for f = lower-bound then (* 10 f) while (< f upper-bound) nconc (loop for x = (handler-case (random f) (arithmetic-error (c) 0.0f0)) for y = (if (coin) (- x) x) repeat 10 nconc (randomly-check-readability y)))) nil) ;;; double float (deftest print.double-float.1 (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* 'double-float)) (loop for i from -4000 to 4000 for f = (float i 0.0d0) for s1 = (with-output-to-string (s) (prin1 f s)) for s2 = (format nil "~A.0" i) unless (equalp s1 s2) collect (list i f s1 s2)))) nil) (deftest print.double-float.2 (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* 'double-float)) (loop for i = (- (random 20000000) 10000000) for f = (float i 0.0d0) for s1 = (with-output-to-string (s) (prin1 f s)) for s2 = (format nil "~A.0" i) repeat 10000 unless (or (/= i (rational f)) ;; not enough bits ;; (> (nth-value 1 (integer-decode-float f)) 0) (equalp s1 s2)) collect (list i f s1 s2)))) nil) (defparameter *possible-double-float-exponent-markers* (loop for type in '(short-float single-float double-float long-float) for c across "SFDL" when (subtypep 'double-float type) nconc (list c (char-downcase c)))) (deftest print.double-float.3 (let ((chars *possible-double-float-exponent-markers*)) (loop for type in '(short-float double-float long-float) nconc (and (not (subtypep 'double-float type)) (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* type)) (loop for i from -4000 to 4000 for f = (float i 0.0d0) for s1 = (with-output-to-string (s) (prin1 f s)) for len1 = (length s1) for s2 = (format nil "~A.0" i) unless (and (> len1 4) (string-equal s1 s2 :start1 0 :end1 (- len1 2)) (eql (char s1 (- len1 1)) #\0) (member (char s1 (- len1 2)) chars)) collect (list type i f s1 s2))))))) nil) (deftest print.double-float.4 (let ((chars *possible-double-float-exponent-markers*)) (loop for type in '(short-float double-float long-float) nconc (and (not (subtypep 'double-float type)) (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* type)) (loop for i = (- (random 20000000) 10000000) for f = (float i 0.0d0) for s1 = (with-output-to-string (s) (prin1 f s)) for len1 = (length s1) for s2 = (format nil "~A.0" i) repeat 10000 unless (or (/= i (rational f)) ;; not enough bits ;; (> (nth-value 1 (integer-decode-float f)) 0) (and (> len1 4) (string-equal s1 s2 :start1 0 :end1 (- len1 2)) (eql (char s1 (- len1 1)) #\0) (member (char s1 (- len1 2)) chars))) collect (list type i f s1 s2))))))) nil) (deftest print.double-float.random (let ((lower-bound (if (< (log least-positive-double-float 10) -100) (expt 0.1d0 100) least-positive-double-float)) (upper-bound (/ (if (> (log most-positive-double-float 10) 100) (expt 10.0d0 100) most-positive-double-float) 10))) (loop for f = lower-bound then (* 10 f) while (< f upper-bound) nconc (loop for x = (handler-case (random f) (arithmetic-error (c) 0.0d0)) for y = (if (coin) (- x) x) repeat 10 nconc (randomly-check-readability y)))) nil) ;;; long float (deftest print.long-float.1 (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* 'long-float)) (loop for i from -4000 to 4000 for f = (float i 0.0l0) for s1 = (with-output-to-string (s) (prin1 f s)) for s2 = (format nil "~A.0" i) unless (equalp s1 s2) collect (list i f s1 s2)))) nil) (deftest print.long-float.2 (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* 'long-float)) (loop for i = (- (random 20000000) 10000000) for f = (float i 0.0l0) for s1 = (with-output-to-string (s) (prin1 f s)) for s2 = (format nil "~A.0" i) repeat 10000 unless (or (/= i (rational f)) ;; not enough bits ;; (> (nth-value 1 (integer-decode-float f)) 0) (equalp s1 s2)) collect (list i f s1 s2)))) nil) (defparameter *possible-long-float-exponent-markers* (loop for type in '(short-float single-float double-float long-float) for c across "SFDL" when (subtypep 'long-float type) nconc (list c (char-downcase c)))) (deftest print.long-float.3 (let ((chars *possible-long-float-exponent-markers*)) (loop for type in '(short-float double-float long-float) nconc (and (not (subtypep 'long-float type)) (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* type)) (loop for i from -4000 to 4000 for f = (float i 0.0l0) for s1 = (with-output-to-string (s) (prin1 f s)) for len1 = (length s1) for s2 = (format nil "~A.0" i) unless (and (> len1 4) (string-equal s1 s2 :start1 0 :end1 (- len1 2)) (eql (char s1 (- len1 1)) #\0) (member (char s1 (- len1 2)) chars)) collect (list type i f s1 s2))))))) nil) (deftest print.long-float.4 (let ((chars *possible-long-float-exponent-markers*)) (loop for type in '(short-float double-float long-float) nconc (and (not (subtypep 'long-float type)) (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* type)) (loop for i = (- (random 20000000) 10000000) for f = (float i 0.0l0) for s1 = (with-output-to-string (s) (prin1 f s)) for len1 = (length s1) for s2 = (format nil "~A.0" i) repeat 10000 unless (or (/= i (rational f)) ;; not enough bits ;; (> (nth-value 1 (integer-decode-float f)) 0) (and (> len1 4) (string-equal s1 s2 :start1 0 :end1 (- len1 2)) (eql (char s1 (- len1 1)) #\0) (member (char s1 (- len1 2)) chars))) collect (list type i f s1 s2))))))) nil) (deftest print.long-float.random (let ((lower-bound (if (< (log least-positive-long-float 10) -100) (expt 0.1l0 100) least-positive-long-float)) (upper-bound (/ (if (> (log most-positive-long-float 10) 100) (expt 10.0l0 100) most-positive-long-float) 10))) (loop for f = lower-bound then (* 10 f) while (< f upper-bound) nconc (loop for x = (handler-case (random f) (arithmetic-error (c) 0.0l0)) for y = (if (coin) (- x) x) repeat 10 nconc (randomly-check-readability y)))) nil)gcl27-2.7.0/ansi-tests/print-integers.lsp000066400000000000000000000435351454061450500202400ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Feb 23 06:26:25 2004 ;;;; Contains: Printing tests for integers (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; Tests with *print-base* (def-print-test print.integers.1 1 "1") (def-print-test print.integers.2 2 "2") (def-print-test print.integers.3 3 "3") (def-print-test print.integers.4 4 "4") (def-print-test print.integers.5 5 "5") (def-print-test print.integers.6 6 "6") (def-print-test print.integers.7 7 "7") (def-print-test print.integers.8 8 "8") (def-print-test print.integers.9 9 "9") (def-print-test print.integers.10 -0 "0") (def-print-test print.integers.11 -1 "-1") (def-print-test print.integers.12 -2 "-2") (def-print-test print.integers.13 -3 "-3") (def-print-test print.integers.14 -4 "-4") (def-print-test print.integers.15 -5 "-5") (def-print-test print.integers.16 -6 "-6") (def-print-test print.integers.17 -7 "-7") (def-print-test print.integers.18 -8 "-8") (def-print-test print.integers.19 -9 "-9") (def-print-test print.integers.20 (expt 10 20) "100000000000000000000") (def-print-test print.integers.21 (- (expt 10 20)) "-100000000000000000000") (def-print-test print.integers.base.2.0 0 "0" (*print-base* 2)) (def-print-test print.integers.base.2.1 1 "1" (*print-base* 2)) (def-print-test print.integers.base.2.2 2 "10" (*print-base* 2)) (def-print-test print.integers.base.2.3 3 "11" (*print-base* 2)) (def-print-test print.integers.base.2.4 -1 "-1" (*print-base* 2)) (def-print-test print.integers.base.2.5 -2 "-10" (*print-base* 2)) (def-print-test print.integers.base.2.6 -3 "-11" (*print-base* 2)) (def-print-test print.integers.base.2.7 255 "11111111" (*print-base* 2)) (def-print-test print.integers.base.2.8 -252 "-11111100" (*print-base* 2)) (def-print-test print.integers.base.2.9 (expt 2 40) "10000000000000000000000000000000000000000" (*print-base* 2)) (def-print-test print.integers.base.2.10 (- (expt 2 40)) "-10000000000000000000000000000000000000000" (*print-base* 2)) (def-print-test print.integers.base.3.0 0 "0" (*print-base* 3)) (def-print-test print.integers.base.3.1 1 "1" (*print-base* 3)) (def-print-test print.integers.base.3.2 2 "2" (*print-base* 3)) (def-print-test print.integers.base.3.3 3 "10" (*print-base* 3)) (def-print-test print.integers.base.3.4 -1 "-1" (*print-base* 3)) (def-print-test print.integers.base.3.5 -2 "-2" (*print-base* 3)) (def-print-test print.integers.base.3.6 -3 "-10" (*print-base* 3)) (def-print-test print.integers.base.3.7 80 "2222" (*print-base* 3)) (def-print-test print.integers.base.3.8 -78 "-2220" (*print-base* 3)) (def-print-test print.integers.base.3.9 (expt 3 40) "10000000000000000000000000000000000000000" (*print-base* 3)) (def-print-test print.integers.base.3.10 (- (expt 3 40)) "-10000000000000000000000000000000000000000" (*print-base* 3)) (def-print-test print.integers.base.4.0 0 "0" (*print-base* 4)) (def-print-test print.integers.base.4.1 1 "1" (*print-base* 4)) (def-print-test print.integers.base.4.2 2 "2" (*print-base* 4)) (def-print-test print.integers.base.4.3 3 "3" (*print-base* 4)) (def-print-test print.integers.base.4.4 4 "10" (*print-base* 4)) (def-print-test print.integers.base.4.5 5 "11" (*print-base* 4)) (def-print-test print.integers.base.4.6 -1 "-1" (*print-base* 4)) (def-print-test print.integers.base.4.7 -2 "-2" (*print-base* 4)) (def-print-test print.integers.base.4.8 -3 "-3" (*print-base* 4)) (def-print-test print.integers.base.4.9 -4 "-10" (*print-base* 4)) (def-print-test print.integers.base.4.10 -5 "-11" (*print-base* 4)) (def-print-test print.integers.base.4.11 255 "3333" (*print-base* 4)) (def-print-test print.integers.base.4.12 -255 "-3333" (*print-base* 4)) (def-print-test print.integers.base.4.13 (expt 4 40) "10000000000000000000000000000000000000000" (*print-base* 4)) (def-print-test print.integers.base.4.14 (- (expt 4 40)) "-10000000000000000000000000000000000000000" (*print-base* 4)) (def-print-test print.integers.base.7.0 0 "0" (*print-base* 7)) (def-print-test print.integers.base.7.1 1 "1" (*print-base* 7)) (def-print-test print.integers.base.7.2 2 "2" (*print-base* 7)) (def-print-test print.integers.base.7.3 16 "22" (*print-base* 7)) (def-print-test print.integers.base.7.4 66 "123" (*print-base* 7)) (def-print-test print.integers.base.7.5 -1 "-1" (*print-base* 7)) (def-print-test print.integers.base.7.6 -7 "-10" (*print-base* 7)) (def-print-test print.integers.base.7.7 -48 "-66" (*print-base* 7)) (def-print-test print.integers.base.7.8 (expt 7 40) "10000000000000000000000000000000000000000" (*print-base* 7)) (def-print-test print.integers.base.7.9 (- (expt 7 40)) "-10000000000000000000000000000000000000000" (*print-base* 7)) (def-print-test print.integers.base.11.0 0 "0" (*print-base* 11)) (def-print-test print.integers.base.11.1 1 "1" (*print-base* 11)) (def-print-test print.integers.base.11.2 2 "2" (*print-base* 11)) (def-print-test print.integers.base.11.3 10 "A" (*print-base* 11)) (def-print-test print.integers.base.11.4 11 "10" (*print-base* 11)) (def-print-test print.integers.base.11.5 121 "100" (*print-base* 11)) (def-print-test print.integers.base.11.6 -1 "-1" (*print-base* 11)) (def-print-test print.integers.base.11.7 -10 "-A" (*print-base* 11)) (def-print-test print.integers.base.11.8 -21 "-1A" (*print-base* 11)) (def-print-test print.integers.base.11.9 -110 "-A0" (*print-base* 11)) (def-print-test print.integers.base.11.10 (expt 11 40) "10000000000000000000000000000000000000000" (*print-base* 11)) (def-print-test print.integers.base.11.11 (- (expt 11 40)) "-10000000000000000000000000000000000000000" (*print-base* 11)) (def-print-test print.integers.base.16.0 0 "0" (*print-base* 16)) (def-print-test print.integers.base.16.1 1 "1" (*print-base* 16)) (def-print-test print.integers.base.16.2 2 "2" (*print-base* 16)) (def-print-test print.integers.base.16.3 12 "C" (*print-base* 16)) (def-print-test print.integers.base.16.4 17 "11" (*print-base* 16)) (def-print-test print.integers.base.16.5 256 "100" (*print-base* 16)) (def-print-test print.integers.base.16.6 -1 "-1" (*print-base* 16)) (def-print-test print.integers.base.16.7 -14 "-E" (*print-base* 16)) (def-print-test print.integers.base.16.8 -30 "-1E" (*print-base* 16)) (def-print-test print.integers.base.16.9 -208 "-D0" (*print-base* 16)) (def-print-test print.integers.base.16.10 (expt 16 40) "10000000000000000000000000000000000000000" (*print-base* 16)) (def-print-test print.integers.base.16.11 (- (expt 16 40)) "-10000000000000000000000000000000000000000" (*print-base* 16)) (def-print-test print.integers.base.36.0 0 "0" (*print-base* 36)) (def-print-test print.integers.base.36.1 1 "1" (*print-base* 36)) (def-print-test print.integers.base.36.2 2 "2" (*print-base* 36)) (def-print-test print.integers.base.36.3 12 "C" (*print-base* 36)) (def-print-test print.integers.base.36.4 37 "11" (*print-base* 36)) (def-print-test print.integers.base.36.5 (* 36 36) "100" (*print-base* 36)) (def-print-test print.integers.base.36.6 -1 "-1" (*print-base* 36)) (def-print-test print.integers.base.36.7 -14 "-E" (*print-base* 36)) (def-print-test print.integers.base.36.8 -35 "-Z" (*print-base* 36)) (def-print-test print.integers.base.36.9 -37 "-11" (*print-base* 36)) (def-print-test print.integers.base.36.10 (- 2 (* 36 36)) "-ZY" (*print-base* 36)) (def-print-test print.integers.base.36.11 (expt 36 40) "10000000000000000000000000000000000000000" (*print-base* 36)) (def-print-test print.integers.base.36.12 (- (expt 36 40)) "-10000000000000000000000000000000000000000" (*print-base* 36)) ;;; With *print-radix* (def-print-test print.integers.radix.0 0 "0." (*print-radix* t)) (def-print-test print.integers.radix.1 1 "1." (*print-radix* t)) (def-print-test print.integers.radix.2 123456 "123456." (*print-radix* t)) (def-print-test print.integers.radix.3 123456789 "123456789." (*print-radix* t)) (def-print-test print.integers.radix.4 -5 "-5." (*print-radix* t)) (def-print-test print.integers.radix.5 -249213 "-249213." (*print-radix* t)) (def-print-test print.integers.radix.6 -917512001 "-917512001." (*print-radix* t)) (def-print-test print.integers.radix.base.2.0 0 "#b0" (*print-radix* t) (*print-base* 2)) (def-print-test print.integers.radix.base.2.1 1 "#b1" (*print-radix* t) (*print-base* 2)) (def-print-test print.integers.radix.base.2.2 2 "#b10" (*print-radix* t) (*print-base* 2)) (def-print-test print.integers.radix.base.2.3 3 "#b11" (*print-radix* t) (*print-base* 2)) (def-print-test print.integers.radix.base.2.4 -1 "#b-1" (*print-radix* t) (*print-base* 2)) (def-print-test print.integers.radix.base.2.5 -2 "#b-10" (*print-radix* t) (*print-base* 2)) (def-print-test print.integers.radix.base.2.6 -3 "#b-11" (*print-radix* t) (*print-base* 2)) (def-print-test print.integers.radix.base.2.7 256 "#b100000000" (*print-radix* t) (*print-base* 2)) (def-print-test print.integers.radix.base.2.8 -256 "#b-100000000" (*print-radix* t) (*print-base* 2)) (def-print-test print.integers.radix.base.2.9 (expt 2 100) (concatenate 'string "#b1" (make-string 100 :initial-element #\0)) (*print-radix* t) (*print-base* 2)) (def-print-test print.integers.radix.base.2.10 (- (expt 2 200)) (concatenate 'string "#b-1" (make-string 200 :initial-element #\0)) (*print-radix* t) (*print-base* 2)) (def-print-test print.integers.radix.base.3.0 0 "#3r0" (*print-radix* t) (*print-base* 3)) (def-print-test print.integers.radix.base.3.1 1 "#3r1" (*print-radix* t) (*print-base* 3)) (def-print-test print.integers.radix.base.3.2 2 "#3r2" (*print-radix* t) (*print-base* 3)) (def-print-test print.integers.radix.base.3.3 4 "#3r11" (*print-radix* t) (*print-base* 3)) (def-print-test print.integers.radix.base.3.4 -1 "#3r-1" (*print-radix* t) (*print-base* 3)) (def-print-test print.integers.radix.base.3.5 -2 "#3r-2" (*print-radix* t) (*print-base* 3)) (def-print-test print.integers.radix.base.3.6 -4 "#3r-11" (*print-radix* t) (*print-base* 3)) (def-print-test print.integers.radix.base.3.7 6561 "#3r100000000" (*print-radix* t) (*print-base* 3)) (def-print-test print.integers.radix.base.3.8 -81 "#3r-10000" (*print-radix* t) (*print-base* 3)) (def-print-test print.integers.radix.base.3.9 (expt 3 100) (concatenate 'string "#3r1" (make-string 100 :initial-element #\0)) (*print-radix* t) (*print-base* 3)) (def-print-test print.integers.radix.base.3.10 (- 1 (expt 3 200)) (concatenate 'string "#3r-" (make-string 200 :initial-element #\2)) (*print-radix* t) (*print-base* 3)) (def-print-test print.integers.radix.base.5.0 0 "#5r0" (*print-radix* t) (*print-base* 5)) (def-print-test print.integers.radix.base.5.1 1 "#5r1" (*print-radix* t) (*print-base* 5)) (def-print-test print.integers.radix.base.5.2 2 "#5r2" (*print-radix* t) (*print-base* 5)) (def-print-test print.integers.radix.base.5.3 6 "#5r11" (*print-radix* t) (*print-base* 5)) (def-print-test print.integers.radix.base.5.4 -1 "#5r-1" (*print-radix* t) (*print-base* 5)) (def-print-test print.integers.radix.base.5.5 -2 "#5r-2" (*print-radix* t) (*print-base* 5)) (def-print-test print.integers.radix.base.5.6 -8 "#5r-13" (*print-radix* t) (*print-base* 5)) (def-print-test print.integers.radix.base.5.7 390625 "#5r100000000" (*print-radix* t) (*print-base* 5)) (def-print-test print.integers.radix.base.5.8 -625 "#5r-10000" (*print-radix* t) (*print-base* 5)) (def-print-test print.integers.radix.base.5.9 (expt 5 100) (concatenate 'string "#5r1" (make-string 100 :initial-element #\0)) (*print-radix* t) (*print-base* 5)) (def-print-test print.integers.radix.base.5.10 (- 1 (expt 5 200)) (concatenate 'string "#5r-" (make-string 200 :initial-element #\4)) (*print-radix* t) (*print-base* 5)) (def-print-test print.integers.radix.base.8.0 0 "#o0" (*print-radix* t) (*print-base* 8)) (def-print-test print.integers.radix.base.8.1 1 "#o1" (*print-radix* t) (*print-base* 8)) (def-print-test print.integers.radix.base.8.2 2 "#o2" (*print-radix* t) (*print-base* 8)) (def-print-test print.integers.radix.base.8.3 9 "#o11" (*print-radix* t) (*print-base* 8)) (def-print-test print.integers.radix.base.8.4 -1 "#o-1" (*print-radix* t) (*print-base* 8)) (def-print-test print.integers.radix.base.8.5 -2 "#o-2" (*print-radix* t) (*print-base* 8)) (def-print-test print.integers.radix.base.8.6 -11 "#o-13" (*print-radix* t) (*print-base* 8)) (def-print-test print.integers.radix.base.8.7 16777216 "#o100000000" (*print-radix* t) (*print-base* 8)) (def-print-test print.integers.radix.base.8.8 -4096 "#o-10000" (*print-radix* t) (*print-base* 8)) (def-print-test print.integers.radix.base.8.9 (expt 8 100) (concatenate 'string "#o1" (make-string 100 :initial-element #\0)) (*print-radix* t) (*print-base* 8)) (def-print-test print.integers.radix.base.8.10 (- 1 (expt 8 200)) (concatenate 'string "#o-" (make-string 200 :initial-element #\7)) (*print-radix* t) (*print-base* 8)) (def-print-test print.integers.radix.base.12.0 0 "#12r0" (*print-radix* t) (*print-base* 12)) (def-print-test print.integers.radix.base.12.1 1 "#12r1" (*print-radix* t) (*print-base* 12)) (def-print-test print.integers.radix.base.12.2 2 "#12r2" (*print-radix* t) (*print-base* 12)) (def-print-test print.integers.radix.base.12.3 13 "#12r11" (*print-radix* t) (*print-base* 12)) (def-print-test print.integers.radix.base.12.4 -1 "#12r-1" (*print-radix* t) (*print-base* 12)) (def-print-test print.integers.radix.base.12.5 -2 "#12r-2" (*print-radix* t) (*print-base* 12)) (def-print-test print.integers.radix.base.12.6 -15 "#12r-13" (*print-radix* t) (*print-base* 12)) (def-print-test print.integers.radix.base.12.7 (expt 12 8) "#12r100000000" (*print-radix* t) (*print-base* 12)) (def-print-test print.integers.radix.base.12.8 (- (* 12 12 12 12)) "#12r-10000" (*print-radix* t) (*print-base* 12)) (def-print-test print.integers.radix.base.12.9 (expt 12 100) (concatenate 'string "#12r1" (make-string 100 :initial-element #\0)) (*print-radix* t) (*print-base* 12)) (def-print-test print.integers.radix.base.12.10 (- 1 (expt 12 200)) (concatenate 'string "#12r-" (make-string 200 :initial-element #\B)) (*print-radix* t) (*print-base* 12)) (def-print-test print.integers.radix.base.16.0 0 "#x0" (*print-radix* t) (*print-base* 16)) (def-print-test print.integers.radix.base.16.1 1 "#x1" (*print-radix* t) (*print-base* 16)) (def-print-test print.integers.radix.base.16.2 2 "#x2" (*print-radix* t) (*print-base* 16)) (def-print-test print.integers.radix.base.16.3 17 "#x11" (*print-radix* t) (*print-base* 16)) (def-print-test print.integers.radix.base.16.4 -1 "#x-1" (*print-radix* t) (*print-base* 16)) (def-print-test print.integers.radix.base.16.5 -2 "#x-2" (*print-radix* t) (*print-base* 16)) (def-print-test print.integers.radix.base.16.6 -19 "#x-13" (*print-radix* t) (*print-base* 16)) (def-print-test print.integers.radix.base.16.7 (expt 16 8) "#x100000000" (*print-radix* t) (*print-base* 16)) (def-print-test print.integers.radix.base.16.8 (- (* 16 16 16 16)) "#x-10000" (*print-radix* t) (*print-base* 16)) (def-print-test print.integers.radix.base.16.9 (expt 16 100) (concatenate 'string "#x1" (make-string 100 :initial-element #\0)) (*print-radix* t) (*print-base* 16)) (def-print-test print.integers.radix.base.16.10 (- 1 (expt 16 200)) (concatenate 'string "#x-" (make-string 200 :initial-element #\F)) (*print-radix* t) (*print-base* 16)) (def-print-test print.integers.radix.base.36.0 0 "#36r0" (*print-radix* t) (*print-base* 36)) (def-print-test print.integers.radix.base.36.1 1 "#36r1" (*print-radix* t) (*print-base* 36)) (def-print-test print.integers.radix.base.36.2 2 "#36r2" (*print-radix* t) (*print-base* 36)) (def-print-test print.integers.radix.base.36.3 37 "#36r11" (*print-radix* t) (*print-base* 36)) (def-print-test print.integers.radix.base.36.4 -1 "#36r-1" (*print-radix* t) (*print-base* 36)) (def-print-test print.integers.radix.base.36.5 -2 "#36r-2" (*print-radix* t) (*print-base* 36)) (def-print-test print.integers.radix.base.36.6 -39 "#36r-13" (*print-radix* t) (*print-base* 36)) (def-print-test print.integers.radix.base.36.7 (expt 36 8) "#36r100000000" (*print-radix* t) (*print-base* 36)) (def-print-test print.integers.radix.base.36.8 (- (* 36 36 36 36)) "#36r-10000" (*print-radix* t) (*print-base* 36)) (def-print-test print.integers.radix.base.36.9 (expt 36 100) (concatenate 'string "#36r1" (make-string 100 :initial-element #\0)) (*print-radix* t) (*print-base* 36)) (def-print-test print.integers.radix.base.36.10 (- 1 (expt 36 200)) (concatenate 'string "#36r-" (make-string 200 :initial-element #\Z)) (*print-radix* t) (*print-base* 36)) (deftest print.integers.base.various.1 (with-standard-io-syntax (loop for b from 2 to 36 nconc (let ((*print-base* b) (*read-base* b)) (loop for i from 1 to 100 for n = (expt b i) for str = (with-output-to-string (s) (prin1 n s)) for result = (read-from-string str) unless (= n result) collect (list b i n str result))))) nil) (deftest print.integers.base.various.2 (with-standard-io-syntax (loop for b from 2 to 36 nconc (let ((*print-base* b) (*read-base* b)) (loop for i from 1 to 100 for n = (- (expt b i)) for str = (with-output-to-string (s) (prin1 n s)) for result = (read-from-string str) unless (= n result) collect (list b i n str result))))) nil) (deftest print.integers.base.various.3 (with-standard-io-syntax (loop for b from 2 to 36 nconc (let ((*print-base* b) (*read-base* b) (*print-radix* t)) (loop for i from 1 to 100 for n = (expt b i) for str = (with-output-to-string (s) (prin1 n s)) for result = (read-from-string str) unless (= n result) collect (list b i n str result))))) nil) (deftest print.integers.base.various.4 (with-standard-io-syntax (loop for b from 2 to 36 nconc (let ((*print-base* b) (*read-base* b) (*print-radix* t)) (loop for i from 1 to 100 for n = (- (expt b i)) for str = (with-output-to-string (s) (prin1 n s)) for result = (read-from-string str) unless (= n result) collect (list b i n str result))))) nil) (deftest print.integers.random.1 (loop for numbits = (random 40) for bound = (ash 1 numbits) for r = (- (random (+ bound bound)) bound) repeat 10000 nconc (randomly-check-readability r)) nil) gcl27-2.7.0/ansi-tests/print-length.lsp000066400000000000000000000062761454061450500177020ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jul 27 08:27:37 2004 ;;;; Contains: Tests involving *PRINT-LENGTH* (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-print-test print-length.1 '(1) "(...)" (*print-length* 0)) (def-print-test print-length.2 '(1) "(1)" (*print-length* nil)) (def-print-test print-length.3 '(1) "(1)" (*print-length* 1)) (def-print-test print-length.4 '(1 . 2) "(1 . 2)" (*print-length* 1)) (deftest print-length.5 (let ((x '(|A| |B| |C| |D| |E| |F|))) (with-standard-io-syntax (let ((*print-case* :upcase) (*print-escape* nil) (*print-readably* nil) (*print-pretty* nil) (*print-length* nil)) (apply #'values (loop for i from 0 to 8 collect (let ((*print-length* i)) (write-to-string x))))))) "(...)" "(A ...)" "(A B ...)" "(A B C ...)" "(A B C D ...)" "(A B C D E ...)" "(A B C D E F)" "(A B C D E F)" "(A B C D E F)") (deftest print-length.6 (let ((x '(|A| |B| |C| |D| |E| |F| . |G|))) (with-standard-io-syntax (let ((*print-case* :upcase) (*print-escape* nil) (*print-readably* nil) (*print-pretty* nil) (*print-length* nil)) (apply #'values (loop for i from 0 to 8 collect (let ((*print-length* i)) (write-to-string x))))))) "(...)" "(A ...)" "(A B ...)" "(A B C ...)" "(A B C D ...)" "(A B C D E ...)" "(A B C D E F . G)" "(A B C D E F . G)" "(A B C D E F . G)") (def-print-test print-length.7 '(1) "(1)" (*print-length* (1+ most-positive-fixnum))) (deftest print-length.8 (let ((x #(|A| |B| |C| |D| |E| |F|))) (with-standard-io-syntax (let ((*print-case* :upcase) (*print-escape* nil) (*print-readably* nil) (*print-pretty* nil) (*print-length* nil)) (apply #'values (loop for i from 0 to 8 collect (let ((*print-length* i)) (write-to-string x))))))) "#(...)" "#(A ...)" "#(A B ...)" "#(A B C ...)" "#(A B C D ...)" "#(A B C D E ...)" "#(A B C D E F)" "#(A B C D E F)" "#(A B C D E F)") (def-print-test print-length.9 "A modest sentence with six words." "\"A modest sentence with six words.\"" (*print-length* 0)) (def-print-test print-length.10 #*00110101100011 "#*00110101100011" (*print-length* 0)) (defstruct print-length-struct foo) ;;; The next test tacitly assumes issue STRUCTURE-READ-PRINT-SYNTAX (deftest print-length.11 (let ((result (with-standard-io-syntax (let ((*print-case* :upcase) (*print-escape* nil) (*print-readably* nil) (*print-pretty* nil) (*print-length* nil) (*package* (find-package "CL-TEST")) (s (make-print-length-struct :foo 17))) (apply #'list (loop for i from 0 to 4 collect (let ((*print-length* i)) (write-to-string s)))))))) (if (member result '(("#S(...)" "#S(PRINT-LENGTH-STRUCT ...)" "#S(PRINT-LENGTH-STRUCT :FOO ...)" "#S(PRINT-LENGTH-STRUCT :FOO 17)" "#S(PRINT-LENGTH-STRUCT :FOO 17)") ("#S(PRINT-LENGTH-STRUCT ...)" "#S(PRINT-LENGTH-STRUCT :FOO 17)" "#S(PRINT-LENGTH-STRUCT :FOO 17)" "#S(PRINT-LENGTH-STRUCT :FOO 17)" "#S(PRINT-LENGTH-STRUCT :FOO 17)")) :test 'equal) :good result)) :good) gcl27-2.7.0/ansi-tests/print-level.lsp000066400000000000000000000065451454061450500175270ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jul 26 13:07:51 2004 ;;;; Contains: Tests of binding the *PRINT-LEVEL* variable (in-package :cl-test) (compile-and-load "printer-aux.lsp") #| (deftest print-level.1 (with-standard-io-syntax (let ((*print-readably* nil)) (loop for x in *mini-universe* for s1 = (write-to-string x) for s2 = (let ((*print-level* 0)) (write-to-string x)) when (and (or (consp x) (and (arrayp x) (not (stringp x)) (not (typep x 'bit-vector))) (typep (class-of x) 'structure-class)) (not (string= s2 "#"))) collect (list x s1 s2)))) nil) |# (defclass print-level-test-class nil (a b c)) ;;; The CLHS page for PRINT-OBJECT makes it clear that tests ;;; PRINT-LEVEL.2,6,7,10,11 were testing for implementation-dependent ;;; behavior. They have been commented out. #| (deftest print-level.2 (with-standard-io-syntax (write-to-string (make-instance 'print-level-test-class) :level 0 :readably nil)) "#") |# (deftest print-level.3 (with-standard-io-syntax (write-to-string (make-array '(4) :initial-contents '(a b c d)) :readably nil :array t :level 0)) "#") (deftest print-level.4 (with-standard-io-syntax (write-to-string (make-array '(4) :initial-contents '(1 1 0 1) :element-type 'bit) :readably nil :array t :level 0)) "#*1101") (deftest print-level.5 (with-standard-io-syntax (write-to-string "abcd" :readably nil :array t :level 0)) "\"abcd\"") (define-condition print-level-condition (condition) (a b c)) #| (deftest print-level.6 (with-standard-io-syntax (write-to-string (make-condition 'print-level-condition) :level 0 :pretty nil :readably nil)) "#") (deftest print-level.7 (with-standard-io-syntax (write-to-string (make-condition 'print-level-condition) :level 0 :pretty t :readably nil)) "#") |# (defstruct print-level-struct) (deftest print-level.8 (with-standard-io-syntax (let* ((*package* (find-package "CL-TEST")) (*print-pretty* nil) (s (make-print-level-struct))) (values (write-to-string s :level 0 :readably nil) (write-to-string s :level 1 :readably nil) (write-to-string s :level nil :readably nil)))) "#S(PRINT-LEVEL-STRUCT)" "#S(PRINT-LEVEL-STRUCT)" "#S(PRINT-LEVEL-STRUCT)") (deftest print-level.9 (with-standard-io-syntax (let* ((*package* (find-package "CL-TEST")) (*print-pretty* t) (s (make-print-level-struct))) (values (write-to-string s :level 0 :readably nil) (write-to-string s :level 1 :readably nil) (write-to-string s :level nil :readably nil)))) "#S(PRINT-LEVEL-STRUCT)" "#S(PRINT-LEVEL-STRUCT)" "#S(PRINT-LEVEL-STRUCT)") (defstruct print-level-struct2 a b c) #| (deftest print-level.10 (with-standard-io-syntax (let ((*package* (find-package "CL-TEST"))) (write-to-string (make-print-level-struct2) :level 0 :pretty nil :readably nil))) "#") (deftest print-level.11 (with-standard-io-syntax (let ((*package* (find-package "CL-TEST"))) (write-to-string (make-print-level-struct2) :level 0 :pretty t :readably nil))) "#") |# (deftest print-level.12 (with-standard-io-syntax (let ((*print-level* (1+ most-positive-fixnum))) (write-to-string '((1 2) (3 4)) :pretty nil :readably nil))) "((1 2) (3 4))") gcl27-2.7.0/ansi-tests/print-lines.lsp000066400000000000000000000015111454061450500175160ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jul 27 09:32:46 2004 ;;;; Contains: Tests involving PRINT-LINES (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest print-lines.1 *print-lines* nil) (deftest print-lines.2 (with-standard-io-syntax (let ((*print-lines* 1) (*print-readably* nil) (*print-miser-width* nil) (*print-pprint-dispatch* (copy-pprint-dispatch))) (set-pprint-dispatch '(cons (eql 1) t) 'pprint-fill) (apply #'values (loop for i from 1 to 10 collect (let ((*print-right-margin* i)) (subseq (with-output-to-string (*standard-output*) (terpri) (pprint '(1 2 3 4 5 6 7 8 9))) 2)))))) "(1 ..)" "(1 ..)" "(1 ..)" "(1 ..)" "(1 ..)" "(1 ..)" "(1 ..)" "(1 2 ..)" "(1 2 ..)" "(1 2 3 ..)") gcl27-2.7.0/ansi-tests/print-pathname.lsp000066400000000000000000000017041454061450500202050ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue May 25 08:22:03 2004 ;;;; Contains: Printer tests for pathnames (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest print.pathname.1 (loop for p in *universe* when (typep p 'pathname) nconc (loop repeat 10 nconc (randomly-check-readability p :test #'is-similar :can-fail t))) nil) (deftest print.pathname.2 (loop for p in *universe* when (typep p 'pathname) nconc (let ((ns (ignore-errors (namestring p)))) "Read 22.1.3.11 before commenting on this test" (when ns (let ((expected-result (concatenate 'string "#P" (with-standard-io-syntax (write-to-string ns :readably nil :escape t)))) (result (with-standard-io-syntax (write-to-string p :readably nil :escape t)))) (unless (string= expected-result result) (list (list expected-result result))))))) nil) gcl27-2.7.0/ansi-tests/print-random-state.lsp000066400000000000000000000011271454061450500210050ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue May 25 07:15:02 2004 ;;;; Contains: Tests of printing random states (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest print.random-state.1 (loop repeat 100 do (loop repeat 50 do (random 1000)) nconc (let* ((rs1 (make-random-state *random-state*)) (rs2 (with-standard-io-syntax (read-from-string (write-to-string rs1 :readably t)))) (result (list (notnot (random-state-p rs2)) (is-similar rs1 rs2)))) (unless (equal result '(t t)) (list result rs1 rs2)))) nil) gcl27-2.7.0/ansi-tests/print-ratios.lsp000066400000000000000000000007151454061450500177120ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Mar 1 22:03:58 2004 ;;;; Contains: Tests for printing ratios (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest print.ratios.random (loop for i from 1 to 1000 for numbits = (1+ (random 40)) for bound = (ash 1 numbits) for num = (- (random (+ bound bound)) bound) for denom = (1+ (random bound)) for r = (/ num denom) nconc (randomly-check-readability r)) nil) gcl27-2.7.0/ansi-tests/print-strings.lsp000066400000000000000000000077051454061450500201100ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Apr 19 05:53:48 2004 ;;;; Contains: Tests of string printing (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest print.string.1 (with-standard-io-syntax (write-to-string "" :escape nil :readably nil)) "") (deftest print.string.2 (with-standard-io-syntax (loop for c across +standard-chars+ for s1 = (string c) for s2 = (write-to-string s1 :escape nil :readably nil) unless (string= s1 s2) collect (list c s1 s2))) nil) (deftest print.string.3 (with-standard-io-syntax (loop for i below 256 for c = (code-char i) when c nconc (let* ((s1 (string c)) (s2 (write-to-string s1 :escape nil :readably nil))) (unless (string= s1 s2) (list (list c s1 s2)))))) nil) (deftest print.string.4 (with-standard-io-syntax (loop for c across +standard-chars+ for s1 = (string c) for s2 = (write-to-string s1 :escape t :readably nil) unless (or (find c "\"\\") (string= (concatenate 'string "\"" s1 "\"") s2)) collect (list c s1 s2))) nil) (deftest print.string.5 (with-standard-io-syntax (write-to-string "\"" :escape t :readably nil)) "\"\\\"\"") (deftest print.string.6 (with-standard-io-syntax (write-to-string "\\" :escape t :readably nil)) "\"\\\\\"") ;;; Not affected by *print-array* (deftest print.string.7 (with-standard-io-syntax (loop for s1 in (remove-if-not #'stringp *universe*) for s2 = (write-to-string s1 :escape nil :readably nil) for s3 = (write-to-string s1 :array t :escape nil :readably nil) unless (string= s2 s3) collect (list s1 s2 s3))) nil) (deftest print.string.8 (with-standard-io-syntax (loop for s1 in (remove-if-not #'stringp *universe*) for s2 = (write-to-string s1 :escape t :readably nil) for s3 = (write-to-string s1 :array t :escape t :readably nil) unless (string= s2 s3) collect (list s1 s2 s3))) nil) ;;; Only active elements of the string are printed (deftest print.string.9 (let* ((s (make-array '(10) :fill-pointer 5 :element-type 'character :initial-contents "abcdefghij")) (result (with-standard-io-syntax (write-to-string s :escape nil :readably nil)))) (or (and (string= result "abcde") t) result)) t) (deftest print.string.10 (let* ((s (make-array '(10) :fill-pointer 5 :element-type 'character :initial-contents "aBcDefGHij")) (result (with-standard-io-syntax (write-to-string s :escape t :readably nil)))) (or (and (string= result "\"aBcDe\"") t) result)) t) (deftest print.string.11 (let* ((s (make-array '(8) :element-type 'base-char :initial-contents "abcdefgh" :adjustable t)) (result (with-standard-io-syntax (write-to-string s :escape t :readably nil)))) (or (and (string= result "\"abcdefgh\"") t) result)) t) (deftest print.string.12 (let* ((s1 (make-array '(8) :element-type 'character :initial-contents "abcdefgh")) (s2 (make-array '(4) :element-type 'character :displaced-to s1 :displaced-index-offset 2)) (result (with-standard-io-syntax (write-to-string s2 :escape t :readably nil)))) (or (and (string= result "\"cdef\"") t) result)) t) ;;; *print-array* should not affect string printing (deftest print.string.13 (with-standard-io-syntax (write-to-string "1234" :array nil :readably nil :escape t)) "\"1234\"") ;;; The ever-popular nil string (deftest print.string.nil.1 :notes (:nil-vectors-are-strings) (let ((s (make-array '(0) :element-type nil))) (write-to-string s :escape nil :readably nil)) "") (deftest print.string.nil.2 :notes (:nil-vectors-are-strings) (let ((s (make-array '(0) :element-type nil))) (write-to-string s :escape t :readably nil)) "\"\"") ;;; Random tests (deftest print.string.random.1 (trim-list (loop for len = (1+ (random 5)) for s = (coerce (loop repeat len collect (random-from-seq +standard-chars+)) 'string) repeat 1000 append (randomly-check-readability s)) 10) nil) gcl27-2.7.0/ansi-tests/print-structure.lsp000066400000000000000000000022011454061450500204410ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed May 26 22:19:52 2004 ;;;; Contains: Printing tests for structures (in-package :cl-test) (compile-and-load "printer-aux.lsp") (defstruct print-struct-1 foo bar) (deftest print-structure.1 (let ((s (make-print-struct-1 :foo 1 :bar 2))) (with-standard-io-syntax (let ((*package* (find-package "CL-TEST"))) (let ((str (write-to-string s :readably nil :case :upcase :escape nil))) (assert (string= (subseq str 0 3) "#S(")) (let ((vals (read-from-string (subseq str 2)))) (assert (listp vals)) (assert (= (length vals) 5)) (assert (eq (car vals) 'print-struct-1)) (assert (symbolp (cadr vals))) (assert (symbolp (cadddr vals))) (cond ((string= (symbol-name (cadr vals)) "FOO") (assert (string= (symbol-name (cadddr vals)) "BAR")) (assert (= (caddr vals) 1)) (assert (= (car (cddddr vals)) 2))) (t (assert (string= (symbol-name (cadr vals)) "BAR")) (assert (string= (symbol-name (cadddr vals)) "FOO")) (assert (= (caddr vals) 2)) (assert (= (car (cddddr vals)) 1)))) nil))))) nil) gcl27-2.7.0/ansi-tests/print-symbols.lsp000066400000000000000000000527501454061450500201070ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 6 11:47:55 2004 ;;;; Contains: Tests of symbol printing (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; Symbol printing when escaping is off (defun princ.symbol.fn (sym case *print-case* expected) (setf (readtable-case *readtable*) case) (let ((str (with-output-to-string (s) (princ sym s)))) (or (equalt str expected) (list str expected)))) (defun prin1.symbol.fn (sym case *print-case* expected) (setf (readtable-case *readtable*) case) (let ((str (with-output-to-string (s) (prin1 sym s)))) (or (and (member str expected :test #'string=) t) (list str expected)))) (deftest print.symbol.1 (with-standard-io-syntax (let ((*print-readably* nil) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values (%p '|XYZ| :upcase :upcase "XYZ") (%p '|XYZ| :upcase :downcase "xyz") (%p '|XYZ| :upcase :capitalize "Xyz") (%p '|XYZ| :downcase :upcase "XYZ") (%p '|XYZ| :downcase :downcase "XYZ") (%p '|XYZ| :downcase :capitalize "XYZ") (%p '|XYZ| :preserve :upcase "XYZ") (%p '|XYZ| :preserve :downcase "XYZ") (%p '|XYZ| :preserve :capitalize "XYZ") (%p '|XYZ| :invert :upcase "xyz") (%p '|XYZ| :invert :downcase "xyz") (%p '|XYZ| :invert :capitalize "xyz"))))) t t t t t t t t t t t t) (deftest print.symbol.2 (with-standard-io-syntax (let ((*print-readably* nil) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values (%p '|xyz| :upcase :upcase "xyz") (%p '|xyz| :upcase :downcase "xyz") (%p '|xyz| :upcase :capitalize "xyz") (%p '|xyz| :downcase :upcase "XYZ") (%p '|xyz| :downcase :downcase "xyz") (%p '|xyz| :downcase :capitalize "Xyz") (%p '|xyz| :preserve :upcase "xyz") (%p '|xyz| :preserve :downcase "xyz") (%p '|xyz| :preserve :capitalize "xyz") (%p '|xyz| :invert :upcase "XYZ") (%p '|xyz| :invert :downcase "XYZ") (%p '|xyz| :invert :capitalize "XYZ"))))) t t t t t t t t t t t t) (deftest print.symbol.3 (with-standard-io-syntax (let ((*print-readably* nil) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values (%p '|Xyz| :upcase :upcase "Xyz") (%p '|Xyz| :upcase :downcase "xyz") (%p '|Xyz| :upcase :capitalize "Xyz") (%p '|Xyz| :downcase :upcase "XYZ") (%p '|Xyz| :downcase :downcase "Xyz") (%p '|Xyz| :downcase :capitalize "Xyz") (%p '|Xyz| :preserve :upcase "Xyz") (%p '|Xyz| :preserve :downcase "Xyz") (%p '|Xyz| :preserve :capitalize "Xyz") (%p '|Xyz| :invert :upcase "Xyz") (%p '|Xyz| :invert :downcase "Xyz") (%p '|Xyz| :invert :capitalize "Xyz"))))) t t t t t t t t t t t t) (deftest print.symbol.4 (with-standard-io-syntax (let ((*print-readably* nil) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values (%p '|xYZ| :upcase :upcase "xYZ") (%p '|xYZ| :upcase :downcase "xyz") (%p '|xYZ| :upcase :capitalize "xyz") (%p '|xYZ| :downcase :upcase "XYZ") (%p '|xYZ| :downcase :downcase "xYZ") (%p '|xYZ| :downcase :capitalize "XYZ") (%p '|xYZ| :preserve :upcase "xYZ") (%p '|xYZ| :preserve :downcase "xYZ") (%p '|xYZ| :preserve :capitalize "xYZ") (%p '|xYZ| :invert :upcase "xYZ") (%p '|xYZ| :invert :downcase "xYZ") (%p '|xYZ| :invert :capitalize "xYZ"))))) t t t t t t t t t t t t) (deftest print.symbol.5 (with-standard-io-syntax (let ((*print-readably* nil) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values (%p '|X1Z| :upcase :upcase "X1Z") (%p '|X1Z| :upcase :downcase "x1z") (%p '|X1Z| :upcase :capitalize "X1z") (%p '|X1Z| :downcase :upcase "X1Z") (%p '|X1Z| :downcase :downcase "X1Z") (%p '|X1Z| :downcase :capitalize "X1Z") (%p '|X1Z| :preserve :upcase "X1Z") (%p '|X1Z| :preserve :downcase "X1Z") (%p '|X1Z| :preserve :capitalize "X1Z") (%p '|X1Z| :invert :upcase "x1z") (%p '|X1Z| :invert :downcase "x1z") (%p '|X1Z| :invert :capitalize "x1z"))))) t t t t t t t t t t t t) (deftest print.symbol.6 (with-standard-io-syntax (let ((*print-readably* nil) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values (%p '|x1z| :upcase :upcase "x1z") (%p '|x1z| :upcase :downcase "x1z") (%p '|x1z| :upcase :capitalize "x1z") (%p '|x1z| :downcase :upcase "X1Z") (%p '|x1z| :downcase :downcase "x1z") (%p '|x1z| :downcase :capitalize "X1z") (%p '|x1z| :preserve :upcase "x1z") (%p '|x1z| :preserve :downcase "x1z") (%p '|x1z| :preserve :capitalize "x1z") (%p '|x1z| :invert :upcase "X1Z") (%p '|x1z| :invert :downcase "X1Z") (%p '|x1z| :invert :capitalize "X1Z"))))) t t t t t t t t t t t t) (deftest print.symbol.7 (with-standard-io-syntax (let ((*print-readably* nil) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values (%p '|X1z| :upcase :upcase "X1z") (%p '|X1z| :upcase :downcase "x1z") (%p '|X1z| :upcase :capitalize "X1z") (%p '|X1z| :downcase :upcase "X1Z") (%p '|X1z| :downcase :downcase "X1z") (%p '|X1z| :downcase :capitalize "X1z") (%p '|X1z| :preserve :upcase "X1z") (%p '|X1z| :preserve :downcase "X1z") (%p '|X1z| :preserve :capitalize "X1z") (%p '|X1z| :invert :upcase "X1z") (%p '|X1z| :invert :downcase "X1z") (%p '|X1z| :invert :capitalize "X1z"))))) t t t t t t t t t t t t) (deftest print.symbol.8 (with-standard-io-syntax (let ((*print-readably* nil) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values (%p '|x1Z| :upcase :upcase "x1Z") (%p '|x1Z| :upcase :downcase "x1z") (%p '|x1Z| :upcase :capitalize "x1z") (%p '|x1Z| :downcase :upcase "X1Z") (%p '|x1Z| :downcase :downcase "x1Z") (%p '|x1Z| :downcase :capitalize "X1Z") (%p '|x1Z| :preserve :upcase "x1Z") (%p '|x1Z| :preserve :downcase "x1Z") (%p '|x1Z| :preserve :capitalize "x1Z") (%p '|x1Z| :invert :upcase "x1Z") (%p '|x1Z| :invert :downcase "x1Z") (%p '|x1Z| :invert :capitalize "x1Z"))))) t t t t t t t t t t t t) (deftest print.symbol.9 (with-standard-io-syntax (let ((*print-readably* nil) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values (%p '|X Z| :upcase :upcase "X Z") (%p '|X Z| :upcase :downcase "x z") (%p '|X Z| :upcase :capitalize "X Z") (%p '|X Z| :downcase :upcase "X Z") (%p '|X Z| :downcase :downcase "X Z") (%p '|X Z| :downcase :capitalize "X Z") (%p '|X Z| :preserve :upcase "X Z") (%p '|X Z| :preserve :downcase "X Z") (%p '|X Z| :preserve :capitalize "X Z") (%p '|X Z| :invert :upcase "x z") (%p '|X Z| :invert :downcase "x z") (%p '|X Z| :invert :capitalize "x z"))))) t t t t t t t t t t t t) (deftest print.symbol.10 (with-standard-io-syntax (let ((*print-readably* nil) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values (%p '|x z| :upcase :upcase "x z") (%p '|x z| :upcase :downcase "x z") (%p '|x z| :upcase :capitalize "x z") (%p '|x z| :downcase :upcase "X Z") (%p '|x z| :downcase :downcase "x z") (%p '|x z| :downcase :capitalize "X Z") (%p '|x z| :preserve :upcase "x z") (%p '|x z| :preserve :downcase "x z") (%p '|x z| :preserve :capitalize "x z") (%p '|x z| :invert :upcase "X Z") (%p '|x z| :invert :downcase "X Z") (%p '|x z| :invert :capitalize "X Z"))))) t t t t t t t t t t t t) (deftest print.symbol.11 (with-standard-io-syntax (let ((*print-readably* nil) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values (%p '|X z| :upcase :upcase "X z") (%p '|X z| :upcase :downcase "x z") (%p '|X z| :upcase :capitalize "X z") (%p '|X z| :downcase :upcase "X Z") (%p '|X z| :downcase :downcase "X z") (%p '|X z| :downcase :capitalize "X Z") (%p '|X z| :preserve :upcase "X z") (%p '|X z| :preserve :downcase "X z") (%p '|X z| :preserve :capitalize "X z") (%p '|X z| :invert :upcase "X z") (%p '|X z| :invert :downcase "X z") (%p '|X z| :invert :capitalize "X z"))))) t t t t t t t t t t t t) (deftest print.symbol.12 (with-standard-io-syntax (let ((*print-readably* nil) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values (%p '|x Z| :upcase :upcase "x Z") (%p '|x Z| :upcase :downcase "x z") (%p '|x Z| :upcase :capitalize "x Z") (%p '|x Z| :downcase :upcase "X Z") (%p '|x Z| :downcase :downcase "x Z") (%p '|x Z| :downcase :capitalize "X Z") (%p '|x Z| :preserve :upcase "x Z") (%p '|x Z| :preserve :downcase "x Z") (%p '|x Z| :preserve :capitalize "x Z") (%p '|x Z| :invert :upcase "x Z") (%p '|x Z| :invert :downcase "x Z") (%p '|x Z| :invert :capitalize "x Z"))))) t t t t t t t t t t t t) ;;; Randomized printing tests (deftest print.symbol.random.1 (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE")) (when (find-package pkg-name) (delete-package pkg-name)) (prog1 (let ((*package* (make-package pkg-name))) (trim-list (loop for c across +standard-chars+ nconc (loop repeat 50 nconc (randomly-check-readability (intern (string c))))) 10)) ;; (delete-package pkg-name) )) nil) (deftest print.symbol.random.2 (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE")) (when (find-package pkg-name) (delete-package pkg-name)) (prog1 (let ((*package* (make-package pkg-name)) (count 0)) (trim-list (loop for c1 = (random-from-seq +standard-chars+) for c2 = (random-from-seq +standard-chars+) for string = (concatenate 'string (string c1) (string c2)) for result = (randomly-check-readability (intern string)) for tries from 1 to 10000 when result do (incf count) nconc result when (= count 10) collect (format nil "... ~A out of ~A, stopping test ..." count tries) while (< count 10)) 10)) ;; (delete-package pkg-name) )) nil) (deftest print.symbol.random.3 (let ((count 0) (symbols (make-array '(1000) :fill-pointer 0 :adjustable t))) ;; Find all symbols that have a home package, put into array SYMBOLS (do-all-symbols (s) (when (symbol-package s) (vector-push-extend s symbols (array-dimension symbols 0)))) (loop for i = (random (fill-pointer symbols)) for s = (aref symbols i) for tries from 1 to 10000 for problem = (randomly-check-readability s) nconc problem when problem do (incf count) while (< count 10))) nil) (deftest print.symbol.random.4 (let ((count 0) (symbols (make-array '(1000) :fill-pointer 0 :adjustable t))) ;; Find all symbols that have a home package, put into array SYMBOLS (do-all-symbols (s) (when (symbol-package s) (vector-push-extend s symbols (array-dimension symbols 0)))) (loop for i = (random (fill-pointer symbols)) for s = (aref symbols i) for tries from 1 to 10000 for problem = (let ((*package* (symbol-package s))) (randomly-check-readability s)) nconc problem when problem do (incf count) while (< count 10))) nil) ;;;; Tests of printing with escaping enabled (deftest prin1.symbol.1 (with-standard-io-syntax (let ((*print-readably* nil) (*package* (find-package :cl-test)) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'prin1.symbol.fn args))) (values (%p '|X| :upcase :upcase '("x" "X" "\\X" "|X|")) (%p '|X| :upcase :downcase '("x" "X" "\\X" "|X|")) (%p '|X| :upcase :capitalize '("x" "X" "\\X" "|X|")) (%p '|X| :downcase :upcase '("\\X" "|X|")) (%p '|X| :downcase :downcase '("\\X" "|X|")) (%p '|X| :downcase :capitalize '("\\X" "|X|")) (%p '|X| :preserve :upcase '("X" "\\X" "|X|")) (%p '|X| :preserve :downcase '("X" "\\X" "|X|")) (%p '|X| :preserve :capitalize '("X" "\\X" "|X|")) (%p '|X| :invert :upcase '("x" "\\X" "|X|")) (%p '|X| :invert :downcase '("x" "\\X" "|X|")) (%p '|X| :invert :capitalize '("x" "\\X" "|X|")) )))) t t t t t t t t t t t t) (deftest prin1.symbol.2 (with-standard-io-syntax (let ((*print-readably* nil) (*package* (find-package :cl-test)) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'prin1.symbol.fn args))) (values (%p '|x| :upcase :upcase '("\\x" "|x|")) (%p '|x| :upcase :downcase '("\\x" "|x|")) (%p '|x| :upcase :capitalize '("\\x" "|x|")) (%p '|x| :downcase :upcase '("x" "X" "\\x" "|x|")) (%p '|x| :downcase :downcase '("x" "X" "\\x" "|x|")) (%p '|x| :downcase :capitalize '("x" "X" "\\x" "|x|")) (%p '|x| :preserve :upcase '("x" "\\x" "|x|")) (%p '|x| :preserve :downcase '("x" "\\x" "|x|")) (%p '|x| :preserve :capitalize '("x" "\\x" "|x|")) (%p '|x| :invert :upcase '("X" "\\x" "|x|")) (%p '|x| :invert :downcase '("X" "\\x" "|x|")) (%p '|x| :invert :capitalize '("X" "\\x" "|x|")) )))) t t t t t t t t t t t t) (deftest prin1.symbol.3 (with-standard-io-syntax (let ((*print-readably* nil) (*package* (find-package :cl-test)) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'prin1.symbol.fn args))) (values (%p '|1| :upcase :upcase '("\\1" "|1|")) (%p '|1| :upcase :downcase '("\\1" "|1|")) (%p '|1| :upcase :capitalize '("\\1" "|1|")) (%p '|1| :downcase :upcase '("1" "\\1" "|1|")) (%p '|1| :downcase :downcase '("1" "\\1" "|1|")) (%p '|1| :downcase :capitalize '("1" "\\1" "|1|")) (%p '|1| :preserve :upcase '("1" "\\1" "|1|")) (%p '|1| :preserve :downcase '("1" "\\1" "|1|")) (%p '|1| :preserve :capitalize '("1" "\\1" "|1|")) (%p '|1| :invert :upcase '("1" "\\1" "|1|")) (%p '|1| :invert :downcase '("1" "\\1" "|1|")) (%p '|1| :invert :capitalize '("1" "\\1" "|1|")) )))) t t t t t t t t t t t t) ;;; Random symbol printing tests when *print-escape* is true ;;; and *print-readably* is false. ;;; I AM NOT SURE THESE ARE CORRECT, SO THEY ARE COMMENTED OUT FOR NOW -- PFD #| (deftest print.symbol.escaped-random.1 (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE")) (when (find-package pkg-name) (delete-package pkg-name)) (prog1 (let ((*package* (make-package pkg-name)) (result (loop for c across +standard-chars+ for s = (intern (string c)) append (loop repeat 50 nconc (randomly-check-readability s :readable nil :escape t))))) (subseq result 0 (min (length result) 10))) ;; (delete-package pkg-name) )) nil) (deftest print.symbol.escaped-random.2 (let ((result (loop for c across +standard-chars+ for s = (make-symbol (string c)) nconc (loop repeat 50 nconc (randomly-check-readability s :readable nil :escape t :gensym t :test #'similar-uninterned-symbols))))) (subseq result 0 (min (length result) 10))) nil) (deftest print.symbol.escaped-random.3 (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE")) (when (find-package pkg-name) (delete-package pkg-name)) (prog1 (let ((*package* (make-package pkg-name)) (result (loop for i below 256 for c = (code-char i) when c nconc (let ((s (intern (string c)))) (loop repeat 50 nconc (randomly-check-readability s :readable nil :escape t)))))) (subseq result 0 (min (length result) 10))) ;; (delete-package pkg-name) )) nil) (deftest print.symbol.escaped-random.4 (let ((result (loop for i below 256 for c = (code-char i) when c nconc (let ((s (make-symbol (string c)))) (loop repeat 50 nconc (randomly-check-readability s :readable nil :escape t :gensym t :test #'similar-uninterned-symbols)))))) (subseq result 0 (min (length result) 10))) nil) (deftest print.symbol.escaped-random.5 (loop for s in *universe* when (and (symbolp s) (symbol-package s) ) nconc (loop repeat 50 nconc (randomly-check-readability s :readable nil :escape t))) nil) (deftest print.symbol.escaped-random.6 (let ((*package* (find-package "KEYWORD"))) (loop for s in *universe* when (and (symbolp s) (symbol-package s)) nconc (loop repeat 50 nconc (randomly-check-readability s :readable nil :escape t)))) nil) (deftest print.symbol.escaped-random.7 (loop for s in *universe* when (and (symbolp s) (not (symbol-package s))) nconc (loop repeat 50 nconc (randomly-check-readability s :readable nil :escape t :gensym t :test #'similar-uninterned-symbols))) nil) (deftest print.symbol.escaped-random.8 (let ((*package* (find-package "KEYWORD"))) (loop for s in *universe* when (and (symbolp s) (not (symbol-package s))) nconc (loop repeat 50 nconc (randomly-check-readability s :readable nil :escape t :gensym t :test #'similar-uninterned-symbols)))) nil) (deftest print.symbol.escaped.9 (let* ((*package* (find-package "CL-TEST")) (s (intern "()"))) (randomly-check-readability s :readable nil :escape t)) nil) (deftest print.symbol.escaped.10 (let* ((*package* (find-package "KEYWORD")) (s (intern "()"))) (randomly-check-readability s :readable nil :escape t)) nil) |# ;;; Tests of printing package prefixes (deftest print.symbol.prefix.1 (with-standard-io-syntax (let ((s (write-to-string (make-symbol "ABC") :gensym t :case :upcase :escape t :readably nil))) (if (string= s "#:ABC") t s))) t) (deftest print.symbol.prefix.2 (with-standard-io-syntax (let ((s (write-to-string (make-symbol "ABC") :gensym nil :case :upcase :readably nil :escape nil))) (if (string= s "ABC") t s))) t) (deftest print.symbol.prefix.3 (with-standard-io-syntax (let ((s (write-to-string (make-symbol "ABC") :gensym nil :case :upcase :readably t :escape nil))) (if (and (string= (subseq s 0 2) "#:") (string= (symbol-name (read-from-string s)) "ABC")) t s))) t) (deftest print.symbol.prefix.4 (with-standard-io-syntax (let ((s (write-to-string (make-symbol "ABC") :gensym nil :case :upcase :readably nil :escape t))) (if (string= s "ABC") t s))) t) (deftest print.symbol.prefix.5 (with-standard-io-syntax (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE")) (when (find-package pkg-name) (delete-package pkg-name)) (let ((pkg (make-package pkg-name))) (multiple-value-prog1 (let* ((*package* (find-package "CL-TEST")) (s (intern "ABC" pkg))) (values (write-to-string s :case :upcase :readably nil :escape t) (let ((*package* pkg)) (write-to-string s :case :upcase :readably nil :escape t)) (let ((*package* pkg)) (write-to-string s :case :downcase :readably nil :escape t)) )) ;; (delete-package pkg) )))) "PRINT-SYMBOL-TEST-PACKAGE::ABC" "ABC" "abc") (deftest print.symbol.prefix.6 (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE")) (when (find-package pkg-name) (delete-package pkg-name)) (let ((pkg (make-package pkg-name))) (prog1 (with-standard-io-syntax (let* ((*package* pkg) (s (intern "X" pkg))) (write-to-string s :case :upcase :readably nil)) ;; (delete-package pkg) )))) "X") (deftest print.symbol.prefix.6a (with-standard-io-syntax (let ((*package* (find-package "CL-TEST"))) (write-to-string 'x :case :upcase :readably nil))) "X") (deftest print.symbol.prefix.6b (funcall (compile nil '(lambda () (declare (optimize speed (safety 0))) (with-standard-io-syntax (let ((*package* (find-package "CL-TEST"))) (write-to-string 'cl-test::x :case :upcase :readably nil)))))) "X") (deftest print.symbol.prefix.7 (with-standard-io-syntax (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE") (pkg-name2 "ANOTHER-PRINT-SYMBOL-TEST-PACKAGE")) (when (find-package pkg-name) (delete-package pkg-name)) (when (find-package pkg-name2) (delete-package pkg-name2)) (prog1 (let* ((pkg (make-package pkg-name)) (pkg2 (make-package pkg-name2)) (s (intern "ABC" pkg))) (import s pkg2) (let ((*package* pkg2)) (write-to-string s :case :upcase :readably nil :escape t))) ;; (delete-package pkg) ))) "ABC") (deftest print.symbol.prefix.8 (with-standard-io-syntax (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE") (pkg-name2 "ANOTHER-PRINT-SYMBOL-TEST-PACKAGE")) (when (find-package pkg-name) (delete-package pkg-name)) (when (find-package pkg-name2) (delete-package pkg-name2)) (prog1 (let* ((pkg (make-package pkg-name)) (pkg2 (make-package pkg-name2)) (s (intern "ABC" pkg2))) (import s pkg) (delete-package pkg2) (let ((*package* pkg)) (write-to-string s :case :upcase :gensym t :readably nil :escape t))) ;; (delete-package pkg) ))) "#:ABC") (deftest print.symbol.prefix.9 (with-standard-io-syntax (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE")) (when (find-package pkg-name) (delete-package pkg-name)) (prog1 (let* ((pkg (make-package pkg-name)) (s (intern "ABC" pkg))) (export s pkg) (let ((*package* (find-package "CL-TEST"))) (write-to-string s :case :upcase :readably nil :escape t))) ;; (delete-package pkg) ))) "PRINT-SYMBOL-TEST-PACKAGE:ABC") (deftest print.symbol.prefix.10 (with-standard-io-syntax (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE")) (when (find-package pkg-name) (delete-package pkg-name)) (prog1 (let* ((pkg (make-package pkg-name)) (s :|X|)) (import s pkg) (let ((*package* pkg)) (write-to-string s :case :upcase :readably nil :escape t))) ;; (delete-package pkg) ))) ":X") gcl27-2.7.0/ansi-tests/print-unreadable-object.lsp000066400000000000000000000077121454061450500217630ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jul 12 06:06:01 2004 ;;;; Contains: Tests of PRINT-UNREADABLE-OBJECT (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-pprint-test print-unreadable-object.1 (loop for x in *mini-universe* for return-vals = nil for s = (with-output-to-string (s) (setq return-vals (multiple-value-list (print-unreadable-object (x s))))) unless (and (equal return-vals '(nil)) (equal s "#<>")) collect (list x return-vals s)) nil) (def-pprint-test print-unreadable-object.2 (loop for x in *mini-universe* for return-vals1 = nil for return-vals2 = nil for s1 = (with-output-to-string (s) (setq return-vals1 (multiple-value-list (print-unreadable-object (x s :type t))))) for s2 = (with-output-to-string (s) (setq return-vals2 (multiple-value-list (print-unreadable-object (x s :type t) (write-char #\X s))))) unless (and (equal return-vals1 '(nil)) (equal return-vals2 '(nil)) (string= s1 "#<" :end1 2) (string= s1 s2 :end1 (- (length s1) 1) :end2 (- (length s2) 2)) (string= s2 " X>" :start1 (- (length s2) 3))) collect (list x return-vals1 return-vals2 s1 s2)) nil) (def-pprint-test print-unreadable-object.3 (loop for x in *mini-universe* for return-vals1 = nil for return-vals2 = nil for s1 = (with-output-to-string (s) (setq return-vals1 (multiple-value-list (print-unreadable-object (x s :identity t) (write "FOO" :stream s) (values 1 2 3 4 5) ;; test if this is ignored )))) for s2 = (with-output-to-string (s) (setq return-vals2 (multiple-value-list (print-unreadable-object (x s :identity t) )))) unless (and (equal return-vals1 '(nil)) (equal return-vals2 '(nil)) (string= s1 "#) (eql (char s2 (1- (length s2))) #\>) (string= s1 s2 :start2 3 :start1 6)) collect (list x return-vals1 return-vals2 s1 s2)) nil) (def-pprint-test print-unreadable-object.4 (loop for x in *mini-universe* for return-vals = nil for s = (with-output-to-string (s) (setq return-vals (multiple-value-list (print-unreadable-object (x s :identity t :type t) (write "FOO" :stream s) (values) ;; test if this is ignored )))) unless (and (equal return-vals '(nil)) (string= s "#<" :end1 2) (eql (char s (1- (length s))) #\>) (>= (count #\Space s) 2)) collect (list x return-vals s)) nil) ;;; TODO Tests that the :identity and :type arguments are evaluated ;;; TODO Tests where :type, :identity are provided, but are nil ;;; TODO Test that the type/identity parts of the output are the same ;;; for the both-printed case as they are in the only-one printed case, ;;; and that only a single space occurs between them if FORMS is omitted. ;;; Error cases (deftest print-unreadable-object.error.1 (with-standard-io-syntax (let ((*print-readably* t)) (loop for x in *mini-universe* for form = `(with-output-to-string (*standard-output*) (assert (signals-error (print-unreadable-object (',x *standard-output*)) print-not-readable))) unless (equal (eval form) "") collect x))) nil) ;;; Stream designators (deftest print-unreadable-object.t.1 (with-output-to-string (os) (with-input-from-string (is "") (with-open-stream (*terminal-io* (make-two-way-stream is os)) (let ((*print-readably* nil)) (assert (equal (multiple-value-list (print-unreadable-object (1 t))) '(nil))))))) "#<>") (deftest print-unreadable-object.nil.1 (with-output-to-string (*standard-output*) (let ((*print-readably* nil)) (assert (equal (multiple-value-list (print-unreadable-object (1 nil))) '(nil))))) "#<>") gcl27-2.7.0/ansi-tests/print-vector.lsp000066400000000000000000000266341454061450500177230ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Apr 20 22:36:53 2004 ;;;; Contains: Tests of vector printing (compile-and-load "printer-aux.lsp") (in-package :cl-test) ;;; Empty vector tests (deftest print.vector.1 (with-standard-io-syntax (write-to-string #() :readably nil :array t)) "#()") (deftest print.vector.2 (with-standard-io-syntax (loop for i from 2 to 100 for a = (make-array '(0) :element-type `(unsigned-byte ,i)) for s = (write-to-string a :readably nil :array t :pretty nil) unless (string= s "#()") collect (list i s))) nil) (deftest print.vector.3 (with-standard-io-syntax (loop for i from 1 to 100 for a = (make-array '(0) :element-type `(signed-byte ,i)) for s = (write-to-string a :readably nil :array t :pretty nil) unless (string= s "#()") collect (list i s))) nil) (deftest print.vector.4 (with-standard-io-syntax (loop for type in '(short-float single-float double-float long-float) for a = (make-array '(0) :element-type type) for s = (write-to-string a :readably nil :array t :pretty nil) unless (string= s "#()") collect (list type s))) nil) ;;; Nonempty vectors (deftest print.vector.5 (with-standard-io-syntax (let* ((*package* (find-package "CL-TEST")) (result (write-to-string #(a b c) :readably nil :array t :pretty nil :case :downcase))) (or (and (string= result "#(a b c)") t) result))) t) (deftest print.vector.6 (with-standard-io-syntax (loop for i from 2 to 100 for a = (make-array '(4) :element-type `(unsigned-byte ,i) :initial-contents '(3 0 2 1)) for s = (write-to-string a :readably nil :array t :pretty nil) unless (string= s "#(3 0 2 1)") collect (list i a s))) nil) (deftest print.vector.7 (with-standard-io-syntax (loop for i from 2 to 100 for a = (make-array '(4) :element-type `(signed-byte ,i) :initial-contents '(-2 -1 0 1)) for s = (write-to-string a :readably nil :array t :pretty nil) unless (string= s "#(-2 -1 0 1)") collect (list i a s))) nil) ;;; Vectors with fill pointers (deftest print.vector.fill.1 (with-standard-io-syntax (let ((v (make-array '(10) :initial-contents '(a b c d e f g h i j) :fill-pointer 0)) (*package* (find-package "CL-TEST"))) (loop for i from 0 to 10 do (setf (fill-pointer v) i) collect (write-to-string v :readably nil :array t :pretty nil :case :downcase)))) ("#()" "#(a)" "#(a b)" "#(a b c)" "#(a b c d)" "#(a b c d e)" "#(a b c d e f)" "#(a b c d e f g)" "#(a b c d e f g h)" "#(a b c d e f g h i)" "#(a b c d e f g h i j)")) (deftest print.vector.fill.2 (with-standard-io-syntax (let ((expected '("#()" "#(0)" "#(0 1)" "#(0 1 2)" "#(0 1 2 3)"))) (loop for i from 2 to 100 nconc (let ((v (make-array '(4) :initial-contents '(0 1 2 3) :element-type `(unsigned-byte ,i) :fill-pointer 0))) (loop for fp from 0 to 4 for expected-result in expected for actual-result = (progn (setf (fill-pointer v) fp) (write-to-string v :readably nil :array t :pretty nil)) unless (string= expected-result actual-result) collect (list i fp expected-result actual-result)))))) nil) (deftest print.vector.fill.3 (with-standard-io-syntax (let ((expected '("#()" "#(0)" "#(0 -1)" "#(0 -1 -2)" "#(0 -1 -2 1)"))) (loop for i from 2 to 100 nconc (let ((v (make-array '(4) :initial-contents '(0 -1 -2 1) :element-type `(signed-byte ,i) :fill-pointer 0))) (loop for fp from 0 to 4 for expected-result in expected for actual-result = (progn (setf (fill-pointer v) fp) (write-to-string v :readably nil :array t :pretty nil)) unless (string= expected-result actual-result) collect (list i fp expected-result actual-result)))))) nil) ;;; Displaced vectors (deftest print.vector.displaced.1 (let* ((v1 (vector 'a 'b 'c 'd 'e 'f 'g)) (v2 (make-array 3 :displaced-to v1 :displaced-index-offset 4))) (with-standard-io-syntax (write-to-string v2 :readably nil :array t :case :downcase :pretty nil :escape nil))) "#(e f g)") (deftest print.vector.displaced.2 (with-standard-io-syntax (loop for i from 2 to 100 nconc (let* ((type `(unsigned-byte ,i)) (v1 (make-array 8 :element-type type :initial-contents '(0 1 2 3 0 1 2 3))) (v2 (make-array 5 :displaced-to v1 :displaced-index-offset 2 :element-type type)) (result (write-to-string v2 :readably nil :array t :pretty nil))) (unless (string= result "#(2 3 0 1 2)") (list (list i v1 v2 result)))))) nil) (deftest print.vector.displaced.3 (with-standard-io-syntax (loop for i from 2 to 100 nconc (let* ((type `(signed-byte ,i)) (v1 (make-array 8 :element-type type :initial-contents '(0 1 -1 -2 0 1 -1 -2))) (v2 (make-array 5 :displaced-to v1 :displaced-index-offset 2 :element-type type)) (result (write-to-string v2 :readably nil :array t :pretty nil))) (unless (string= result "#(-1 -2 0 1 -1)") (list (list i v1 v2 result)))))) nil) ;;; Adjustable vectors (deftest print.vector.adjustable.1 (with-standard-io-syntax (let ((v (make-array '(10) :initial-contents '(a b c d e f g h i j) :adjustable t))) (write-to-string v :readably nil :array t :case :downcase :pretty nil :escape nil))) "#(a b c d e f g h i j)") (deftest print.vector.adjustable.2 (with-standard-io-syntax (loop for i from 2 to 100 for type = `(unsigned-byte ,i) for v = (make-array '(8) :initial-contents '(0 1 2 3 3 0 2 1) :adjustable t) for s = (write-to-string v :readably nil :array t :case :downcase :pretty nil :escape nil) unless (string= s "#(0 1 2 3 3 0 2 1)") collect (list i v s))) nil) (deftest print.vector.adjustable.3 (with-standard-io-syntax (loop for i from 2 to 100 for type = `(signed-byte ,i) for v = (make-array '(8) :initial-contents '(0 1 -1 -2 -1 0 -2 1) :adjustable t) for s = (write-to-string v :readably nil :array t :case :downcase :pretty nil :escape nil) unless (string= s "#(0 1 -1 -2 -1 0 -2 1)") collect (list i v s))) nil) ;;; Printing with *print-array* and *print-readably* bound to nil (deftest print.vector.unreadable.1 (with-standard-io-syntax (subseq (write-to-string #(a b c d e) :array nil :readably nil) 0 2)) "#<") (deftest print.vector.unreadable.2 (with-standard-io-syntax (loop for i from 2 to 100 for type = `(unsigned-byte ,i) for v = (make-array '(4) :element-type type :initial-contents '(0 1 2 3)) for result = (write-to-string v :array nil :readably nil) unless (string= (subseq result 0 2) "#<") collect (list i type v result))) nil) (deftest print.vector.unreadable.3 (with-standard-io-syntax (loop for i from 2 to 100 for type = `(signed-byte ,i) for v = (make-array '(4) :element-type type :initial-contents '(0 1 -2 -1)) for result = (write-to-string v :array nil :readably nil) unless (string= (subseq result 0 2) "#<") collect (list i type v result))) nil) ;;; Readability tests (deftest print.vector.random.1 (trim-list (loop for v in *universe* when (vectorp v) nconc (loop repeat 10 nconc (randomly-check-readability v :test #'equalp :can-fail (not (subtypep t (array-element-type v)))))) 10) nil) (deftest print.vector.random.2 (trim-list (loop for i from 2 to 100 for type = `(unsigned-byte ,i) for v = (make-array '(4) :element-type type :initial-contents '(1 3 2 0)) nconc (loop repeat 10 nconc (randomly-check-readability v :test #'equalp :can-fail t))) 10) nil) (deftest print.vector.random.3 (trim-list (loop for i from 2 to 100 for type = `(signed-byte ,i) for v = (make-array '(4) :element-type type :initial-contents '(-1 1 0 -2)) nconc (loop repeat 10 nconc (randomly-check-readability v :test #'equalp :can-fail t))) 10) nil) (deftest print.vector.random.4 (trim-list (loop for v = (make-random-vector (1+ (random 100))) repeat 1000 nconc (randomly-check-readability v :test #'equalp)) 10) nil) ;;; *print-length* checks (deftest print.vector.length.1 (with-standard-io-syntax (write-to-string #() :pretty nil :length 0 :readably nil)) "#()") (deftest print.vector.length.2 (with-standard-io-syntax (write-to-string #(1) :pretty nil :length 0 :readably nil)) "#(...)") (deftest print.vector.length.3 (with-standard-io-syntax (write-to-string #(1) :pretty nil :length 1 :readably nil)) "#(1)") (deftest print.vector.length.4 (with-standard-io-syntax (write-to-string #(a b c d e f g h) :pretty nil :array t :escape nil :length 5 :case :downcase :readably nil)) "#(a b c d e ...)") (deftest print.vector.length.5 (with-standard-io-syntax (loop for i from 2 to 100 for type = `(unsigned-byte ,i) for v = (make-array '(0) :element-type type) for result = (write-to-string v :array t :readably nil :pretty nil :length 0) unless (string= result "#()") collect (list i type v result))) nil) (deftest print.vector.length.6 (with-standard-io-syntax (loop for i from 2 to 100 for type = `(unsigned-byte ,i) for v = (make-array '(1) :element-type type :initial-contents '(2)) for result = (write-to-string v :pretty nil :array t :readably nil :length 0) unless (string= result "#(...)") collect (list i type v result))) nil) (deftest print.vector.length.7 (with-standard-io-syntax (loop for i from 1 to 100 for type = `(signed-byte ,i) for v = (make-array '(1) :element-type type :initial-contents '(-1)) for result = (write-to-string v :pretty nil :array t :readably nil :length 0) unless (string= result "#(...)") collect (list i type v result))) nil) (deftest print.vector.length.8 (with-standard-io-syntax (loop for i from 2 to 100 for type = `(unsigned-byte ,i) for v = (make-array '(4) :element-type type :initial-contents '(1 3 0 2)) for result = (write-to-string v :pretty nil :array t :readably nil :length 2) unless (string= result "#(1 3 ...)") collect (list i type v result))) nil) (deftest print.vector.length.9 (with-standard-io-syntax (loop for i from 2 to 100 for type = `(signed-byte ,i) for v = (make-array '(4) :element-type type :initial-contents '(1 -2 0 -1)) for result = (write-to-string v :pretty nil :array t :readably nil :length 2) unless (string= result "#(1 -2 ...)") collect (list i type v result))) nil) ;;; Printing with *print-level* bound (deftest print.vector.level.1 (with-standard-io-syntax (write-to-string #() :level 0 :readably nil :pretty nil)) "#") (deftest print.vector.level.2 (with-standard-io-syntax (write-to-string #() :level 1 :readably nil :pretty nil)) "#()") (deftest print.vector.level.3 (with-standard-io-syntax (write-to-string #(17) :level 1 :readably nil :pretty nil)) "#(17)") (deftest print.vector.level.4 (with-standard-io-syntax (write-to-string #(4 (17) 9 (a) (b) 0) :level 1 :readably nil :pretty nil)) "#(4 # 9 # # 0)") (deftest print.vector.level.5 (with-standard-io-syntax (write-to-string '(#(a)) :level 1 :readably nil :pretty nil)) "(#)") (deftest print.vector.level.6 (with-standard-io-syntax (write-to-string '#(#(a)) :level 1 :readably nil :pretty nil)) "#(#)") gcl27-2.7.0/ansi-tests/print.lsp000066400000000000000000000015531454061450500164140ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jul 25 11:41:16 2004 ;;;; Contains: Tests of PRINT (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; This function is mostly tested elsewhere (deftest print.1 (random-print-test 1000) nil) (deftest print.2 (with-standard-io-syntax (with-output-to-string (os) (with-input-from-string (is "") (with-open-stream (*terminal-io* (make-two-way-stream is os)) (print 2 t))))) " 2 ") (deftest print.3 (with-standard-io-syntax (with-output-to-string (*standard-output*) (print 3 nil))) " 3 ") ;;; Error tests (deftest print.error.1 (signals-error (with-output-to-string (*standard-output*) (print)) program-error) t) (deftest print.error.2 (signals-error (with-output-to-string (s) (print nil s nil)) program-error) t) gcl27-2.7.0/ansi-tests/printer-aux.lsp000066400000000000000000000402241454061450500175340ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Feb 23 06:20:00 2004 ;;;; Contains: Auxiliary functions and macros for printer tests (in-package :cl-test) (eval-when (:compile-toplevel :load-toplevel :execute) (compile-and-load "random-aux.lsp")) (defmacro def-print-test (name form result &rest bindings) `(deftest ,name (if (equalpt (my-with-standard-io-syntax (let ((*print-readably* nil)) (let ,bindings (with-output-to-string (*standard-output*) (prin1 ,form))))) ,result) t ,result) t)) (defmacro def-pprint-test (name form expected-value &key (margin 100) (miser nil) (circle nil) (len nil) (pretty t) (escape nil) (readably nil) (package (find-package "CL-TEST"))) `(deftest ,name (with-standard-io-syntax (let ((*print-pretty* ,pretty) (*print-escape* ,escape) (*print-readably* ,readably) (*print-right-margin* ,margin) (*package* ,package) (*print-length* ,len) (*print-miser-width* ,miser) (*print-circle* ,circle)) ,form)) ,expected-value)) (defmacro def-ppblock-test (name form expected-value &rest key-args) `(def-pprint-test ,name (with-output-to-string (*standard-output*) (pprint-logical-block (*standard-output* nil) ,form)) ,expected-value ,@key-args)) ;;; Function to test readable of printed forms, under random settings ;;; of various printer control variables. ;;; ;;; Return NIL if obj printed and read properly, or a list containing ;;; the object and the printer variable bindings otherwise. They key ;;; argument TEST is used to compared the reread object and obj. (defvar *random-read-check-debug* nil "When set to true, RANDOMLY-CHECK-READABILITY will dump out parameter settings before trying a test. This is intended for cases where the error that occurs is fatal.") (defun randomly-check-readability (obj &key (can-fail nil) (test #'equal) (readable t) (circle nil circle-p) (escape nil escape-p) (gensym nil gensym-p) (debug *random-read-check-debug*)) (declare (type function test)) ;; Generate random printer-control values (my-with-standard-io-syntax (let ((*print-array* (coin)) (*print-base* (+ 2 (random 34))) (*print-radix* (coin)) (*print-case* (random-from-seq #(:upcase :downcase :capitalize))) (*print-circle* (if circle-p circle (coin))) (*print-escape* (if escape-p escape (coin))) (*print-gensym* (if gensym-p gensym (coin))) (*print-level* (random 50)) (*print-length* (if readable (random 50) nil)) (*print-lines* (if readable (random 50) nil)) (*print-miser-width* (and (coin) (random 100))) (*print-pretty* (coin)) (*print-right-margin* (and (coin) (random 100))) (*print-readably* readable) (*read-default-float-format* (rcase (1 'short-float) (1 'single-float) (1 'double-float) (1 'long-float) (1 *read-default-float-format*))) (*readtable* (copy-readtable)) (readcase (random-from-seq #(:upcase :downcase :preserve :invert))) ) (flet ((%params () (list (list '*print-readably* *print-readably*) (list '*print-array* *print-array*) (list '*print-base* *print-base*) (list '*print-radix* *print-radix*) (list '*print-case* *print-case*) (list '*print-circle* *print-circle*) (list '*print-escape* *print-escape*) (list '*print-gensym* *print-gensym*) (list '*print-level* *print-level*) (list '*print-length* *print-length*) (list '*print-lines* *print-lines*) (list '*print-miser-width* *print-miser-width*) (list '*print-pretty* *print-pretty*) (list '*print-right-margin* *print-right-margin*) (list '*read-default-float-format* *read-default-float-format*) (list 'readtable-case readcase)))) (when debug (let ((params (%params))) (with-standard-io-syntax (format *debug-io* "~%~A~%" params))) (finish-output *debug-io*)) (setf (readtable-case *readtable*) readcase) (let* ((str (handler-case (with-output-to-string (s) (write obj :stream s)) (print-not-readable () (if can-fail (return-from randomly-check-readability nil) ":print-not-readable-error")))) (obj2 (let ((*read-base* *print-base*)) (handler-case (let ((*readtable* (if *print-readably* (copy-readtable nil) *readtable*))) (read-from-string str)) (reader-error () :reader-error) (end-of-file () :end-of-file) (stream-error () :stream-error) (file-error () :file-error) )))) (unless (funcall test obj obj2) (list (list* obj str obj2 (%params) )))))))) (defun parse-escaped-string (string) "Parse a string into a list of either characters (representing themselves unescaped) or lists ( :escape) (representing escaped characters.)" (assert (stringp string) () "Not a string: ~A" string) (let ((result nil) (len (length string)) (index 0)) (prog () normal ; parsing in normal mode (when (= index len) (return)) (let ((c (elt string index))) (cond ((eql c #\\) (assert (< (incf index) len) () "End of string after \\") (push `(,(elt string index) :escaped) result) (incf index) (go normal)) ((eql c #\|) (incf index) (go multiple-escaped)) (t (push c result) (incf index) (go normal)))) multiple-escaped ; parsing inside |s (assert (< index len) () "End of string inside |") (let ((c (elt string index))) (cond ((eq c #\|) (incf index) (go normal)) (t (push `(,c :escaped) result) (incf index) (go multiple-escaped))))) (nreverse result))) (defun escaped-equal (list1 list2) "Determine that everything escaped in list1 is also escaped in list2, and that the characters are also the same." (and (= (length list1) (length list2)) (loop for e1 in list1 for e2 in list2 for is-escaped1 = (and (consp e1) (eq (cadr e1) :escaped)) for is-escaped2 = (and (consp e2) (eq (cadr e2) :escaped)) for c1 = (if is-escaped1 (car e1) e1) for c2 = (if is-escaped2 (car e2) e2) always (and (if is-escaped1 is-escaped2 t) (char= c1 c2))))) (defun similar-uninterned-symbols (s1 s2) (and (symbolp s1) (symbolp s2) (null (symbol-package s1)) (null (symbol-package s2)) (string= (symbol-name s1) (symbol-name s2)))) (defun make-random-cons-tree (size) (if (<= size 1) (rcase (5 nil) (1 (random 1000)) (1 (random 1000.0)) (2 (random-from-seq #(a b c d e f g |1| |2| |.|)))) (let ((s1 (1+ (random (1- size))))) (cons (make-random-cons-tree s1) (make-random-cons-tree (- size s1)))))) (defun make-random-vector (size) (if (> size 1) (let* ((nelems (min (1- size) (1+ (random (max 2 (floor size 4)))))) (sizes (mapcar #'1+ (random-partition* (- size nelems 1) nelems)))) (make-array nelems :initial-contents (mapcar #'make-random-vector sizes))) (rcase (1 (random-from-seq #(a b c d e f g))) (1 (- (random 2001) 1000)) (1 (random 1000.0)) ))) ;;; Random printing test for WRITE and related functions (defun funcall-with-print-bindings (fun &key ((:array *print-array*) *print-array*) ((:base *print-base*) *print-base*) ((:case *print-case*) *print-case*) ((:circle *print-circle*) *print-circle*) ((:escape *print-escape*) *print-escape*) ((:gensym *print-gensym*) *print-gensym*) ((:length *print-length*) *print-length*) ((:level *print-level*) *print-level*) ((:lines *print-lines*) *print-lines*) ((:miser-width *print-miser-width*) *print-miser-width*) ((:pprint-dispatch *print-pprint-dispatch*) *print-pprint-dispatch*) ((:pretty *print-pretty*) *print-pretty*) ((:radix *print-radix*) *print-radix*) ((:readably *print-readably*) *print-readably*) ((:right-margin *print-right-margin*) *print-right-margin*) ((:stream *standard-output*) *standard-output*)) (funcall fun)) (defun output-test (obj &key (fun #'write) ((:array *print-array*) *print-array*) ((:base *print-base*) *print-base*) ((:case *print-case*) *print-case*) ((:circle *print-circle*) *print-circle*) ((:escape *print-escape*) *print-escape*) ((:gensym *print-gensym*) *print-gensym*) ((:length *print-length*) *print-length*) ((:level *print-level*) *print-level*) ((:lines *print-lines*) *print-lines*) ((:miser-width *print-miser-width*) *print-miser-width*) ((:pprint-dispatch *print-pprint-dispatch*) *print-pprint-dispatch*) ((:pretty *print-pretty*) *print-pretty*) ((:radix *print-radix*) *print-radix*) ((:readably *print-readably*) *print-readably*) ((:right-margin *print-right-margin*) *print-right-margin*) ((:stream *standard-output*) *standard-output*)) (let ((results (multiple-value-list (funcall fun obj)))) (assert (= (length results) 1)) (assert (eql (car results) obj)) obj)) (defun make-random-key-param (name) (rcase (1 nil) (1 `(,name nil)) (1 `(,name t)))) (defun make-random-key-integer-or-nil-param (name bound) (rcase (1 nil) (1 `(,name nil)) (1 `(,name ,(random bound))))) (defun make-random-write-args () (let* ((arg-lists `(,@(mapcar #'make-random-key-param '(:array :circle :escape :gensym :pretty :radix :readably)) ,(rcase (1 nil) (1 `(:base ,(+ 2 (random 35))))) ,(and (coin) `(:case ,(random-from-seq #(:upcase :downcase :capitalize)))) ,@(mapcar #'make-random-key-integer-or-nil-param '(:length :level :lines :miser-width :right-margin) '(100 20 50 200 200))))) (reduce #'append (random-permute arg-lists) :from-end t))) (defun filter-unreadable-forms (string) "Find #<...> strings and replace with #<>." (let ((len (length string)) (pos 0)) (loop while (< pos len) do (let ((next (search "#<" string :start2 pos))) (unless next (return string)) (let ((end (position #\> string :start next))) (unless end (return string)) (setq string (concatenate 'string (subseq string 0 next) "#<>" (subseq string (1+ end))) pos (+ next 3) len (+ len (- next end) 3))))))) (defmacro def-random-write-test-fun (name write-args test-fn &key (prefix "") (suffix "")) `(defun ,name (n &key (size 10)) (loop for args = (make-random-write-args) for package = (find-package (random-from-seq #("CL-TEST" "CL-USER" "KEYWORD"))) for obj = (let ((*random-readable* t)) (declare (special *random-readable*)) (random-thing (random size))) for s1 = (let ((*package* package)) (with-output-to-string (s) (apply #'write obj :stream s ,@write-args args))) for s2 = (let ((*package* package)) (with-output-to-string (*standard-output*) (apply #'output-test obj :fun ,test-fn args))) repeat n ;; We filter the contents of #<...> forms since they may change with time ;; if they contain object addresses. unless (string= (filter-unreadable-forms (concatenate 'string ,prefix s1 ,suffix)) (filter-unreadable-forms s2)) collect (list obj s1 s2 args)))) (def-random-write-test-fun random-write-test nil #'write) (def-random-write-test-fun random-prin1-test (:escape t) #'prin1) (def-random-write-test-fun random-princ-test (:escape nil :readably nil) #'princ) (def-random-write-test-fun random-print-test (:escape t) #'print :prefix (string #\Newline) :suffix " ") (def-random-write-test-fun random-pprint-test (:escape t :pretty t) #'(lambda (obj) (assert (null (multiple-value-list (pprint obj)))) obj) :prefix (string #\Newline)) (defmacro def-random-write-to-string-test-fun (name write-args test-fn &key (prefix "") (suffix "")) `(defun ,name (n) (loop for args = (make-random-write-args) for package = (find-package (random-from-seq #("CL-TEST" "CL-USER" "KEYWORD"))) for obj = (let ((*random-readable* t)) (declare (special *random-readable*)) (random-thing (random 10))) for s1 = (let ((*package* package)) (with-output-to-string (s) (apply #'write obj :stream s ,@write-args args))) for s2 = (let ((*package* package)) (apply ,test-fn obj args)) repeat n unless (string= (filter-unreadable-forms (concatenate 'string ,prefix s1 ,suffix)) (filter-unreadable-forms s2)) collect (list obj s1 s2)))) (def-random-write-to-string-test-fun random-write-to-string-test nil #'write-to-string) (def-random-write-to-string-test-fun random-prin1-to-string-test (:escape t) #'(lambda (obj &rest args) (apply #'funcall-with-print-bindings #'(lambda () (prin1-to-string obj)) args))) (def-random-write-to-string-test-fun random-princ-to-string-test (:escape nil :readably nil) #'(lambda (obj &rest args) (apply #'funcall-with-print-bindings #'(lambda () (princ-to-string obj)) args))) ;;; Routines for testing floating point printing (defun decode-fixed-decimal-string (s) "Return a rational equal to the number represented by a decimal floating (without exponent). Trim off leading/trailing spaces." (setq s (string-trim " " s)) (assert (> (length s) 0)) (let (neg) (when (eql (elt s 0) #\-) (setq s (subseq s 1)) (setq neg t)) ;; Check it's of the form {digits}.{digits} (let ((dot-pos (position #\. s))) (assert dot-pos) (let ((prefix (subseq s 0 dot-pos)) (suffix (subseq s (1+ dot-pos)))) (assert (every #'digit-char-p prefix)) (assert (every #'digit-char-p suffix)) (let* ((prefix-len (length prefix)) (prefix-integer (if (eql prefix-len 0) 0 (parse-integer prefix))) (suffix-len (length suffix)) (suffix-integer (if (eql suffix-len 0) 0 (parse-integer suffix))) (magnitude (+ prefix-integer (* suffix-integer (expt 1/10 suffix-len))))) (if neg (- magnitude) magnitude)))))) ;;; Macro to define both FORMAT and FORMATTER tests (defmacro def-format-test (name string args expected-output &optional (num-left 0)) (assert (symbolp name)) (let* ((s (symbol-name name)) (expected-prefix (string 'format.)) (expected-prefix-length (length expected-prefix))) (assert (>= (length s) expected-prefix-length)) (assert (string-equal (subseq s 0 expected-prefix-length) expected-prefix)) (let* ((formatter-test-name-string (concatenate 'string (string 'formatter.) (subseq s expected-prefix-length))) (formatter-test-name (intern formatter-test-name-string (symbol-package name))) (formatter-form (if (stringp string) `(formatter ,string) (list 'formatter (eval string))))) `(progn (deftest ,name (with-standard-io-syntax (let ((*print-readably* nil) (*package* (symbol-package 'ABC))) (format nil ,string ,@args))) ,expected-output) (deftest ,formatter-test-name (let ((fn ,formatter-form) (args (list ,@args))) (with-standard-io-syntax (let ((*print-readably* nil) (*package* (symbol-package 'ABC))) (with-output-to-string (stream) (let ((tail (apply fn stream args))) ;; FIXME -- Need to check that TAIL really is a tail of ARGS (assert (= (length tail) ,num-left) (tail) "Tail is ~A, length should be ~A" tail ,num-left) ))))) ,expected-output))))) ;;; Macro used for an idiom in testing FORMATTER calls (defmacro formatter-call-to-string (fn &body args) (let ((stream (gensym "S"))) `(with-output-to-string (,stream) (assert (equal (funcall ,fn ,stream ,@args 'a) '(a)))))) gcl27-2.7.0/ansi-tests/printer-control-vars.lsp000066400000000000000000000014341454061450500213700ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jun 3 06:25:52 2004 ;;;; Contains: Tests of initial values of printer control variables (in-package :cl-test) (deftest print-base.init.1 *print-base* 10) (deftest print-radix.init.1 *print-radix* nil) (deftest print-case.init.1 *print-case* :upcase) (deftest print-circle.init.1 *print-circle* nil) (deftest print-escape.init.1 (notnot *print-escape*) t) (deftest print-gensym.init.1 (notnot *print-gensym*) t) (deftest print-level.init.1 *print-level* nil) (deftest print-length.init.1 *print-length* nil) (deftest print-lines.init.1 *print-lines* nil) (deftest print-readably.init.1 *print-readably* nil) (deftest print-right-margin.init.1 *print-right-margin* nil) gcl27-2.7.0/ansi-tests/probe-file.lsp000066400000000000000000000024451454061450500173050ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 5 20:46:29 2004 ;;;; Contains: Tests of PROBE-FILE (in-package :cl-test) (deftest probe-file.1 (probe-file #p"nonexistent") nil) (deftest probe-file.2 (let ((s (open #p"probe-file.lsp" :direction :input))) (prog1 (equalpt (truename #p"probe-file.lsp") (probe-file s)) (close s))) t) (deftest probe-file.3 (let ((s (open #p"probe-file.lsp" :direction :input))) (close s) (equalpt (truename #p"probe-file.lsp") (probe-file s))) t) (deftest probe-file.4 (equalpt (truename #p"probe-file.lsp") (probe-file "CLTEST:PROBE-FILE.LSP")) t) ;;; Specialized string tests (deftest probe-file.5 (do-special-strings (str "probe-file.lsp" nil) (let ((s (open str :direction :input))) (assert (equalpt (truename #p"probe-file.lsp") (probe-file s))) (close s))) nil) ;;; Error tests (deftest probe-file.error.1 (signals-error (probe-file) program-error) t) (deftest probe-file.error.2 (signals-error (probe-file #p"probe-file.lsp" nil) program-error) t) (deftest probe-file.error.3 (signals-error-always (probe-file (make-pathname :name :wild)) file-error) t t) (deftest probe-file.error.4 (signals-error-always (probe-file "CLTEST:*.FOO") file-error) t t) gcl27-2.7.0/ansi-tests/proclaim.lsp000066400000000000000000000027041454061450500170650ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 21 07:33:53 2005 ;;;; Contains: Tests of PROCLAIM (in-package :cl-test) (deftest proclaim.1 (let ((sym (gensym))) (proclaim `(special ,sym)) (eval `(flet ((%f () ,sym)) (let ((,sym :good)) (%f))))) :good) (deftest proclaim.2 (let ((sym (gensym))) (proclaim `(declaration ,sym)) (proclaim `(,sym)) nil) nil) (deftest proclaim.3 (let ((i 0)) (proclaim (progn (incf i) '(optimize))) i) 1) ;;; Error cases (deftest proclaim.error.1 (signals-error (proclaim) program-error) t) (deftest proclaim.error.2 (signals-error (proclaim '(optimize) nil) program-error) t) (deftest proclaim.error.3 (signals-error (proclaim `(optimize . foo)) error) t) (deftest proclaim.error.4 (signals-error (proclaim `(inline . foo)) error) t) (deftest proclaim.error.5 (signals-error (proclaim `(notinline . foo)) error) t) (deftest proclaim.error.6 (signals-error (proclaim `(type . foo)) error) t) (deftest proclaim.error.7 (signals-error (proclaim `(ftype . foo)) type-error) t) (deftest proclaim.error.8 (signals-error (proclaim '(type integer . foo)) error) t) (deftest proclaim.error.9 (signals-error (proclaim '(integer . foo)) error) t) (deftest proclaim.error.10 (signals-error (proclaim '(declaration . foo)) error) t) (deftest proclaim.error.11 (signals-error (proclaim '(ftype (function (t) t) . foo)) error) t) gcl27-2.7.0/ansi-tests/prog.lsp000066400000000000000000000054451454061450500162330ustar00rootroot00000000000000;-*- 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) (deftest prog.11 (let ((x :bad)) (declare (special x)) (let ((x :good)) (prog ((y x)) (declare (special x)) (return y)))) :good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest prog.12 (macrolet ((%m (z) z)) (prog ((x (expand-in-current-env (%m :good)))) (return x))) :good) (def-macro-test prog.error.1 (prog nil)) ;;; 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) (deftest prog*.11 (let ((x :bad)) (declare (special x)) (let ((x :good)) (prog* ((y x)) (declare (special x)) (return y)))) :good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest prog*.12 (macrolet ((%m (z) z)) (prog* ((x (expand-in-current-env (%m :good)))) (return x))) :good) (def-macro-test prog*.error.1 (prog* nil)) gcl27-2.7.0/ansi-tests/prog1.lsp000066400000000000000000000014361454061450500163100ustar00rootroot00000000000000;-*- 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) ;;; Test that prog1 doesn't have a tagbody (deftest prog1.6 (block nil (tagbody (return (prog1 'bad (go 10) 10)) 10 (return 'good))) good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest prog1.7 (macrolet ((%m (z) z)) (prog1 (expand-in-current-env (%m 'good)))) good) (def-macro-test prog1.error.1 (prog1 nil)) gcl27-2.7.0/ansi-tests/prog2.lsp000066400000000000000000000020401454061450500163010ustar00rootroot00000000000000;-*- 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) ;;; Test that prog2 doesn't have a tagbody (deftest prog2.7 (block nil (tagbody (return (prog2 17 'bad (go 10) 10)) 10 (return 'good))) good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest prog2.8 (macrolet ((%m (z) z)) (prog2 (expand-in-current-env (%m 'bad1)) (expand-in-current-env (%m 'good)) (expand-in-current-env (%m 'bad2)))) good) (def-macro-test prog2.error.1 (prog2 nil nil)) gcl27-2.7.0/ansi-tests/progn.lsp000066400000000000000000000017771454061450500164150ustar00rootroot00000000000000;-*- 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) ;;; No implicit tagbody (deftest progn.8 (block nil (tagbody (progn (go 10) 10 (return 'bad)) 10 (return 'good))) good) ;;; Macros are expanded in the appropriate environment (deftest progn.9 (macrolet ((%m (z) z)) (progn (expand-in-current-env (%m :good)))) :good) (deftest progn.10 (macrolet ((%m (z) z)) (progn (expand-in-current-env (%m :bad)) (expand-in-current-env (%m :good)))) :good) gcl27-2.7.0/ansi-tests/progv.lsp000066400000000000000000000046021454061450500164130ustar00rootroot00000000000000;-*- 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) ;;; No tagbody (deftest progv.11 (block nil (tagbody (progv nil nil (go 10) 10 (return 'bad)) 10 (return 'good))) good) ;;; Variables that are not bound don't have any type constraints (deftest progv.12 (progv '(x y) '(1) (locally (declare (special x y) (type nil y)) (values x (boundp 'y)))) 1 nil) ;;; Macros are expanded in the appropriate environment (deftest progv.13 (macrolet ((%m (z) z)) (progv (expand-in-current-env (%m '(x))) '(:good) (locally (declare (special x)) x))) :good) (deftest progv.14 (macrolet ((%m (z) z)) (progv (list (expand-in-current-env (%m 'x))) '(:good) (locally (declare (special x)) x))) :good) (deftest progv.15 (macrolet ((%m (z) z)) (progv '(x) (expand-in-current-env (%m '(:good))) (locally (declare (special x)) x))) :good) (deftest progv.16 (macrolet ((%m (z) z)) (progv '(x) (list (expand-in-current-env (%m :good))) (locally (declare (special x)) x))) :good) (deftest progv.17 (macrolet ((%m (z) z)) (progv nil nil (expand-in-current-env (%m :good)))) :good) gcl27-2.7.0/ansi-tests/psetf.lsp000066400000000000000000000211271454061450500164000ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 15:38:30 2003 ;;;; Contains: Tests of PSETF (in-package :cl-test) (deftest psetf.order.1 (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 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)) (deftest psetf.10 (let ((*x* 0) (*y* 10)) (declare (special *x* *y*)) (values *x* *y* (psetf *x* 6 *y* 15) *x* *y*)) 0 10 nil 6 15) (deftest psetf.11 (let ((*x* 0) (*y* 10)) (declare (special *x* *y*)) (values *x* *y* (psetf *x* *y* *y* *x*) *x* *y*)) 0 10 nil 10 0) (def-macro-test psetf.error.1 (psetf)) ;;; PSETF is a good testbed for finding conflicts in setf expansions ;;; These tests apply psetf to various accessors (deftest psetf.12 (let* ((x (list 'a 'b)) (y (list 'c 'd))) (psetf (car x) 1 (car y) 2) (values x y)) (1 b) (2 d)) (deftest psetf.12a (let* ((x (list 'a 'b)) (y (list 'c 'd))) (psetf (first x) 1 (first y) 2) (values x y)) (1 b) (2 d)) (deftest psetf.13 (let* ((x (list 'a 'b)) (y (list 'c 'd))) (psetf (cdr x) 1 (cdr y) 2) (values x y)) (a . 1) (c . 2)) (deftest psetf.13a (let* ((x (list 'a 'b)) (y (list 'c 'd))) (psetf (rest x) 1 (rest y) 2) (values x y)) (a . 1) (c . 2)) (deftest psetf.14 (let* ((x (list 'a 'b)) (y (list 'c 'd))) (psetf (cadr x) 1 (cadr y) 2) (values x y)) (a 1) (c 2)) (deftest psetf.15 (let* ((x (list 'a 'b)) (y (list 'c 'd))) (psetf (cddr x) 1 (cddr y) 2) (values x y)) (a b . 1) (c d . 2)) (deftest psetf.16 (let* ((x (list (list 'a))) (y (list (list 'c)))) (psetf (caar x) 1 (caar y) 2) (values x y)) ((1)) ((2))) (deftest psetf.17 (let* ((x (list (list 'a))) (y (list (list 'c)))) (psetf (cdar x) 1 (cdar y) 2) (values x y)) ((a . 1)) ((c . 2))) ;;; TODO: c*r accessors with > 2 a/d ;;; TODO: third,...,tenth (deftest psetf.18 (let* ((x (vector 'a 'b)) (y (vector 'c 'd))) (psetf (aref x 0) 1 (aref y 0) 2) (values x y)) #(1 b) #(2 d)) (deftest psetf.18a (let* ((x (vector 'a 'b)) (y (vector 'c 'd))) (psetf (svref x 0) 1 (svref y 0) 2) (values x y)) #(1 b) #(2 d)) (deftest psetf.19 (let* ((x (copy-seq #*11000)) (y (copy-seq #*11100))) (psetf (bit x 1) 0 (bit x 2) 1 (bit y 4) 1 (bit y 0) 0) (values x y)) #*10100 #*01101) (deftest psetf.20 (let* ((x (copy-seq "abcde")) (y (copy-seq "fghij"))) (psetf (char x 1) #\X (char y 2) #\Y) (values x y)) "aXcde" "fgYij") (deftest psetf.21 (let* ((x (copy-seq #*11000)) (y (copy-seq #*11100))) (psetf (sbit x 1) 0 (sbit x 2) 1 (sbit y 4) 1 (sbit y 0) 0) (values x y)) #*10100 #*01101) (deftest psetf.22 (let* ((x (copy-seq "abcde")) (y (copy-seq "fghij"))) (psetf (schar x 1) #\X (schar y 2) #\Y) (values x y)) "aXcde" "fgYij") (deftest psetf.23 (let* ((x (copy-seq '(a b c d e))) (y (copy-seq '(f g h i j)))) (psetf (elt x 1) 'u (elt y 2) 'v) (values x y)) (a u c d e) (f g v i j)) (deftest psetf.24 (let ((x #b110110001) (y #b101001100)) (psetf (ldb (byte 5 1) x) #b10110 (ldb (byte 3 6) y) #b10) (values x y)) #b110101101 #b010001100) (deftest psetf.25 (let* ((f1 (gensym)) (f2 (gensym)) (fn1 (constantly :foo)) (fn2 (constantly :bar))) (psetf (fdefinition f1) fn1 (fdefinition f2) fn2) (values (funcall f1) (funcall f2))) :foo :bar) (deftest psetf.26 (let* ((a1 (make-array '(10) :fill-pointer 5)) (a2 (make-array '(20) :fill-pointer 7))) (psetf (fill-pointer a1) (1+ (fill-pointer a2)) (fill-pointer a2) (1- (fill-pointer a1))) (values (fill-pointer a1) (fill-pointer a2))) 8 4) (deftest psetf.27 (let* ((x (list 'a 'b 'c 'd)) (y (list 'd 'e 'f 'g)) (n1 1) (n2 2) (v1 :foo) (v2 :bar)) (psetf (nth n1 x) v1 (nth n2 y) v2) (values x y)) (a :foo c d) (d e :bar g)) (deftest psetf.28 (let* ((f1 (gensym)) (f2 (gensym)) (fn1 (constantly :foo)) (fn2 (constantly :bar))) (psetf (symbol-function f1) fn1 (symbol-function f2) fn2) (values (funcall f1) (funcall f2))) :foo :bar) (deftest psetf.29 (let* ((s1 (gensym)) (s2 (gensym)) (v1 :foo) (v2 :bar)) (psetf (symbol-value s1) v1 (symbol-value s2) v2) (values (symbol-value s1) (symbol-value s2))) :foo :bar) (deftest psetf.30 (let* ((s1 (gensym)) (s2 (gensym)) (v1 (list :foo 1)) (v2 (list :bar 2))) (psetf (symbol-plist s1) v1 (symbol-plist s2) v2) (values (symbol-plist s1) (symbol-plist s2))) (:foo 1) (:bar 2)) (deftest psetf.31 (let* ((x (list 'a 'b 'c 'd 'e)) (y (list 'f 'g 'h 'i 'j)) (v1 (list 1 2)) (v2 (list 3 4 5)) (p1 1) (p2 2) (l1 (length v1)) (l2 (length v2))) (psetf (subseq x p1 (+ p1 l1)) v1 (subseq y p2 (+ p2 l2)) v2) (values x y)) (a 1 2 d e) (f g 3 4 5)) (deftest psetf.32 (let* ((x (gensym)) (y (gensym)) (k1 :foo) (k2 :bar) (v1 1) (v2 2)) (psetf (get x k1) v1 (get y k2) v2) (values (symbol-plist x) (symbol-plist y))) (:foo 1) (:bar 2)) (deftest psetf.33 (let* ((x nil) (y nil) (k1 :foo) (k2 :bar) (v1 1) (v2 2)) (psetf (getf x k1) v1 (getf y k2) v2) (values x y)) (:foo 1) (:bar 2)) (deftest psetf.34 (let* ((ht1 (make-hash-table)) (ht2 (make-hash-table)) (k1 :foo) (v1 1) (k2 :bar) (v2 2)) (psetf (gethash k1 ht1) v1 (gethash k2 ht2) v2) (values (gethash k1 ht1) (gethash k2 ht2))) 1 2) (deftest psetf.35 (let ((n1 (gensym)) (n2 (gensym)) (n3 (gensym)) (n4 (gensym))) (eval `(defclass ,n1 () ())) (eval `(defclass ,n2 () ())) (psetf (find-class n3) (find-class n1) (find-class n4) (find-class n2)) (values (eqlt (find-class n1) (find-class n3)) (eqlt (find-class n2) (find-class n4)))) t t) (deftest psetf.36 (let ((fn1 (constantly :foo)) (fn2 (constantly :bar)) (n1 (gensym)) (n2 (gensym))) (psetf (macro-function n1) fn1 (macro-function n2) fn2) (values (eval `(,n1)) (eval `(,n2)))) :foo :bar) (deftest psetf.37 (let ((b1 (byte 3 1)) (b2 (byte 4 2)) (x #b1100101011010101) (y #b11010101000110) (m1 #b101010101101101) (m2 #b11110010110101)) (psetf (mask-field b1 x) m1 (mask-field b2 y) m2) (values x y)) #b1100101011011101 #b11010101110110) (deftest psetf.38 (let* ((a1 (make-array '(2 3) :initial-contents '((a b c)(d e f)))) (a2 (make-array '(3 4) :initial-contents '((1 2 3 4) (5 6 7 8) (9 10 11 12)))) (i1 2) (i2 5) (v1 'u) (v2 'v)) (psetf (row-major-aref a1 i1) v1 (row-major-aref a2 i2) v2) (values a1 a2)) #2a((a b u)(d e f)) #2a((1 2 3 4)(5 v 7 8)(9 10 11 12))) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest psetf.39 (macrolet ((%m (z) z)) (let ((x 1) (y 2)) (values (psetf (expand-in-current-env (%m x)) y y x) x y))) nil 2 1) (deftest psetf.40 (macrolet ((%m (z) z)) (let ((x 1) (y 2)) (values (psetf x (expand-in-current-env (%m y)) y x) x y))) nil 2 1) ;;; TODO: logical-pathname-translations, readtable-case gcl27-2.7.0/ansi-tests/psetq.lsp000066400000000000000000000037271454061450500164210ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 15:37:20 2003 ;;;; Contains: Tests of PSETQ (in-package :cl-test) (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) (deftest psetq.8 (let ((*x* 0) (*y* 10)) (declare (special *x* *y*)) (values *x* *y* (psetq *x* 6 *y* 15) *x* *y*)) 0 10 nil 6 15) (deftest psetq.9 (let ((*x* 0) (*y* 10)) (declare (special *x* *y*)) (values *x* *y* (psetq *x* *y* *y* *x*) *x* *y*)) 0 10 nil 10 0) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest psetq.10 (macrolet ((%m (z) z)) (let ((x nil) (y nil)) (values (psetq x (expand-in-current-env (%m 1)) y (expand-in-current-env (%m 2))) x y))) nil 1 2) (deftest psetq.error.1 (signals-error (funcall (macro-function 'psetq)) program-error) t) (deftest psetq.error.2 (signals-error (funcall (macro-function 'psetq) '(psetq)) program-error) t) (deftest psetq.error.3 (signals-error (funcall (macro-function 'psetq) '(psetq) nil nil) program-error) t) gcl27-2.7.0/ansi-tests/push.lsp000066400000000000000000000026411454061450500162360ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:05:34 2003 ;;;; Contains: Tests of PUSH (in-package :cl-test) (compile-and-load "cons-aux.lsp") ;;; 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)) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest push.4 (macrolet ((%m (z) z)) (let ((x nil)) (values (push (expand-in-current-env (%m 1)) x) x))) (1) (1)) (deftest push.5 (macrolet ((%m (z) z)) (let ((x nil)) (values (push 1 (expand-in-current-env (%m x))) x))) (1) (1)) (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) (deftest push.order.2 (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 push.order.3 (let ((x '(a b c))) (values (push (progn (setq x '(d e)) 'z) x) x)) (z d e) (z d e)) (def-macro-test push.error.1 (push x y)) ;;; Need to add push vs. various accessors gcl27-2.7.0/ansi-tests/pushnew.lsp000066400000000000000000000144131454061450500167500ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:28:35 2003 ;;;; Contains: Tests of PUSHNEW (in-package :cl-test) (compile-and-load "cons-aux.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.16 (let ((x '(1 2 3))) (values (pushnew 10 x :test #'<=) x)) (10 1 2 3) (10 1 2 3)) (deftest pushnew.17 (let ((x '(1 2 3))) (values (pushnew 10 x :test #'>) x)) (1 2 3) (1 2 3)) (deftest pushnew.18 (let ((x '(1 2 3))) (values (pushnew 10 x :test-not #'>) x)) (10 1 2 3) (10 1 2 3)) (deftest pushnew.19 (let ((x '(1 2 3))) (values (pushnew 10 x :test-not #'<=) x)) (1 2 3) (1 2 3)) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest pushnew.20 (macrolet ((%m (z) z)) (let ((x nil)) (values (pushnew (expand-in-current-env (%m 1)) x) x))) (1) (1)) (deftest pushnew.21 (macrolet ((%m (z) z)) (let ((x nil)) (values (pushnew 1 (expand-in-current-env (%m x))) x))) (1) (1)) (deftest pushnew.22 (macrolet ((%m (z) z)) (let ((x '(a b))) (values (pushnew 1 x :test (expand-in-current-env (%m #'eql))) x))) (1 a b) (1 a b)) (deftest pushnew.23 (macrolet ((%m (z) z)) (let ((x '(1))) (values (pushnew 1 x :test-not (expand-in-current-env (%m #'eql))) x))) (1 1) (1 1)) (deftest pushnew.24 (macrolet ((%m (z) z)) (let ((x '(3))) (values (pushnew 1 x :key (expand-in-current-env (%m #'evenp))) x))) (3) (3)) (defharmless pushnew.test-and-test-not.1 (let ((x '(b c))) (pushnew 'a x :test #'eql :test-not #'eql))) (defharmless pushnew.test-and-test-not.2 (let ((x '(b c))) (pushnew 'a x :test-not #'eql :test #'eql))) (deftest pushnew.order.1 (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 pushnew.order.3 (let ((x '(a b c))) (values (pushnew (progn (setq x '(d e)) 'z) x) x)) (z d e) (z d e)) (deftest pushnew.error.1 (signals-error (let ((x '(a b))) (pushnew 'c x :test #'identity)) program-error) t) (deftest pushnew.error.2 (signals-error (let ((x '(a b))) (pushnew 'c x :test-not #'identity)) program-error) t) (deftest pushnew.error.3 (signals-error (let ((x '(a b))) (pushnew 'c x :key #'cons)) program-error) t) (def-macro-test pushnew.error.4 (pushnew x y)) gcl27-2.7.0/ansi-tests/random-aux.lsp000066400000000000000000000233631454061450500173360ustar00rootroot00000000000000;-*- 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) (declaim (special +standard-chars+ *cl-symbols-vector*)) (defvar *maximum-random-int-bits* (max 36 (1+ (integer-length most-positive-fixnum)))) (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)) (when (typep total 'ratio) (setf total (coerce total 'double-float))) `(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))))))) (defmacro rselect (cumulative-frequency-array &rest cases) (let ((len (length cases)) (a (gensym "A")) (max (gensym "MAX")) (r (gensym "R")) (p (gensym "P")) (done (gensym "DONE"))) (assert (> len 0)) `(let ((,a ,cumulative-frequency-array)) (assert (eql ,len (length ,a))) (let* ((,max (aref ,a ,(1- len))) (,r (random ,max))) (block ,done ,@(loop for i from 0 for c in cases collect `(let ((,p (aref ,a ,i))) (when (< ,r ,p) (return-from ,done ,c)))) (error "Should not happen!")))))) (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 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 make-random-integer () (let ((r (ash 1 (1+ (random *maximum-random-int-bits*))))) (rcase (6 (- (random r) (floor (/ r 2)))) (1 (- r (random (min 10 r)))) (1 (+ (floor (/ r 2)) (random (min 10 r))))))) (defun make-random-rational () (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*)))) (n (random r))) (assert (>= r 2)) (let ((d (loop for x = (random r) unless (zerop x) do (return x)))) (if (coin) (/ n d) (- (/ n d)))))) (defun make-random-nonnegative-rational () (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*)))) (n (random r))) (assert (>= r 2)) (let ((d (loop for x = (random r) unless (zerop x) do (return x)))) (/ n d)))) (defun make-random-positive-rational () (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*)))) (n (1+ (random r)))) (assert (>= r 2)) (let ((d (loop for x = (random r) unless (zerop x) do (return x)))) (/ n d)))) (defun make-random-bounded-rational (upper-limit lower-inclusive upper-inclusive) (assert (rationalp upper-limit)) (assert (not (minusp upper-limit))) (cond ((= upper-limit 0) 0) ((<= upper-limit 1/1000000) (/ (make-random-bounded-rational (* 1000000 upper-limit) lower-inclusive upper-inclusive) 1000000)) ((>= upper-limit 1000000) (* (random 1000000) (make-random-bounded-rational (/ upper-limit 1000000) lower-inclusive upper-inclusive))) (t (assert (< 1/1000000 upper-limit 1000000)) (let ((x 0)) (loop do (setq x (* upper-limit (rational (random 1.0)))) while (or (and (not lower-inclusive) (zerop x)) (and (not upper-inclusive) (= x upper-limit))) finally (return x)))))) (defun make-random-float () (rcase (1 (random most-positive-short-float)) (1 (random most-positive-single-float)) (1 (random most-positive-double-float)) (1 (random most-positive-long-float)))) (defun make-random-symbol () (rcase (3 (random-from-seq #(a b c d e f g h i j k l m n o p q r s t u v w x y z))) (2 (random-from-seq *cl-symbols-vector*)) (1 (gensym)))) (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-thing (n) (if (<= n 1) (random-leaf) (rcase (1 (apply #'cons (mapcar #'random-thing (random-partition (1- n) 2)))) (1 (apply #'vector (mapcar #'random-thing (random-partition (1- n) (max 10 (1- n)))))) ))) (defparameter *use-random-byte* t) (defparameter *random-readable* nil) (defun make-random-string (size-spec &key simple) (let* ((size (if (eql size-spec '*) (random 30) size-spec)) (use-random-byte nil) (etype 'character) (s (random-case (progn (setf use-random-byte *use-random-byte*) (make-string size :element-type 'character)) (progn (setf use-random-byte *use-random-byte*) (make-array size :element-type 'character :initial-element #\a)) (make-array size :element-type (setf etype (if *random-readable* 'character 'standard-char)) :adjustable (and (not simple) (not *random-readable*) (rcase (3 nil) (1 t))) :fill-pointer (and (not simple) (not *random-readable*) (rcase (3 nil) (1 (random (1+ size))))) :initial-element #\a) (make-array size :element-type (setf etype (if *random-readable* 'character 'base-char)) :adjustable (and (not simple) (not *random-readable*) (rcase (3 nil) (1 t))) :fill-pointer (and (not simple) (not *random-readable*) (rcase (3 nil) (1 (random (1+ size))))) :initial-element #\a)))) (if (coin) (dotimes (i size) (setf (char s i) (elt #(#\a #\b #\A #\B) (random 4)))) (dotimes (i size) (setf (char s i) (or (and (eql etype 'character) use-random-byte (or (code-char (random (min char-code-limit (ash 1 16)))) (code-char (random 256)))) (elt "abcdefghijklmnopqrstuvwyxzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" (random 62)))))) (when (and (not simple) (not *random-readable*) (coin 5)) (let ((len (+ (random (1+ size)) size))) (setq s (make-random-string len)) (setq etype (array-element-type s)) (setq s (make-array size :element-type etype :displaced-to s :displaced-index-offset (random (1+ (- len size))))))) s)) (defun random-leaf () (rcase (1 (let ((k (ash 1 (1+ (random 40))))) (random-from-interval k (- k)))) (1 (random-from-seq +standard-chars+)) (1 (random-real)) (1 (make-random-string (random 20))) (1 (gensym)) (1 (make-symbol (make-random-string (random 20)))) (1 (random-from-seq *cl-symbols-vector*)))) (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)))) (defun random-partition* (n p) "Partition n into p numbers, each >= 0. Return list of numbers." (assert (<= 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)))))))))) (defun random-partition (n p) "Partition n into p numbers, each >= 1 (if possible.)" (cond ((<= n p) (make-list p :initial-element 1)) (t (mapcar #'1+ (random-partition* (- n p) p))))) ;;; Random method combination ;;; Methods in this method combination take a single method qualifier, ;;; which is a positive integer. Each method is invoked ;;; with probability proportional to its qualifier. ;;; ;;; Inside a method, a throw to the symbol FAIL causes ;;; the application to repeat. This enables methods to abort ;;; and retry the random selection process. (defun positive-integer-qualifier-p (qualifiers) (typep qualifiers '(cons (integer 1) null))) (define-method-combination randomized nil ((method-list positive-integer-qualifier-p)) (assert method-list) (let ((clauses (mapcar #'(lambda (method) (let ((weight (car (method-qualifiers method)))) `(,weight (call-method ,method)))) method-list))) `(loop (catch 'fail (return (rcase ,@clauses)))))) gcl27-2.7.0/ansi-tests/random-class-aux.lsp000066400000000000000000000021721454061450500204340ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Oct 10 07:14:30 2004 ;;;; Contains: Aux. functions for random tests on classes (in-package :cl-test) (defun random-class-1-fn (&key (n 10) (rep 1000)) "Randomly break and recreate a linear chain of class definitions" (assert (typep n '(integer 1)) (n) "N is ~A" n) (assert (typep rep 'unsigned-byte) (rep) "REP is ~A" rep) (let ((class-names (make-array n :initial-contents (loop for i from 1 to n collect (make-symbol (format nil "CLASS-NAME-~D" i)))))) (unwind-protect (let ((parents (make-array n :initial-element nil))) ;; Create classes (loop for name across class-names do (eval `(defclass ,name () nil))) (loop for i = (1+ (random (1- n))) for name = (elt class-names i) for parent = (elt parents i) repeat rep do (if parent (progn (setf (elt parents i) nil) (eval `(defclass ,name () nil))) (eval `(defclass ,name (,(setf (elt parents i) (elt class-names (1- i)))) nil ))))) (loop for name across class-names do (setf (find-class name) nil))))) gcl27-2.7.0/ansi-tests/random-class.lsp000066400000000000000000000003101454061450500176310ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Oct 10 07:13:47 2004 ;;;; Contains: Randomized tests on classes (in-package :cl-test) (compile-and-load "random-class-aux.lsp") gcl27-2.7.0/ansi-tests/random-int-form.lsp000066400000000000000000003441431454061450500202760ustar00rootroot00000000000000;-*- 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* *make-random-integer-form-cdf*)) ;;; 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 load-failures (&key (pathname "failures.lsp")) (length (setq $y (with-open-file (s pathname :direction :input) (loop for x = (read s nil) while x collect x))))) (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 *random-special-vars* #(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8* *s9*)) (defparameter *loop-random-int-form-period* 2000) (defmacro cl-handler-bind (&rest args) `(cl:handler-bind ,@args)) (defmacro cl-handler-case (&rest args) `(cl:handler-case ,@args)) (eval-when (:compile-toplevel :load-toplevel :execute) (defun cumulate (vec) (loop for i from 1 below (length vec) do (incf (aref vec i) (aref vec (1- i)))) vec)) (defparameter *default-make-random-integer-form-cdf* (cumulate (copy-seq #(10 5 40 4 5 4 2 2 10 1 1 #-armedbead 1 #-armedbear 1 #-allegro 5 5 5 #-(or gcl ecl armedbear) 2 2 #-(or cmu allegro poplog) 5 4 30 4 20 3 2 2 1 1 5 30 #-poplog 5 #-(or allegro poplog) 10 50 4 4 10 20 10 10 3 20 5 #-(or armedbear) 20 2 2 2)))) (defparameter *make-random-integer-form-cdf* (copy-seq *default-make-random-integer-form-cdf*)) (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro with-random-integer-form-params (&body forms) (let ((len (gensym "LEN")) (vec (gensym "VEC"))) `(let* ((,len (length *default-make-random-integer-form-cdf*)) (,vec (make-array ,len))) (loop for i from 0 below ,len do (setf (aref ,vec i) (1+ (min (random 100) (random 100))))) (setq ,vec (cumulate ,vec)) (let ((*make-random-integer-form-cdf* ,vec)) ,@forms))))) ;;; 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 *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))) (loop for i from 1 to n do (when (= (mod i 100) 0) ;; #+sbcl (print "Do gc...") ;; #+sbcl (sb-ext::gc :full t) ;; #+lispworks-personal-edition (cl-user::normal-gc) (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* nil)) (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) ) (with-random-integer-form-params (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) ) (test-int-form form vars var-types vals-list opt-decls-1 opt-decls-2))) (defun make-random-optimize-settings () (loop for settings = (list* (list 'speed (random 4)) #+sbcl '(sb-c:insert-step-conditions 0) (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 (random-permute 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 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 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 is-zero-rank-integer-array-type (type) "This function was introduced because of a bug in ACL 6.2" ; (subtypep type '(array integer 0)) (and (consp type) (eq (car type) 'array) (cddr type) (or (eq (cadr type) '*) (subtypep (cadr type) 'integer)) (or (eql (caddr type) 0) (null (caddr type))))) (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 0)) (is-zero-rank-integer-array-type type) `(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) (rselect *make-random-integer-form-cdf* ;; flet call (make-random-integer-flet-call-form size) (make-random-aref-form size) ;; Unary ops (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)))) (make-random-integer-unwind-protect-form size) (make-random-integer-mapping-form size) ;; prog1, multiple-value-prog1 (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 (let* ((nforms (random 4)) (sizes (random-partition (1- size) (+ nforms 2))) (args (mapcar #'make-random-integer-form sizes))) `(prog2 ,@args)) `(isqrt (abs ,(make-random-integer-form (- size 2)))) `(the integer ,(make-random-integer-form (1- size))) `(cl:handler-bind nil ,(make-random-integer-form (1- size))) `(restart-bind nil ,(make-random-integer-form (1- size))) #-armedbear `(macrolet () ,(make-random-integer-form (1- size))) #-armedbear `(symbol-macrolet () ,(make-random-integer-form (1- size))) ;; dotimes #-allegro (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 (make-random-loop-form (1- size)) (make-random-count-form size) #-(or gcl ecl armedbear) ;; load-time-value (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 (make-random-integer-eval-form size) #-(or cmu allegro poplog) (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 (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 (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 (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 (let* ((op (random-from-seq #(+ - * logand min max logior values lcm gcd logxor))) (nmax (case op ((* lcm gcd) 4) (values (1- multiple-values-limit)) (t (1+ (random 40))))) (nargs (1+ (min (random nmax) (random nmax)))) (sizes (random-partition (1- size) nargs)) (args (mapcar #'make-random-integer-form sizes))) `(,op ,@args)) ;; expt `(expt ,(make-random-integer-form (1- size)) ,(random 3)) ;; coerce `(coerce ,(make-random-integer-form (1- size)) 'integer) ;; complex (degenerate case) `(complex ,(make-random-integer-form (1- size)) 0) ;; quotient (degenerate cases) `(/ ,(make-random-integer-form (1- size)) 1) `(/ ,(make-random-integer-form (1- size)) -1) ;; tagbody (make-random-tagbody-and-progn size) ;; conditionals (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)) #-poplog (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))) #-(or allegro poplog) (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))) (make-random-integer-binding-form size) ;; progv (make-random-integer-progv-form size) `(let () ,(make-random-integer-form (1- size))) (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)))) (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)))) ;; setq and similar (make-random-integer-setq-form size) (make-random-integer-case-form size) (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)) (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)) (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) (make-random-flet-form size) (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)))))) (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)))))) (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-aref-form (size) (or (when *vars* (let* ((desc (random-var-desc)) (type (var-desc-type desc)) (name (var-desc-name desc))) (cond ((null type) nil) ((subtypep type '(array integer (*))) `(aref ,name (min ,(1- (first (third type))) (max 0 ,(make-random-integer-form (- size 2)))))) ((subtypep type '(array integer (* *))) (destructuring-bind (s1 s2) (random-partition (max 2 (- size 2)) 2) `(aref ,name (min ,(1- (first (third type))) (max 0 ,(make-random-integer-form s1))) (min ,(1- (second (third type))) (max 0 ,(make-random-integer-form s2)))))) (t nil)))) (make-random-integer-form size))) (defun make-random-count-form (size) (destructuring-bind (s1 s2) (random-partition (1- size) 2) (let ((arg1 (make-random-integer-form s1)) (arg2-args (loop repeat s2 collect (make-random-integer)))) (let ((op 'count) (test (random-from-seq #(eql = /= < > <= >=))) (arg2 (rcase (1 (make-array (list s2) :initial-contents arg2-args)) (1 (let* ((mask (1- (ash 1 (1+ (random 32)))))) (make-array (list s2) :initial-contents (mapcar #'(lambda (x) (logand x mask)) arg2-args) :element-type `(integer 0 ,mask)))) (1 `(quote ,arg2-args))))) `(,op ,arg1 ,arg2 ,@(rcase (2 nil) (1 (list :test `(quote ,test))) (1 (list :test-not `(quote ,test))))))))) (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) (find (var-desc-name s) *random-special-vars*)) *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 (find var *random-special-vars*) (setq desc (find var *vars* :key #'var-desc-name))) (var-desc-type desc)) (t (rcase (4 '(integer * *)) (1 (setq e1 `(make-array nil :initial-element ,e1 ,@(rcase (1 nil) (1 '(:adjustable t))))) '(array integer nil)) (1 (let ((size (1+ (random 10)))) (setq e1 `(make-array '(,size):initial-element ,e1 ,@(rcase (1 nil) (1 '(:adjustable t))))) `(array integer (,size)))) #| (1 (let ((size1 (1+ (random 10))) (size2 (1+ (random 10)))) (setq e1 `(make-array '(,size1 ,size2):initial-element ,e1 ,@(rcase (1 nil) (1 '(:adjustable t))))) `(array integer (,size1 ,size2)))) |# (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 random2 (n) (min (random n) (random n))) (defun random-from-seq2 (seq) (elt seq (random2 (length seq)))) (defun make-random-integer-binding-form (size) (destructuring-bind (s1 s2) (random-partition (1- size) 2) (let* ((var (random-from-seq2 (rcase (2 #(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10)) #-ecl (2 *random-special-vars*) ))) (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)))) (3 nil)) ,e2)) (2 `(multiple-value-bind (,var) ,e1 ,e2))))))) (defun make-random-integer-progv-form (size) (let* ((num-vars (random 4)) (possible-vars *random-special-vars*) (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 shiftf)))) (cond ((subtypep '(integer * *) type) (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8)))) (rcase (1 (when (find var *random-special-vars*) (setq op (random-from-seq #(setf shiftf)) var `(symbol-value ',var)))) (1 (setq op 'multiple-value-setq) (setq var (list var))) (5 (setf op (random-from-seq #(setq setf shiftf incf decf))))) `(,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)))) (rcase (1 (when (find var *random-special-vars*) (setq op (random-from-seq #(setf shiftf)) var `(symbol-value ',var)))) (1 (setq op 'multiple-value-setq) (setq var (list var))) (5 nil)) `(,op ,var ,(random-from-interval (1+ (third type)) (second type)))) ((and type (is-zero-rank-integer-array-type type)) ; (subtypep type '(array integer nil)) (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)))) ((and type (subtypep type '(array integer (*)))) (when (eq op 'setq) (setq op (random-from-seq #(setf shiftf)))) (destructuring-bind (s1 s2) (random-partition (max 2 (- size 2)) 2) `(,op (aref ,var (min ,(1- (first (third type))) (max 0 ,(make-random-integer-form s1)))) ,(make-random-integer-form s2)))) ((and type (subtypep type '(array integer (* *)))) (when (eq op 'setq) (setq op (random-from-seq #(setf shiftf)))) (destructuring-bind (s1 s2 s3) (random-partition (max 3 (- size 3)) 3) `(,op (aref ,var (min ,(1- (first (third type))) (max 0 ,(make-random-integer-form s1))) (min ,(1- (second (third type))) (max 0 ,(make-random-integer-form s2)))) ,(make-random-integer-form s3)))) ;; 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))) ) (let* ((sizes (random-partition (1- size) (+ 2 keyarg-n (- maxargs minargs)))) (s1 (car sizes)) (s2 (cadr sizes)) (opt-sizes (cddr sizes))) (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)))) (12 (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 (let* ((nsizes (+ 1 (random 3))) (sizes (random-partition (1- size) nsizes))) `(,(random-from-seq (if (= nsizes 2) #(< <= > >= = /= eql equal) #(< <= > >= = /=))) ,@(mapcar #'make-random-integer-form sizes)))) (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))) #-poplog (1 (destructuring-bind (s1 s2) (random-partition (1- size) 2) `(ldb-test ,(make-random-byte-spec-form s1) ,(make-random-integer-form s2)))) (2 (let ((form (make-random-integer-form (1- size))) (op (random-from-seq #(evenp oddp minusp plusp zerop)))) `(,op ,form))) (2 (destructuring-bind (s1 s2) (random-partition (1- size) 2) (let ((arg1 (make-random-integer-form s1)) (arg2-args (loop repeat s2 collect (make-random-integer)))) (let ((op (random-from-seq #(find position))) (test (random-from-seq #(eql = /= < > <= >=))) (arg2 (rcase (1 (make-array (list s2) :initial-contents arg2-args)) (1 (let* ((mask (1- (ash 1 (1+ (random 32)))))) (make-array (list s2) :initial-contents (mapcar #'(lambda (x) (logand x mask)) arg2-args) :element-type `(integer 0 ,mask)))) (1 `(quote ,arg2-args))))) `(,op ,arg1 ,arg2 ,@(rcase (2 nil) (1 (list :test `(quote ,test))) (1 (list :test-not `(quote ,test))))))))) (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 `(real ,@(make-random-integer-range))) (1 `(rational ,@(make-random-integer-range))) (1 `(rational ,(+ 1/2 (make-random-integer)))) (1 `(rational * ,(+ 1/2 (make-random-integer)))) (1 `(integer ,@(make-random-integer-range))) (1 `(integer ,(make-random-integer))) (1 `(integer * ,(make-random-integer))) (1 'fixnum) (1 'bignum) (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))) (defgeneric make-random-element-of-type (type) (:documentation "Create a random element of a lisp type.")) (defgeneric make-random-element-of-compound-type (type-op type-args) (:documentation "Create a random element of type `(,TYPE-OP ,@TYPE-ARGS)") (:method ((type-op (eql 'or)) type-args) (assert type-args) (make-random-element-of-type (random-from-seq type-args))) (:method ((type-op (eql 'and)) type-args) (assert type-args) (loop for x = (make-random-element-of-type (car type-args)) repeat 100 when (typep x (cons 'and (cdr type-args))) return x finally (error "Cannot generate random element of ~A" (cons type-op type-args)))) (:method ((type-op (eql 'not)) type-args) (assert (eql (length type-args) 1)) (make-random-element-of-type `(and t (not ,(car type-args))))) (:method ((type-op (eql 'integer)) type-args) (let ((lo (let ((lo (car type-args))) (cond ((consp lo) (1+ (car lo))) ((eq lo nil) '*) (t lo)))) (hi (let ((hi (cadr type-args))) (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))))) (:method ((type-op (eql 'rational)) type-args) (let ((type (cons type-op type-args))) (or (let ((r (make-random-element-of-type 'rational))) (and (typep r type) r)) (let ((lo (car type-args)) (hi (cadr type-args)) lo= hi=) (cond ((consp lo) nil) ((member lo '(* nil)) (setq lo nil) (setq lo= nil)) (t (assert (typep lo 'rational)) (setq lo= t))) (cond ((consp hi) nil) ((member hi '(* nil)) (setq hi nil) (setq hi= nil)) (t (assert (typep hi 'rational)) (setq hi= t))) (assert (or (null lo) (null hi) (<= lo hi))) (assert (or (null lo) (null hi) (< lo hi) (and lo= hi=))) (cond ((null lo) (cond ((null hi) (make-random-rational)) (hi= (- hi (make-random-nonnegative-rational))) (t (- hi (make-random-positive-rational))))) ((null hi) (cond (lo= (+ lo (make-random-nonnegative-rational))) (t (+ lo (make-random-positive-rational))))) (t (+ lo (make-random-bounded-rational (- hi lo) lo= hi=)))))))) (:method ((type-op (eql 'ratio)) type-args) (let ((r 0)) (loop do (setq r (make-random-element-of-compound-type 'rational type-args)) while (integerp r)) r)) (:method ((type-op (eql 'real)) type-args) (rcase (1 (let ((lo (and (numberp (car type-args)) (rational (car type-args)))) (hi (and (numberp (cadr type-args)) (rational (cadr type-args))))) (make-random-element-of-compound-type 'rational `(,(or lo '*) ,(or hi '*))))) (1 (make-random-element-of-compound-type 'float `(,(or (car type-args) '*) ,(or (cadr type-args) '*)))))) (:method ((type-op (eql 'float)) type-args) (let* ((new-type-op (random-from-seq #(single-float double-float long-float short-float))) (lo (car type-args)) (hi (cadr type-args)) (most-neg (most-negative-float new-type-op)) (most-pos (most-positive-float new-type-op))) (cond ((or (and (realp lo) (< lo most-neg)) (and (realp hi) (> hi most-pos))) ;; try again (make-random-element-of-compound-type type-op type-args)) (t (when (and (realp lo) (not (typep lo new-type-op))) (cond ((< lo most-neg) (setq lo '*)) (t (setq lo (coerce lo new-type-op))))) (when (and (realp hi) (not (typep hi new-type-op))) (cond ((> hi most-pos) (setq hi '*)) (t (setq hi (coerce hi new-type-op))))) (make-random-element-of-compound-type new-type-op `(,(or lo '*) ,(or hi '*))))))) (:method ((type-op (eql 'short-float)) type-args) (assert (<= (length type-args) 2)) (apply #'make-random-element-of-float-type type-op type-args)) (:method ((type-op (eql 'single-float)) type-args) (assert (<= (length type-args) 2)) (apply #'make-random-element-of-float-type type-op type-args)) (:method ((type-op (eql 'double-float)) type-args) (assert (<= (length type-args) 2)) (apply #'make-random-element-of-float-type type-op type-args)) (:method ((type-op (eql 'long-float)) type-args) (assert (<= (length type-args) 2)) (apply #'make-random-element-of-float-type type-op type-args)) (:method ((type-op (eql 'mod)) type-args) (let ((modulus (second type-args))) (assert (integerp modulus)) (assert (plusp modulus)) (make-random-element-of-compound-type 'integer `(0 (,modulus))))) (:method ((type-op (eql 'unsigned-byte)) type-args) (assert (<= (length type-args) 1)) (if (null type-args) (make-random-element-of-type '(integer 0 *)) (let ((bits (first type-args))) (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))))))))) (:method ((type-op (eql 'signed-byte)) type-args) (assert (<= (length type-args) 1)) (if (null type-args) (make-random-element-of-type 'integer) (let ((bits (car type-args))) (if (eq bits'*) (make-random-element-of-type 'integer) (progn (assert (and (integerp bits) (>= bits 1))) (make-random-element-of-type `(integer ,(- (ash 1 (1- bits))) ,(1- (ash 1 (1- bits)))))))))) (:method ((type-op (eql 'eql)) type-args) (assert (= (length type-args) 1)) (car type-args)) (:method ((type-op (eql 'member)) type-args) (assert type-args) (random-from-seq type-args)) (:method ((type-op (eql 'vector)) type-args) (assert (<= (length type-args) 2)) (let ((etype-spec (if type-args (car type-args) '*)) (size-spec (if (cdr type-args) (cadr type-args) '*))) (make-random-vector etype-spec size-spec))) (:method ((type-op (eql 'aimple-vector)) type-args) (assert (<= (length type-args) 1)) (let ((size-spec (if type-args (car type-args) '*))) (make-random-vector t size-spec :simple t))) (:method ((type-op (eql 'array)) type-args) (assert (<= (length type-args) 2)) (let ((etype-spec (if type-args (car type-args) '*)) (size-spec (if (cdr type-args) (cadr type-args) '*))) (make-random-array etype-spec size-spec))) (:method ((type-op (eql 'simple-array)) type-args) (assert (<= (length type-args) 2)) (let ((etype-spec (if type-args (car type-args) '*)) (size-spec (if (cdr type-args) (cadr type-args) '*))) (make-random-array etype-spec size-spec :simple t))) (:method ((type-op (eql 'string)) type-args) (assert (<= (length type-args) 1)) (let ((size-spec (if type-args (car type-args) '*))) (make-random-string size-spec))) (:method ((type-op (eql 'simple-string)) type-args) (assert (<= (length type-args) 1)) (let ((size-spec (if type-args (car type-args) '*))) (make-random-string size-spec :simple t))) (:method ((type-op (eql 'base-string)) type-args) (assert (<= (length type-args) 1)) (let ((size-spec (if type-args (car type-args) '*))) (make-random-vector 'base-char size-spec))) (:method ((type-op (eql 'simple-base-string)) type-args) (assert (<= (length type-args) 1)) (let ((size-spec (if type-args (car type-args) '*))) (make-random-vector 'base-char size-spec :simple t))) (:method ((type-op (eql 'bit-vector)) type-args) (assert (<= (length type-args) 1)) (let ((size-spec (if type-args (car type-args) '*))) (make-random-vector 'bit size-spec))) (:method ((type-op (eql 'simple-bit-vector)) type-args) (assert (<= (length type-args) 1)) (let ((size-spec (if type-args (car type-args) '*))) (make-random-vector 'bit size-spec :simple t))) (:method ((type-op (eql 'cons)) type-args) (assert (<= (length type-args) 2)) (cons (make-random-element-of-type (if type-args (car type-args) t)) (make-random-element-of-type (if (cdr type-args) (cadr type-args) t)))) (:method ((type-op (eql 'complex)) type-args) (cond ((null type-args) (make-random-element-of-type 'complex)) (t (assert (null (cdr type-args))) (let ((etype (car type-args))) (loop for v1 = (make-random-element-of-type etype) for v2 = (make-random-element-of-type etype) for c = (complex v1 v2) when (typep c (cons 'complex type-args)) return c))))) ) (defmethod make-random-element-of-type ((type cons)) (make-random-element-of-compound-type (car type) (cdr type))) (defun make-random-element-of-float-type (type-op &optional lo hi) (let (lo= hi=) (cond ((consp lo) nil) ((member lo '(* nil)) (setq lo (most-negative-float type-op)) (setq lo= t)) (t (assert (typep lo type-op)) (setq lo= t))) (cond ((consp hi) nil) ((member hi '(* nil)) (setq hi (most-positive-float type-op)) (setq hi= t)) (t (assert (typep hi type-op)) (setq hi= t))) (assert (<= lo hi)) (assert (or (< lo hi) (and lo= hi=))) (let ((limit 100000)) (cond ((or (<= hi 0) (>= lo 0) (and (<= (- limit) hi limit) (<= (- limit) lo limit))) (loop for x = (+ (random (- hi lo)) lo) do (when (or lo= (/= x lo)) (return x)))) (t (rcase (1 (random (min hi (float limit hi)))) (1 (- (random (min (float limit lo) (- lo))))))))))) #| (defmethod make-random-element-of-type ((type cons)) (let ((type-op (first type))) (ecase type-op (or (assert (cdr type)) (make-random-element-of-type (random-from-seq (cdr type)))) (and (assert (cdr type)) (loop for x = (make-random-element-of-type (cadr type)) repeat 100 when (typep x (cons 'and (cddr type))) return x finally (error "Cannot generate random element of ~A" type))) (not (assert (cdr type)) (assert (not (cddr type))) (make-random-element-of-type `(and t ,type))) (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))))) (rational (or (let ((r (make-random-element-of-type 'rational))) (and (typep r type) r)) (let ((lo (cadr type)) (hi (caddr type)) lo= hi=) (cond ((consp lo) nil) ((member lo '(* nil)) (setq lo nil) (setq lo= nil)) (t (assert (typep lo 'rational)) (setq lo= t))) (cond ((consp hi) nil) ((member hi '(* nil)) (setq hi nil) (setq hi= nil)) (t (assert (typep hi 'rational)) (setq hi= t))) (assert (or (null lo) (null hi) (<= lo hi))) (assert (or (null lo) (null hi) (< lo hi) (and lo= hi=))) (cond ((null lo) (cond ((null hi) (make-random-rational)) (hi= (- hi (make-random-nonnegative-rational))) (t (- hi (make-random-positive-rational))))) ((null hi) (cond (lo= (+ lo (make-random-nonnegative-rational))) (t (+ lo (make-random-positive-rational))))) (t (+ lo (make-random-bounded-rational (- hi lo) lo= hi=))))))) (ratio (let ((r 0)) (loop do (setq r (make-random-element-of-type `(rational ,@(cdr type)))) while (integerp r)) r)) (real (rcase (1 (let ((lo (and (numberp (cadr type)) (rational (cadr type)))) (hi (and (numberp (caddr type)) (rational (caddr type))))) (make-random-element-of-type `(rational ,(or lo '*) ,(or hi '*))))) (1 (make-random-element-of-type `(float ,(or (cadr type) '*) ,(or (caddr type) '*)))))) ((float) (let* ((new-type-op (random-from-seq #(single-float double-float long-float short-float))) (lo (cadr type)) (hi (caddr type)) (most-neg (most-negative-float new-type-op)) (most-pos (most-positive-float new-type-op))) (cond ((or (and (realp lo) (< lo most-neg)) (and (realp hi) (> hi most-pos))) ;; try again (make-random-element-of-type type)) (t (when (and (realp lo) (not (typep lo new-type-op))) (cond ((< lo most-neg) (setq lo '*)) (t (setq lo (coerce lo new-type-op))))) (when (and (realp hi) (not (typep hi new-type-op))) (cond ((> hi most-pos) (setq hi '*)) (t (setq hi (coerce hi new-type-op))))) (make-random-element-of-type `(,new-type-op ,(or lo '*) ,(or hi '*))))))) ((single-float double-float long-float short-float) (let ((lo (cadr type)) (hi (caddr type)) lo= hi=) (cond ((consp lo) nil) ((member lo '(* nil)) (setq lo (most-negative-float type-op)) (setq lo= t)) (t (assert (typep lo type-op)) (setq lo= t))) (cond ((consp hi) nil) ((member hi '(* nil)) (setq hi (most-positive-float type-op)) (setq hi= t)) (t (assert (typep hi type-op)) (setq hi= t))) (assert (<= lo hi)) (assert (or (< lo hi) (and lo= hi=))) (let ((limit 100000)) (cond ((or (<= hi 0) (>= lo 0) (and (<= (- limit) hi limit) (<= (- limit) lo limit))) (loop for x = (+ (random (- hi lo)) lo) do (when (or lo= (/= x lo)) (return x)))) (t (rcase (1 (random (min hi (float limit hi)))) (1 (- (random (min (float limit lo) (- 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))))))))) (signed-byte (if (null (cdr type)) (make-random-element-of-type 'integer) (let ((bits (second type))) (if (eq bits'*) (make-random-element-of-type 'integer) (progn (assert (and (integerp bits) (>= bits 1))) (make-random-element-of-type `(integer ,(- (ash 1 (1- bits))) ,(1- (ash 1 (1- bits)))))))))) (eql (assert (= (length type) 2)) (cadr type)) (member (assert (cdr type)) (random-from-seq (cdr type))) ((vector) (let ((etype-spec (if (cdr type) (cadr type) '*)) (size-spec (if (cddr type) (caddr type) '*))) (make-random-vector etype-spec size-spec))) ((simple-vector) (let ((size-spec (if (cdr type) (cadr type) '*))) (make-random-vector t size-spec :simple t))) ((array simple-array) (let ((etype-spec (if (cdr type) (cadr type) '*)) (size-spec (if (cddr type) (caddr type) '*))) (make-random-array etype-spec size-spec :simple (eql (car type) 'simple-array)))) ((string simple-string) (let ((size-spec (if (cdr type) (cadr type) '*))) (make-random-string size-spec :simple (eql (car type) 'simple-string)))) ((base-string simple-base-string) (let ((size-spec (if (cdr type) (cadr type) '*))) (make-random-vector 'base-char size-spec :simple (eql (car type) 'simple-base-string)))) ((bit-vector simple-bit-vector) (let ((size-spec (if (cdr type) (cadr type) '*))) (make-random-vector 'bit size-spec :simple (eql (car type) 'simple-bit-vector)))) ((cons) (cons (make-random-element-of-type (if (cdr type) (cadr type) t)) (make-random-element-of-type (if (cddr type) (caddr type) t)))) ((complex) (cond ((null (cdr type)) (make-random-element-of-type 'complex)) (t (assert (null (cddr type))) (let ((etype (cadr type))) (loop for v1 = (make-random-element-of-type etype) for v2 = (make-random-element-of-type etype) for c = (complex v1 v2) when (typep c type) return c))))) ))) |# (defmethod make-random-element-of-type ((type class)) (make-random-element-of-type (class-name type))) (defmethod make-random-element-of-type ((type (eql 'bit))) (random 2)) (defmethod make-random-element-of-type ((type (eql 'boolean))) (random-from-seq #(nil t))) (defmethod make-random-element-of-type ((type (eql 'symbol))) (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| car))) (defmethod make-random-element-of-type ((type (eql 'keyword))) (random-from-seq #(:a :b :c :d :e :f :g :h :i :j))) (defmethod make-random-element-of-type ((type (eql 'unsigned-byte))) (random-from-interval (1+ (ash 1 (random *maximum-random-int-bits*))) 0)) (defmethod make-random-element-of-type ((type (eql 'signed-byte))) (random-from-interval (1+ (ash 1 (random *maximum-random-int-bits*))) (- (ash 1 (random *maximum-random-int-bits*))))) (defmethod make-random-element-of-type ((type (eql 'rational))) (make-random-rational)) (defmethod make-random-element-of-type ((type (eql 'ratio))) (let ((r 0)) (loop do (setq r (make-random-element-of-type 'rational)) while (integerp r)) r)) (defmethod make-random-element-of-type ((type (eql 'integer))) (let ((x (ash 1 (random *maximum-random-int-bits*)))) (random-from-interval (1+ x) (- x)))) (defmethod make-random-element-of-type ((type (eql 'float))) (make-random-element-of-type (random-from-seq #(short-float single-float double-float long-float)))) (defmethod make-random-element-of-type ((type (eql 'real))) (make-random-element-of-type (random-from-seq #(integer rational float)))) (defmethod make-random-element-of-type ((type (eql 'number))) (make-random-element-of-type (random-from-seq #(integer rational float #-ecl complex)))) (defmethod make-random-element-of-type ((type (eql 'bit-vector))) (make-random-vector 'bit '*)) (defmethod make-random-element-of-type ((type (eql 'simple-bit-vector))) (make-random-vector 'bit '* :simple t)) (defmethod make-random-element-of-type ((type (eql 'vector))) (make-random-vector '* '*)) (defmethod make-random-element-of-type ((type (eql 'simple-vector))) (make-random-vector 't '* :simple t)) (defmethod make-random-element-of-type ((type (eql 'array))) (make-random-array '* '*)) (defmethod make-random-element-of-type ((type (eql 'simple-array))) (make-random-array '* '* :simple t)) (defmethod make-random-element-of-type ((type (eql 'string))) (make-random-string '*)) (defmethod make-random-element-of-type ((type (eql 'simple-string))) (make-random-string '* :simple t)) (defmethod make-random-element-of-type ((type (eql 'base-string))) (make-random-vector 'base-char '*)) (defmethod make-random-element-of-type ((type (eql 'simple-base-string))) (make-random-vector 'base-char '* :simple t)) (defmethod make-random-element-of-type ((type (eql 'character))) (make-random-character)) (defmethod make-random-element-of-type ((type (eql 'extended-char))) (loop for x = (make-random-character) when (typep x 'extended-char) return x)) (defmethod make-random-element-of-type ((type (eql 'null))) nil) (defmethod make-random-element-of-type ((type (eql 'fixnum))) (random-from-interval (1+ most-positive-fixnum) most-negative-fixnum)) (defmethod make-random-element-of-type ((type (eql 'complex))) (make-random-element-of-type '(complex real))) (defmethod make-random-element-of-type ((type (eql 'cons))) (make-random-element-of-type '(cons t t))) (defmethod make-random-element-of-type ((type (eql 'list))) ;; Should modify this to allow non-proper lists? (let ((len (min (random 10) (random 10)))) (loop repeat len collect (make-random-element-of-type t)))) (defmethod make-random-element-of-type ((type (eql 'sequence))) (make-random-element-of-type '(or list vector))) (defmethod make-random-element-of-type ((type (eql 'function))) (rcase (5 (symbol-function (random-from-seq *cl-function-symbols*))) (5 (symbol-function (random-from-seq *cl-accessor-symbols*))) (1 #'(lambda (x) (cons x x))) (1 (eval '#'(lambda (x) (cons x x)))))) (defmethod make-random-element-of-type ((type symbol)) (case type ((single-float short-float double-float long-float) (make-random-element-of-type (list type))) ((base-char standard-char) (random-from-seq +standard-chars+)) ;; Default ((atom t *) (make-random-element-of-type (random-from-seq #(real symbol boolean integer unsigned-byte #-ecl complex character (string 1) (bit-vector 1))))) (t (call-next-method type)) )) (defun make-random-character () (loop when (rcase (3 (random-from-seq +standard-chars+)) (3 (code-char (random (min 256 char-code-limit)))) (1 (code-char (random (min (ash 1 16) char-code-limit)))) (1 (code-char (random (min (ash 1 24) char-code-limit)))) (1 (code-char (random char-code-limit)))) return it)) (defun make-random-array-element-type () ;; Create random types for array elements (let ((bits 40)) (rcase (2 t) (1 'symbol) (1 `(unsigned-byte ,(1+ (random bits)))) (1 `(signed-byte ,(1+ (random bits)))) (1 'character) (1 'base-char) (1 'bit) (1 (random-from-seq #(short-float single-float double-float long-float)))))) (defun make-random-vector (etype-spec size-spec &key simple) (let* ((etype (if (eql etype-spec '*) (make-random-array-element-type) etype-spec)) (size (if (eql size-spec '*) (random (ash 1 (+ 2 (random 8)))) size-spec)) (displaced? (and (not simple) (coin 4))) (displaced-size (+ size (random (max 6 size)))) (displacement (random (1+ (- displaced-size size)))) (adjustable (and (not simple) (coin 3))) (fill-pointer (and (not simple) (rcase (3 nil) (1 t) (1 (random (1+ size))))))) (assert (<= size 1000000)) (if displaced? (let ((displaced-vector (make-array displaced-size :element-type etype :initial-contents (loop repeat displaced-size collect (make-random-element-of-type etype))))) (make-array size :element-type etype :adjustable adjustable :fill-pointer fill-pointer :displaced-to displaced-vector :displaced-index-offset displacement)) (make-array size :element-type etype :initial-contents (loop repeat size collect (make-random-element-of-type etype)) :adjustable adjustable :fill-pointer fill-pointer )))) (defun make-random-array (etype-spec dim-specs &key simple) (when (eql dim-specs '*) (setq dim-specs (random 10))) (when (numberp dim-specs) (setq dim-specs (make-list dim-specs :initial-element '*))) (let* ((etype (if (eql etype-spec '*) t etype-spec)) (rank (length dim-specs)) (dims (loop for dim in dim-specs collect (if (eql dim '*) (1+ (random (ash 1 (floor 9 rank)))) dim)))) (assert (<= (reduce '* dims :initial-value 1) 1000000)) (assert (<= (reduce 'max dims :initial-value 1) 1000000)) (make-array dims :element-type etype :initial-contents (labels ((%init (dims) (if (null dims) (make-random-element-of-type etype) (loop repeat (car dims) collect (%init (cdr dims)))))) (%init dims)) :adjustable (and (not simple) (coin)) ;; Do displacements later ))) (defun most-negative-float (float-type-symbol) (ecase float-type-symbol (short-float most-negative-short-float) (single-float most-negative-single-float) (double-float most-negative-double-float) (long-float most-negative-long-float) (float (min most-negative-short-float most-negative-single-float most-negative-double-float most-negative-long-float)))) (defun most-positive-float (float-type-symbol) (ecase float-type-symbol (short-float most-positive-short-float) (single-float most-positive-single-float) (double-float most-positive-double-float) (long-float most-positive-long-float) (float (max most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float)))) (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 *compile-using-defgeneric* nil "If true and *COMPILE-USING-DEFUN* is false, then build a defgeneric form for the function and compile that.") (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) ((or error serious-condition) #'(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)) (clf (cdr lambda-form))) (prog1 (cond (*compile-using-defun* (fmakunbound opt-defun-name) (eval `(defun ,opt-defun-name ,@clf)) (compile opt-defun-name) (symbol-function opt-defun-name)) (*compile-using-defgeneric* (fmakunbound opt-defun-name) (eval `(defgeneric ,opt-defun-name ,(car clf))) (eval `(defmethod ,opt-defun-name,(mapcar #'(lambda (name) `(,name integer)) (car clf)) ,@(cdr clf))) (compile opt-defun-name) (symbol-function opt-defun-name)) (t (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 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 values) (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))))))) ((expt rationalize rational numberator denominator) (try 0) (mapc try-fn args) (prune-fn form try-fn)) ((coerce) (try 0) (try (car args)) (prune (car args) #'(lambda (form) (try `(coerce ,form ,(cadr 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))) (try arg2.2) (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))) ((incf decf) (try 0) (assert (member (length form) '(2 3))) (try (first args)) (when (> (length args) 1) (try (second args)) (try `(,op ,(first args))) (unless (integerp (second args)) (prune (second args) #'(lambda (form) (try `(,op ,(first args) ,form))))))) ((setq setf shiftf) (try 0) ;; Assumes only one assignment (assert (= (length form) 3)) (try (first args)) (try (second args)) (unless (integerp (second args)) (prune (second args) #'(lambda (form) (try `(,op ,(first args) ,form)))))) ((rotatef) (try 0) (mapc try-fn (cdr 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 (and (listp (car case)) (> (length (car case)) 1)) ;; try removing constants (loop for i below (length (car case)) do (funcall try-fn `((,@(subseq (car case) 0 i) ,@(subseq (car case) (1+ i))) ,@(cdr case))))) (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)) ) (when (> body-len 1) (funcall try-fn `(,op ,binding-list ,@(cdr body)))) ;; 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)))) |# (when (>= len 1) (let ((val-form (cadar binding-list))) (when (consp val-form) (case (car val-form) ((make-array) (let ((init (getf (cddr val-form) :initial-element))) (when init (funcall try-fn init)))) ((cons) (funcall try-fn (cadr val-form)) (funcall try-fn (caddr 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)))) ;; Prune off unused variable (when (and binding-list (not (rest binding-list)) (let ((name (caar binding-list))) (and (symbolp name) (not (find-if-subtree #'(lambda (x) (eq x name)) body))))) (funcall try-fn `(progn ,@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 incf decf) :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)) gcl27-2.7.0/ansi-tests/random-intern.lsp000066400000000000000000000032451454061450500200350ustar00rootroot00000000000000;-*- 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)))) gcl27-2.7.0/ansi-tests/random-state-p.lsp000066400000000000000000000011111454061450500201010ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 6 17:50:04 2003 ;;;; Contains: Tests of RANDOM-STATE-P (in-package :cl-test) (deftest random-state-p.error.1 (signals-error (random-state-p) program-error) t) (deftest random-state-p.error.2 (signals-error (random-state-p nil nil) program-error) t) (deftest random-state-p.1 (check-type-predicate #'random-state-p 'random-state) nil) (deftest random-state-p.2 (notnot-mv (random-state-p *random-state*)) t) (deftest random-state-p.3 (notnot-mv (random-state-p (make-random-state))) t) gcl27-2.7.0/ansi-tests/random-type-prop-tests-01.lsp000066400000000000000000000066411454061450500220560ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 6 20:36:56 2005 ;;;; Contains: Test that invoke the random type prop infrastructure, part 1 (in-package :cl-test) (def-type-prop-test special-operator-p 'special-operator-p '(symbol) 1) (def-type-prop-test type-of 'type-of '(t) 1) (def-type-prop-test typep.1 '(lambda (x y) (typep x (type-of y))) '(t t) 2) (def-type-prop-test typep.2 'typep (list t #'(lambda (x) (let ((type (make-random-type-containing x))) `(eql ,type)))) 2) (def-type-prop-test subtypep '(lambda (x y) (subtypep (type-of x) (type-of y))) '(t t) 2) (def-type-prop-test fboundp.1 'fboundp '(symbol) 1) (def-type-prop-test fboundp.2 'fboundp '((cons (eql setf) (cons symbol null))) 1) (def-type-prop-test functionp 'functionp '(t) 1) (def-type-prop-test compiled-function-p 'compiled-function-p '(t) 1) (def-type-prop-test not 'not '(t) 1) (def-type-prop-test eq 'eq (list '(and t (not number) (not character)) #'(lambda (x) (rcase (1 `(eql ,x)) (1 '(and t (not number) (not character)))))) 2) (def-type-prop-test eql.1 'eql '(t t) 2) (def-type-prop-test eql.2 'eql (list t #'(lambda (x) `(eql ,x))) 2) (def-type-prop-test equal.1 'equal '(t t) 2) (def-type-prop-test equal.2 'equal (list t #'(lambda (x) `(eql ,x))) 2) (def-type-prop-test equalp.1 'equalp '(t t) 2) (def-type-prop-test equalp.2 'equalp (list t #'(lambda (x) `(eql ,x))) 2) (def-type-prop-test identity 'identity '(t) 1) (def-type-prop-test complement '(lambda (f y) (funcall (complement f) y)) (list `(eql ,#'symbolp) t) 2) (def-type-prop-test constantly '(lambda (x) (funcall (constantly x))) '(t) 1) (def-type-prop-test and.1 'and '(t) 1) (def-type-prop-test and.2 'and '((or null t) t) 2) (def-type-prop-test and.3 'and '((or null t) (or null t) t) 3) (def-type-prop-test if.1 'if '(boolean t) 2) (def-type-prop-test if.2 'if '(boolean t t) 3) (def-type-prop-test if.3 '(lambda (p q x y z) (if p (if q x y) z)) '(boolean boolean t t t) 5) (def-type-prop-test if.4 '(lambda (p q x y z) (if p x (if q y z))) '(boolean boolean t t t) 5) (def-type-prop-test if.5 '(lambda (p q x y) (if (or p q) x y)) '(boolean boolean t t) 4) (def-type-prop-test if.6 '(lambda (p q x y) (if (and p q) x y)) '(boolean boolean t t) 4) (def-type-prop-test cond.1 '(lambda (p x y) (cond (p x) (t y))) '(boolean t t) 3) (def-type-prop-test cond.2 '(lambda (p x y) (cond (p x) (t y))) '((or null t) t t) 3) (def-type-prop-test or.1 'or '(t) 1) (def-type-prop-test or.2 'or '((or null t) t) 2) (def-type-prop-test or.3 'or '((or null null t) (or null t) t) 3) (def-type-prop-test when 'when '((or null t) t) 2) (def-type-prop-test unless 'unless '((or null t) t) 2) (def-type-prop-test slot-exists-p 'slot-exists-p '(t symbol) 2) (def-type-prop-test find-class 'find-class '(symbol null) 2) (def-type-prop-test class-of 'class-of '(t) 1) (def-type-prop-test find-restart 'find-restart '((and symbol (not null))) 1) (def-type-prop-test symbolp 'symbolp '(t) 1) (def-type-prop-test keywordp 'keywordp '(t) 1) (def-type-prop-test make-symbol 'make-symbol '(string) 1 :test #'(lambda (x y) (string= (symbol-name x) (symbol-name y)))) (def-type-prop-test symbol-name 'symbol-name '(symbol) 1) (def-type-prop-test symbol-package 'symbol-package '(symbol) 1) (def-type-prop-test boundp 'boundp '(symbol) 1) (def-type-prop-test find-symbol 'find-symbol '(string) 1) (def-type-prop-test find-package 'find-package '((or string symbol character)) 1) gcl27-2.7.0/ansi-tests/random-type-prop-tests-02.lsp000066400000000000000000000130351454061450500220520ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 6 20:37:57 2005 ;;;; Contains: Tests that invoke the random type prop infrastructure, part 2 (in-package :cl-test) (def-type-prop-test =.1 '= '(number number) 2) (def-type-prop-test =.2 '= '(number number number) 3) (def-type-prop-test =.3 '= nil 4 :maxargs 10 :rest-type 'number) (def-type-prop-test =.4 '= '(integer integer) 2) (def-type-prop-test =.5 '= (list 'number #'(lambda (x) (if (coin) 'number `(eql ,x)))) 2) (def-type-prop-test =.6 '= (list 'number 'number #'(lambda (x y) (rcase (2 'number) (1 `(eql ,x)) (1 `(eql ,y))))) 3) (def-type-prop-test /=.1 '/= '(number number) 2) (def-type-prop-test /=.2 '/= '(number number number) 3) (def-type-prop-test /=.3 '/= nil 4 :maxargs 10 :rest-type 'number) (def-type-prop-test /=.4 '/= '(integer integer) 2) (def-type-prop-test /=.5 '/= (list 'number #'(lambda (x) (if (coin) 'number `(eql ,x)))) 2) (def-type-prop-test /=.6 '/= (list 'number 'number #'(lambda (x y) (rcase (2 'number) (1 `(eql ,x)) (1 `(eql ,y))))) 3) (def-type-prop-test <.1 '< '(real real) 2) (def-type-prop-test <.2 '< '(real real real) 3) (def-type-prop-test <.3 '< nil 4 :maxargs 10 :rest-type 'real) (def-type-prop-test <.4 '< '(integer integer) 2) (def-type-prop-test <.5 '< (list 'real #'(lambda (x) (if (coin) 'real `(eql ,x)))) 2) (def-type-prop-test <.6 '< (list 'real 'real #'(lambda (x y) (rcase (2 'real) (1 `(eql ,x)) (1 `(eql ,y))))) 3) (def-type-prop-test >.1 '> '(real real) 2) (def-type-prop-test >.2 '> '(real real real) 3) (def-type-prop-test >.3 '> nil 4 :maxargs 10 :rest-type 'real) (def-type-prop-test >.4 '> '(integer integer) 2) (def-type-prop-test >.5 '> (list 'real #'(lambda (x) (if (coin) 'real `(eql ,x)))) 2) (def-type-prop-test >.6 '> (list 'real 'real #'(lambda (x y) (rcase (2 'real) (1 `(eql ,x)) (1 `(eql ,y))))) 3) (def-type-prop-test <=.1 '<= '(real real) 2) (def-type-prop-test <=.2 '<= '(real real real) 3) (def-type-prop-test <=.3 '<= nil 4 :maxargs 10 :rest-type 'real) (def-type-prop-test <=.4 '<= '(integer integer) 2) (def-type-prop-test <=.5 '<= (list 'real #'(lambda (x) (if (coin) 'real `(eql ,x)))) 2) (def-type-prop-test <=.6 '<= (list 'real 'real #'(lambda (x y) (rcase (2 'real) (1 `(eql ,x)) (1 `(eql ,y))))) 3) (def-type-prop-test >=.1 '>= '(real real) 2) (def-type-prop-test >=.2 '>= '(real real real) 3) (def-type-prop-test >=.3 '>= nil 4 :maxargs 10 :rest-type 'real) (def-type-prop-test >=.4 '>= '(integer integer) 2) (def-type-prop-test >=.5 '>= (list 'real #'(lambda (x) (if (coin) 'real `(eql ,x)))) 2) (def-type-prop-test >=.6 '>= (list 'real 'real #'(lambda (x y) (rcase (2 'real) (1 `(eql ,x)) (1 `(eql ,y))))) 3) (def-type-prop-test min.1 'min nil 2 :maxargs 6 :rest-type 'integer) (def-type-prop-test min.2 'min nil 2 :maxargs 6 :rest-type 'rational) (def-type-prop-test min.3 'min nil 2 :maxargs 6 :rest-type 'real) (def-type-prop-test max.1 'max nil 2 :maxargs 6 :rest-type 'integer) (def-type-prop-test max.2 'max nil 2 :maxargs 6 :rest-type 'rational) (def-type-prop-test max.3 'max nil 2 :maxargs 6 :rest-type 'real) (def-type-prop-test minusp 'minusp '(real) 1) (def-type-prop-test plusp 'plusp '(real) 1) (def-type-prop-test zerop 'zerop '(number) 1) (def-type-prop-test floor.1 'floor '(real) 1) (def-type-prop-test floor.2 'floor '(real (and integer (not (satisfies zerop)))) 2) (def-type-prop-test floor.3 'floor '(real (and real (not (satisfies zerop)))) 2) (def-type-prop-test ffloor.1 'ffloor '(real) 1) (def-type-prop-test ffloor.2 'ffloor '(real (and integer (not (satisfies zerop)))) 2) (def-type-prop-test ffloor.3 'ffloor '(real (and real (not (satisfies zerop)))) 2) (def-type-prop-test ceiling.1 'ceiling '(real) 1) (def-type-prop-test ceiling.2 'ceiling '(real (and integer (not (satisfies zerop)))) 2) (def-type-prop-test ceiling.3 'ceiling '(real (and real (not (satisfies zerop)))) 2) (def-type-prop-test fceiling.1 'fceiling '(real) 1) (def-type-prop-test fceiling.2 'fceiling '(real (and integer (not (satisfies zerop)))) 2) (def-type-prop-test fceiling.3 'fceiling '(real (and real (not (satisfies zerop)))) 2) (def-type-prop-test truncate.1 'truncate '(real) 1) (def-type-prop-test truncate.2 'truncate '(real (and integer (not (satisfies zerop)))) 2) (def-type-prop-test truncate.3 'truncate '(real (and real (not (satisfies zerop)))) 2) (def-type-prop-test ftruncate.1 'ftruncate '(real) 1) (def-type-prop-test ftruncate.2 'ftruncate '(real (and integer (not (satisfies zerop)))) 2) (def-type-prop-test ftruncate.3 'ftruncate '(real (and real (not (satisfies zerop)))) 2) (def-type-prop-test round.1 'round '(real) 1) (def-type-prop-test round.2 'round '(real (and integer (not (satisfies zerop)))) 2) (def-type-prop-test round.3 'round '(real (and real (not (satisfies zerop)))) 2) (def-type-prop-test fround.1 'fround '(real) 1) (def-type-prop-test fround.2 'fround '(real (and integer (not (satisfies zerop)))) 2) (def-type-prop-test fround.3 'fround '(real (and real (not (satisfies zerop)))) 2) gcl27-2.7.0/ansi-tests/random-type-prop-tests-03.lsp000066400000000000000000000200001454061450500220410ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 6 20:39:10 2005 ;;;; Contains: Tests that invoke the random type prop infrastructure, part 3 (in-package :cl-test) ;;; trig, hyperbolic functions here ;;; WARNING -- these tests may cause floating point overflow/underflow ;;; Ignore those failures (def-type-prop-test *.1 '* '(integer integer) 2) (def-type-prop-test *.2 '* nil 1 :rest-type 'integer :maxargs 4) (def-type-prop-test *.3 '* nil 2 :rest-type 'integer :maxargs 10) (def-type-prop-test *.4 '* '(real real) 2 :test #'approx=) (def-type-prop-test *.5 '* '(number number) 2 :test #'approx=) (def-type-prop-test \+.1 '+ '(integer integer) 2) (def-type-prop-test \+.2 '+ nil 1 :rest-type 'integer :maxargs 4) (def-type-prop-test \+.3 '+ nil 2 :rest-type 'integer :maxargs 10) (def-type-prop-test \+.4 '+ '(real real) 2 :test #'approx=) (def-type-prop-test \+.5 '+ '(number number) 2 :test #'approx=) (def-type-prop-test \-.1 '- '(integer integer) 2) (def-type-prop-test \-.2 '- nil 1 :rest-type 'integer :maxargs 4) (def-type-prop-test \-.3 '- nil 2 :rest-type 'integer :maxargs 10) (def-type-prop-test \-.4 '- '(real real) 2 :test #'approx=) (def-type-prop-test \-.5 '- '(number number) 2 :test #'approx=) (def-type-prop-test \-.6 '- '(number) 1) ;;; WARNING -- these tests may cause floating point overflow/underflow ;;; Ignore those failures (def-type-prop-test /.1 '/ '((and integer (not (satisfies zerop)))) 1) (def-type-prop-test /.2 '/ '((and rational (not (satisfies zerop)))) 1) (def-type-prop-test /.3 '/ '((and real (not (satisfies zerop)))) 1 :ignore 'arithmetic-error) (def-type-prop-test /.4 '/ '((and complex (not (satisfies zerop)))) 1 :ignore 'arithmetic-error) (def-type-prop-test /.5 '/ '(integer) 2 :maxargs 6 :rest-type '(and integer (not (satisfies zerop)))) (def-type-prop-test /.6 '/ '(rational) 2 :maxargs 6 :rest-type '(and rational (not (satisfies zerop)))) (def-type-prop-test /.7 '/ '(real) 2 :maxargs 6 :rest-type '(and real (not (satisfies zerop))) :test #'approx= :ignore 'arithmetic-error) (def-type-prop-test /.8 '/ '(number) 2 :maxargs 6 :rest-type '(and number (not (satisfies zerop))) :test #'approx= :ignore 'arithmetic-error) (def-type-prop-test 1+.1 '1+ '(integer) 1) (def-type-prop-test 1+.2 '1+ '(rational) 1) (def-type-prop-test 1+.3 '1+ '(real) 1) (def-type-prop-test 1+.4 '1+ '(number) 1) (def-type-prop-test 1-.1 '1- '(integer) 1) (def-type-prop-test 1-.2 '1- '(rational) 1) (def-type-prop-test 1-.3 '1- '(real) 1) (def-type-prop-test 1-.4 '1- '(number) 1) (def-type-prop-test abs.1 'abs '(integer) 1) (def-type-prop-test abs.2 'abs '(rational) 1) (def-type-prop-test abs.3 'abs '(real) 1) (def-type-prop-test abs.4 'abs '(number) 1) (def-type-prop-test evenp 'evenp '(integer) 1) (def-type-prop-test oddp 'oddp '(integer) 1) ;;; exp, expt here (def-type-prop-test gcd 'gcd nil 1 :maxargs 6 :rest-type 'integer) (def-type-prop-test lcm 'lcm nil 1 :maxargs 6 :rest-type 'integer) (def-type-prop-test log.1 'log '((and real (not (satisfies zerop)))) 1 :test #'approx=) (def-type-prop-test log.2 'log '((and number (not (satisfies zerop)))) 1 :test #'approx=) (def-type-prop-test mod.1 'mod '(integer (and integer (not (satisfies zerop)))) 2) (def-type-prop-test mod.2 'mod '(real (and real (not (satisfies zerop)))) 2 :test #'approx=) (def-type-prop-test rem.1 'rem '(integer (and integer (not (satisfies zerop)))) 2) (def-type-prop-test rem.2 'rem '(real (and real (not (satisfies zerop)))) 2 :test #'approx=) (def-type-prop-test signum.1 'signum '(integer) 1) (def-type-prop-test signum.2 'signum '(rational) 1) (def-type-prop-test signum.3 'signum '(real) 1) (def-type-prop-test signum.4 'signum '(number) 1) (def-type-prop-test sqrt.1 'sqrt '(integer) 1 :test #'approx=) (def-type-prop-test sqrt.2 'sqrt '(rational) 1 :test #'approx=) (def-type-prop-test sqrt.3 'sqrt '(real) 1 :test #'approx=) (def-type-prop-test sqrt.4 'sqrt '(number) 1 :test #'approx=) (def-type-prop-test isqrt 'isqrt '((integer 0)) 1) (def-type-prop-test numberp 'numberp '(t) 1) (def-type-prop-test complex.1 'complex '(integer) 1) (def-type-prop-test complex.2 'complex '(rational) 1) (def-type-prop-test complex.3 'complex '(real) 1) (def-type-prop-test complex.4 'complex '(rational rational) 2) (def-type-prop-test complex.5 'complex '(real real) 2) (def-type-prop-test complexp 'complexp '(t) 1) (def-type-prop-test conjugate 'conjugate '(number) 1) (def-type-prop-test phase.1 'phase '(real) 1) (def-type-prop-test phase.2 'phase '(number) 1 :test #'approx=) (def-type-prop-test realpart.1 'realpart '(real) 1) (def-type-prop-test realpart.2 'realpart '(number) 1) (def-type-prop-test imagpart.1 'imagpart '(real) 1) (def-type-prop-test imagpart.2 'imagpart '(number) 1) (def-type-prop-test realp 'realp '(t) 1) (def-type-prop-test numerator 'numerator '(rational) 1) (def-type-prop-test denominator 'denominator '(rational) 1) (def-type-prop-test rational 'rational '(real) 1) (def-type-prop-test rationalize 'rationalize '(real) 1) (def-type-prop-test rationalp 'rationalp '(t) 1) (def-type-prop-test ash.1 'ash '(integer (integer -32 32)) 2) (def-type-prop-test ash.2 'ash '(integer (integer -100 100)) 2) (def-type-prop-test integer-length 'integer-length '(integer) 1) (def-type-prop-test integerp 'integerp '(t) 1) (def-type-prop-test logand.1 'logand '(integer integer) 2) (def-type-prop-test logand.2 'logand nil 2 :rest-type 'integer :maxargs 6) (def-type-prop-test logandc1 'logandc1 '(integer integer) 2) (def-type-prop-test logandc2 'logandc2 '(integer integer) 2) (def-type-prop-test lognand 'lognand '(integer integer) 2) (def-type-prop-test lognor 'lognor '(integer integer) 2) (def-type-prop-test logeqv.1 'logeqv '(integer integer) 2) (def-type-prop-test logeqv.2 'logeqv nil 2 :rest-type 'integer :maxargs 6) (def-type-prop-test logior.1 'logior '(integer integer) 2) (def-type-prop-test logior.2 'logior nil 2 :rest-type 'integer :maxargs 6) (def-type-prop-test logxor.1 'logxor '(integer integer) 2) (def-type-prop-test logxor.2 'logxor nil 2 :rest-type 'integer :maxargs 6) (def-type-prop-test logorc1 'logorc1 '(integer integer) 2) (def-type-prop-test logorc2 'logorc2 '(integer integer) 2) (def-type-prop-test lognot 'lognot '(integer) 1) (def-type-prop-test logbitp.1 'logbitp '((integer 0 32) integer) 2) (def-type-prop-test logbitp.2 'logbitp '((integer 0 100) integer) 2) ; (def-type-prop-test logbitp.3 'logbitp '((integer 0) integer) 2) (def-type-prop-test logcount 'logcount '(integer) 1) (def-type-prop-test logtest 'logtest '(integer integer) 2) (def-type-prop-test decode-float.1 'decode-float '(float) 1) (def-type-prop-test decode-float.2 '(lambda (x) (nth-value 1 (decode-float x))) '(float) 1) (def-type-prop-test decode-float.3 '(lambda (x) (nth-value 2 (decode-float x))) '(float) 1) (def-type-prop-test float-radix 'float-radix '(float) 1) (def-type-prop-test scale-float 'scale-float '(float (integer -30 30)) 2 :ignore 'arithmetic-error :test #'approx=) (def-type-prop-test float-sign.1 'float-sign '(float) 1) (def-type-prop-test float-sign.2 'float-sign '(float float) 2) (def-type-prop-test float-digits 'float-digits '(float) 1) (def-type-prop-test float-precision 'float-precision '(float) 1) (def-type-prop-test integer-decode-float.1 'integer-decode-float '(float) 1) (def-type-prop-test integer-decode-float.2 '(lambda (x) (nth-value 1 (integer-decode-float x))) '(float) 1) (def-type-prop-test integer-decode-float.3 '(lambda (x) (nth-value 2 (integer-decode-float x))) '(float) 1) (def-type-prop-test float.1 'float '(real) 1) (def-type-prop-test float.2 'float '(real float) 2) (def-type-prop-test floatp 'floatp '(t) 1) (defun has-nonzero-length (x) (> (length x) 0)) (def-type-prop-test parse-integer.1 'parse-integer '((and (vector (member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) (satisfies has-nonzero-length))) 1) (def-type-prop-test parse-integer.2 'parse-integer `((and (vector (member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) (satisfies has-nonzero-length)) (eql :start) ,#'(lambda (x &rest rest) (declare (ignore rest)) `(integer 0 (,(length x))))) 3) (def-type-prop-test sxhash 'sxhash '(t) 1) gcl27-2.7.0/ansi-tests/random-type-prop-tests-04.lsp000066400000000000000000000146761454061450500220700ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 6 21:44:41 2005 ;;;; Contains: Test that invoke the random type prop infrastructure, part 4 (in-package :cl-test) (defun char-or-same (c &rest args) (declare (ignore args)) (if (coin) `(eql ,c) 'character)) (eval-when (:load-toplevel :execute) (compile 'char-or-same)) (def-type-prop-test char=.1 'char= nil 2 :rest-type 'base-char :maxargs 5) (def-type-prop-test char=.2 'char= '(character character) 2) (def-type-prop-test char=.3 'char= (list 'character #'char-or-same) 2) (def-type-prop-test char=.4 'char= (list 'character #'char-or-same #'char-or-same) 3) (def-type-prop-test char=.5 'char= '(character) 3 :rest-type #'char-or-same :maxargs 6) (def-type-prop-test char/=.1 'char/= nil 2 :rest-type 'base-char :maxargs 5) (def-type-prop-test char/=.2 'char/= '(character character) 2) (def-type-prop-test char/=.3 'char/= (list 'character #'char-or-same) 2) (def-type-prop-test char/=.4 'char/= (list 'character 'character #'char-or-same) 3) (def-type-prop-test char/=.5 'char/= nil 2 :rest-type 'character :maxargs 6) (def-type-prop-test char<=.1 'char<= nil 2 :rest-type 'base-char :maxargs 5) (def-type-prop-test char<=.2 'char<= '(character character) 2) (def-type-prop-test char<=.3 'char<= (list 'character #'char-or-same) 2) (def-type-prop-test char<=.4 'char<= (list 'character #'char-or-same #'char-or-same) 3) (def-type-prop-test char<=.5 'char<= '(character) 3 :rest-type #'char-or-same :maxargs 6) (def-type-prop-test char>=.1 'char>= nil 2 :rest-type 'base-char :maxargs 5) (def-type-prop-test char>=.2 'char>= '(character character) 2) (def-type-prop-test char>=.3 'char>= (list 'character #'char-or-same) 2) (def-type-prop-test char>=.4 'char>= (list 'character #'char-or-same #'char-or-same) 3) (def-type-prop-test char>=.5 'char>= '(character) 3 :rest-type #'char-or-same :maxargs 6) (def-type-prop-test char<.1 'char< nil 2 :rest-type 'base-char :maxargs 5) (def-type-prop-test char<.2 'char< '(character character) 2) (def-type-prop-test char<.3 'char< (list 'character #'char-or-same) 2) (def-type-prop-test char<.4 'char< (list 'character 'character #'char-or-same) 3) (def-type-prop-test char<.5 'char< nil 2 :rest-type 'character :maxargs 6) (def-type-prop-test char>.1 'char> nil 2 :rest-type 'base-char :maxargs 5) (def-type-prop-test char>.2 'char> '(character character) 2) (def-type-prop-test char>.3 'char> (list 'character #'char-or-same) 2) (def-type-prop-test char>.4 'char> (list 'character 'character #'char-or-same) 3) (def-type-prop-test char>.5 'char> nil 2 :rest-type 'character :maxargs 6) (def-type-prop-test char-equal.1 'char-equal nil 2 :rest-type 'base-char :maxargs 5) (def-type-prop-test char-equal.2 'char-equal '(character character) 2) (def-type-prop-test char-equal.3 'char-equal (list 'character #'char-or-same) 2) (def-type-prop-test char-equal.4 'char-equal (list 'character #'char-or-same #'char-or-same) 3) (def-type-prop-test char-equal.5 'char-equal '(character) 3 :rest-type #'char-or-same :maxargs 6) (def-type-prop-test char-not-equal.1 'char-not-equal nil 2 :rest-type 'base-char :maxargs 5) (def-type-prop-test char-not-equal.2 'char-not-equal '(character character) 2) (def-type-prop-test char-not-equal.3 'char-not-equal (list 'character #'char-or-same) 2) (def-type-prop-test char-not-equal.4 'char-not-equal (list 'character 'character #'char-or-same) 3) (def-type-prop-test char-not-equal.5 'char-not-equal nil 2 :rest-type 'character :maxargs 6) (def-type-prop-test char-not-greaterp.1 'char-not-greaterp nil 2 :rest-type 'base-char :maxargs 5) (def-type-prop-test char-not-greaterp.2 'char-not-greaterp '(character character) 2) (def-type-prop-test char-not-greaterp.3 'char-not-greaterp (list 'character #'char-or-same) 2) (def-type-prop-test char-not-greaterp.4 'char-not-greaterp (list 'character #'char-or-same #'char-or-same) 3) (def-type-prop-test char-not-greaterp.5 'char-not-greaterp '(character) 3 :rest-type #'char-or-same :maxargs 6) (def-type-prop-test char-not-lessp.1 'char-not-lessp nil 2 :rest-type 'base-char :maxargs 5) (def-type-prop-test char-not-lessp.2 'char-not-lessp '(character character) 2) (def-type-prop-test char-not-lessp.3 'char-not-lessp (list 'character #'char-or-same) 2) (def-type-prop-test char-not-lessp.4 'char-not-lessp (list 'character #'char-or-same #'char-or-same) 3) (def-type-prop-test char-not-lessp.5 'char-not-lessp '(character) 3 :rest-type #'char-or-same :maxargs 6) (def-type-prop-test char-lessp.1 'char-lessp nil 2 :rest-type 'base-char :maxargs 5) (def-type-prop-test char-lessp.2 'char-lessp '(character character) 2) (def-type-prop-test char-lessp.3 'char-lessp (list 'character #'char-or-same) 2) (def-type-prop-test char-lessp.4 'char-lessp (list 'character 'character #'char-or-same) 3) (def-type-prop-test char-lessp.5 'char-lessp nil 2 :rest-type 'character :maxargs 6) (def-type-prop-test char-greaterp.1 'char-greaterp nil 2 :rest-type 'base-char :maxargs 5) (def-type-prop-test char-greaterp.2 'char-greaterp '(character character) 2) (def-type-prop-test char-greaterp.3 'char-greaterp (list 'character #'char-or-same) 2) (def-type-prop-test char-greaterp.4 'char-greaterp (list 'character 'character #'char-or-same) 3) (def-type-prop-test char-greaterp.5 'char-greaterp nil 2 :rest-type 'character :maxargs 6) (defun length1-p (seq) (= (length seq) 1)) (def-type-prop-test character 'character '((or character (and (string 1) (satisfies length1-p)))) 1) (def-type-prop-test characterp 'characterp '(t) 1) (def-type-prop-test alpha-char-p 'alpha-char-p '(character) 1) (def-type-prop-test alphanumericp 'alphanumericp '(character) 1) (def-type-prop-test digit-char 'digit-char '((or (integer 0 36) (integer 0)) (integer 2 36)) 1 :maxargs 2) (def-type-prop-test digit-char-p 'digit-char-p '(character) 1) (def-type-prop-test graphic-char-p 'graphic-char-p '(character) 1) (def-type-prop-test standard-char-p 'standard-char-p '(character) 1) (def-type-prop-test char-upcase 'char-upcase '(character) 1) (def-type-prop-test char-downcase 'char-downcase '(character) 1) (def-type-prop-test upper-case-p 'upper-case-p '(character) 1) (def-type-prop-test lower-case-p 'lower-case-p '(character) 1) (def-type-prop-test both-case-p 'both-case-p '(character) 1) (def-type-prop-test char-code 'char-code '(character) 1) (def-type-prop-test char-int 'char-int '(character) 1) (def-type-prop-test code-char 'code-char '((integer 0 #.char-code-limit)) 1) (def-type-prop-test char-name 'char-name '(character) 1) (def-type-prop-test name-char 'name-char '(string) 1) gcl27-2.7.0/ansi-tests/random-type-prop-tests-05.lsp000066400000000000000000000654431454061450500220670ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Mar 8 20:31:08 2005 ;;;; Contains: Random type prop tests, part 5 (Cons) (in-package :cl-test) (def-type-prop-test list.1 'list nil 1 :rest-type 't :maxargs 10) (def-type-prop-test list.2 '(lambda (x) (car (list x))) '(t) 1) (def-type-prop-test list.3 '(lambda (x y) (cdr (list x y))) '(t t) 2) (def-type-prop-test list.4 '(lambda (x y z) (cadr (list x y z))) '(t t t) 3) (def-type-prop-test list.5 '(lambda (x) (let ((z (list x))) (declare (dynamic-extent z)) (car z))) '(t) 1) (def-type-prop-test list* 'list* () 1 :rest-type t :maxargs 10) (def-type-prop-test null 'null '(t) 1) (def-type-prop-test cons.1 'cons '(t t) 2) (def-type-prop-test cons.2 '(lambda (x y) (car (cons y x))) '(t t) 2) (def-type-prop-test cons.3 '(lambda (x y) (cdr (cons x y))) '(t t) 2) (def-type-prop-test consp 'consp '(t) 1) (def-type-prop-test atom 'atom '(t) 1) (def-type-prop-test rplaca 'rplaca '(cons t) 2 :replicate '(t nil)) (def-type-prop-test rplacd 'rplacd '(cons t) 2 :replicate '(t nil)) (def-type-prop-test car 'car '((cons t t)) 1) (def-type-prop-test first 'first '((cons t t)) 1) (def-type-prop-test cdr 'cdr '((cons t t)) 1) (def-type-prop-test rest 'rest '((cons t t)) 1) (def-type-prop-test caar 'caar '((cons (cons t t) t)) 1) (def-type-prop-test cdar 'cdar '((cons (cons t t) t)) 1) (def-type-prop-test cadr 'cadr '((cons t (cons t t))) 1) (def-type-prop-test second 'second '((cons t (cons t t))) 1) (def-type-prop-test cddr 'cddr '((cons t (cons t t))) 1) (def-type-prop-test caaar 'caaar '((cons (cons (cons t t) t) t)) 1) (def-type-prop-test cdaar 'cdaar '((cons (cons (cons t t) t) t)) 1) (def-type-prop-test cadar 'cadar '((cons (cons t (cons t t)) t)) 1) (def-type-prop-test cddar 'cddar '((cons (cons t (cons t t)) t)) 1) (def-type-prop-test caadr 'caadr '((cons t (cons (cons t t) t))) 1) (def-type-prop-test cdadr 'cdadr '((cons t (cons (cons t t) t))) 1) (def-type-prop-test caddr 'caddr '((cons t (cons t (cons t t)))) 1) (def-type-prop-test third 'third '((cons t (cons t (cons t t)))) 1) (def-type-prop-test cdddr 'cdddr '((cons t (cons t (cons t t)))) 1) (def-type-prop-test caaaar'caaaar '((cons (cons (cons (cons t t) t) t) t)) 1) (def-type-prop-test cdaaar 'cdaaar '((cons (cons (cons (cons t t) t) t) t)) 1) (def-type-prop-test cadaar 'cadaar '((cons (cons (cons t (cons t t)) t) t)) 1) (def-type-prop-test cddaar 'cddaar '((cons (cons (cons t (cons t t)) t) t)) 1) (def-type-prop-test caadar 'caadar '((cons (cons t (cons (cons t t) t)) t)) 1) (def-type-prop-test cdadar 'cdadar '((cons (cons t (cons (cons t t) t)) t)) 1) (def-type-prop-test caddar 'caddar '((cons (cons t (cons t (cons t t))) t)) 1) (def-type-prop-test cdddar 'cdddar '((cons (cons t (cons t (cons t t))) t)) 1) (def-type-prop-test caaadr 'caaadr '((cons t (cons (cons (cons t t) t) t))) 1) (def-type-prop-test cdaadr 'cdaadr '((cons t (cons (cons (cons t t) t) t))) 1) (def-type-prop-test cadadr 'cadadr '((cons t (cons (cons t (cons t t)) t))) 1) (def-type-prop-test cddadr 'cddadr '((cons t (cons (cons t (cons t t)) t))) 1) (def-type-prop-test caaddr 'caaddr '((cons t (cons t (cons (cons t t) t)))) 1) (def-type-prop-test cdaddr 'cdaddr '((cons t (cons t (cons (cons t t) t)))) 1) (def-type-prop-test cadddr 'cadddr '((cons t (cons t (cons t (cons t t))))) 1) (def-type-prop-test fourth 'fourth '((cons t (cons t (cons t (cons t t))))) 1) (def-type-prop-test cddddr 'cddddr '((cons t (cons t (cons t (cons t t))))) 1) (def-type-prop-test fifth 'fifth '((cons t (cons t (cons t (cons t (cons t t)))))) 1) (def-type-prop-test sixth 'sixth '((cons t (cons t (cons t (cons t (cons t (cons t t))))))) 1) (def-type-prop-test seventh 'seventh '((cons t (cons t (cons t (cons t (cons t (cons t (cons t t)))))))) 1) (def-type-prop-test eighth 'eighth '((cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t t))))))))) 1) (def-type-prop-test ninth 'ninth '((cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t t)))))))))) 1) (def-type-prop-test tenth 'tenth '((cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t t))))))))))) 1) (def-type-prop-test pop '(lambda (x) (list (pop x) x)) '((cons t t)) 1) (def-type-prop-test push '(lambda (x y) (list (push x y) x y)) '(t t) 2) (def-type-prop-test copy-tree.1 'copy-tree '((cons t t)) 1) (def-type-prop-test copy-tree.2 'copy-tree '((cons (cons t t) (cons t t))) 1) (def-type-prop-test copy-tree.3 'copy-tree '((cons t (cons (cons t (cons t t)) t))) 1) (def-type-prop-test copy-tree.4 'copy-tree '(list) 1) (def-type-prop-test sublis.1 'sublis '((cons (cons symbol t) null) list) 2) (def-type-prop-test sublis.2 'sublis '((cons (cons (integer 0 7) t) null) list) 2) (def-type-prop-test sublis.3 'sublis '(null list) 2) (def-type-prop-test sublis.4 'sublis `((cons (cons boolean t) null) list (eql :key) (or null (eql not) (eql ,#'not))) 4) (def-type-prop-test sublis.5 'sublis `((cons (cons t t) null) list (eql :test) (or (eql equal) (eql ,#'equal))) 4) (def-type-prop-test sublis.6 'sublis `((cons (cons t t) null) list (eql :test-not) (or (eql eql) (eql ,#'eql))) 4) (def-type-prop-test subst.1 'subst '(t t t) 3) (def-type-prop-test subst.2 'subst '(t t (cons t t)) 3) (def-type-prop-test subst.3 'subst '(t t list) 3) (def-type-prop-test subst.4 'subst '(t t (cons (cons t t) (cons t t))) 3) (def-type-prop-test subst.5 'subst `(boolean t (cons (cons t t) (cons t t)) (eql :key) (or null (eql not) (eql ,#'not))) 5) (def-type-prop-test subst.6 'subst `(t t (cons (cons t t) (cons t t)) (eql :test) (or (eql equal) (eql ,#'equal))) 5) (def-type-prop-test subst.7 'subst `(t t (cons (cons t t) (cons t t)) (eql :test-not) (or (eql equal) (eql ,#'equal))) 5) (def-type-prop-test subst.8 'subst `(t t (cons (cons t t) (cons t t)) (eql :key) (or null (eql not) (eql ,#'not)) (eql :test) (or (eql equal) (eql ,#'equal))) 7) (def-type-prop-test nsubst.1 'nsubst '(t t t) 3 :replicate '(nil nil t)) (def-type-prop-test nsubst.2 'nsubst '(t t (cons t t)) 3 :replicate '(nil nil t)) (def-type-prop-test nsubst.3 'nsubst '(t t list) 3 :replicate '(nil nil t)) (def-type-prop-test nsubst.4 'nsubst '(t t (cons (cons t t) (cons t t))) 3 :replicate '(nil nil t)) (def-type-prop-test nsubst.5 'nsubst `(boolean t (cons (cons t t) (cons t t)) (eql :key) (or null (eql not) (eql ,#'not))) 5 :replicate '(nil nil t nil nil)) (def-type-prop-test nsubst.6 'nsubst `(t t (cons (cons t t) (cons t t)) (eql :test) (or (eql equal) (eql ,#'equal))) 5 :replicate '(nil nil t nil nil)) (def-type-prop-test nsubst.7 'nsubst `(t t (cons (cons t t) (cons t t)) (eql :test-not) (or (eql equal) (eql ,#'equal))) 5 :replicate '(nil nil t nil nil)) (def-type-prop-test nsubst.8 'nsubst `(t t (cons (cons t t) (cons t t)) (eql :key) (or null (eql not) (eql ,#'not)) (eql :test) (or (eql equal) (eql ,#'equal))) 7 :replicate '(nil nil t nil nil nil nil)) (def-type-prop-test subst-if.1 'subst-if `(t (or (eql not) (eql ,#'not)) list) 3) (def-type-prop-test subst-if.2 'subst-if `(t (or (eql not) (eql ,#'not)) (cons (or null t) (or null t))) 3) (def-type-prop-test subst-if.3 'subst-if `(t (eql identity) (cons (cons (cons t t) (cons t t)) (cons (cons t t) (cons t t))) (eql :key) (or null (eql not) (eql ,#'not))) 5) (def-type-prop-test nsubst-if.1 'nsubst-if `(t (or (eql not) (eql ,#'not)) list) 3 :replicate '(nil nil t)) (def-type-prop-test nsubst-if.2 'nsubst-if `(t (or (eql not) (eql ,#'not)) (cons (or null t) (or null t))) 3 :replicate '(nil nil t)) (def-type-prop-test nsubst-if.3 'nsubst-if `(t (eql identity) (cons (cons (cons t t) (cons t t)) (cons (cons t t) (cons t t))) (eql :key) (or null (eql not) (eql ,#'not))) 5 :replicate '(nil nil t nil nil)) (def-type-prop-test subst-if-not.1 'subst-if-not `(t (or (eql not) (eql ,#'not)) list) 3) (def-type-prop-test subst-if-not.2 'subst-if-not `(t (or (eql not) (eql ,#'not)) (cons (or null t) (or null t))) 3) (def-type-prop-test subst-if-not.3 'subst-if-not `(t (eql identity) (cons (cons (cons t t) (cons t t)) (cons (cons t t) (cons t t))) (eql :key) (or null (eql not) (eql ,#'not))) 5) (def-type-prop-test nsubst-if-not.1 'nsubst-if-not `(t (or (eql not) (eql ,#'not)) list) 3 :replicate '(nil nil t)) (def-type-prop-test nsubst-if-not.2 'nsubst-if-not `(t (or (eql not) (eql ,#'not)) (cons (or null t) (or null t))) 3 :replicate '(nil nil t)) (def-type-prop-test nsubst-if-not.3 'nsubst-if-not `(t (eql identity) (cons (cons (cons t t) (cons t t)) (cons (cons t t) (cons t t))) (eql :key) (or null (eql not) (eql ,#'not))) 5 :replicate '(nil nil t nil nil)) (def-type-prop-test tree-equal.1 'tree-equal (list t #'(lambda (x) `(or t (eql ,(copy-tree x))))) 2) (def-type-prop-test tree-equal.2 'tree-equal (list 'list #'(lambda (x) `(or list (eql ,(copy-tree t))))) 2) (def-type-prop-test tree-equal.3 'tree-equal (list '(cons t t) #'(lambda (x) `(or (cons t t) (eql ,(copy-tree x)))) '(eql :test) `(or (eql equal) (eql ,#'equal))) 4) (def-type-prop-test tree-equal.4 'tree-equal (list t #'(lambda (x) `(or t (eql ,(copy-tree x)))) '(eql :test-not) '(eql eql)) 4) (def-type-prop-test copy-list.1 'copy-list '(list) 1) (def-type-prop-test copy-list.2 'copy-list '((cons t t)) 1) (def-type-prop-test copy-list.3 'copy-list '((cons t (cons t (or t (cons t (or t (cons t t))))))) 1) (def-type-prop-test list-length.1 'list-length '(list) 1) (def-type-prop-test list-length.2 'list-length '((cons t list)) 1) (def-type-prop-test listp 'listp '(t) 1) (def-type-prop-test make-list.1 'make-list '((integer 0 100)) 1) (def-type-prop-test make-list.2 '(lambda (x) (length (make-list x))) '((integer 0 100)) 1) (def-type-prop-test make-list.3 'make-list '((integer 0 100) (eql :initial-element) t) 3) (def-type-prop-test nth.1 'nth '((integer 0 12) list) 2) (def-type-prop-test endp.1 'endp '((or null (cons t t))) 1) (def-type-prop-test append.1 'append nil 1 :maxargs 10 :rest-type 'list) (def-type-prop-test append.2 'append '(list t) 2) (def-type-prop-test append.3 'append '(list list t) 3) (def-type-prop-test append.4 'append '(list list list t) 4) (def-type-prop-test nconc.1 'nconc '(list) 1) (def-type-prop-test nconc.2 'nconc '(list list) 2 :replicate '(t nil)) (def-type-prop-test nconc.3 'nconc '(list list list) 3 :replicate '(t t nil)) (def-type-prop-test nconc.4 'nconc '(list list list list) 4 :replicate '(t t t nil)) (def-type-prop-test revappend 'revappend '(list t) 2) (def-type-prop-test nreconc 'nreconc '(list t) 2 :replicate '(t nil)) (def-type-prop-test butlast.1 'butlast '(list) 1) (def-type-prop-test butlast.2 'butlast '(list (integer 0 20)) 2) (def-type-prop-test nbutlast.1 'nbutlast '(list) 1 :replicate '(t)) (def-type-prop-test nbutlast.2 'nbutlast '(list (integer 0 20)) 2 :replicate '(t nil)) (def-type-prop-test last.1 'last '(list) 1) (def-type-prop-test last.2 'last '(list (integer 0 15)) 2) (def-type-prop-test last.3 'last '((cons t (or t (cons t (or t (cons t t)))))) 1) (def-type-prop-test last.4 'last '((cons t (or t (cons t (or t (cons t t))))) (integer 0 5)) 2) (def-type-prop-test ldiff.1 'ldiff '(list t) 2) (def-type-prop-test ldiff.2 'ldiff (list 'list #'(lambda (x) (if (consp x) `(or t (eql ,(nthcdr (random (length x)) x))) t))) 2) (def-type-prop-test tailp.1 'tailp '(t list) 2) (def-type-prop-test tailp.2 'tailp (list t #'(lambda (x) (make-list-type (1+ (random 10)) `(eql ,x)))) 2) (def-type-prop-test nthcdr 'nthcdr '((integer 0 20) list) 2) (def-type-prop-test member.1 'member '(t list) 2) (def-type-prop-test member.2 'member (list t #'(lambda (x) (make-list-type (random 5) `(cons (eql ,x) ,(make-list-type (random 5)))))) 2) (def-type-prop-test member.3 'member `(t list (eql :key) (or (eql not) (eql ,#'not))) 4) (def-type-prop-test member.4 'member `(t list (eql :test) (or (eql equalp) (eql ,#'equalp))) 4) (def-type-prop-test member.5 'member `(t list (eql :test-not) (or (eql eql) (eql ,#'eql))) 4) (def-type-prop-test member.6 'member `(t list (eql :allow-other-keys) (and t (not null)) (eql :foo) t) 6) (def-type-prop-test member-if.1 'member-if `((or (eql symbolp) (eql ,#'symbolp)) list) 2) (def-type-prop-test member-if.2 'member-if (list '(eql zerop) #'(lambda (x) (make-list-type (random 10) 'null '(integer 0 10)))) 2) (def-type-prop-test member-if.3 'member-if (list '(eql zerop) #'(lambda (x) (make-list-type (random 10) 'null '(integer 0 10))) '(eql :key)`(or (eql 1-) (eql ,#'1-))) 4) (def-type-prop-test member-if-not.1 'member-if-not `((or (eql symbolp) (eql ,#'symbolp)) list) 2) (def-type-prop-test member-if-not.2 'member-if-not (list '(eql plusp) #'(lambda (x) (make-list-type (random 10) 'null '(integer 0 10)))) 2) (def-type-prop-test member-if-not.3 'member-if-not (list '(eql plusp) #'(lambda (x) (make-list-type (random 10) 'null '(integer 0 10))) '(eql :key) `(or (eql 1-) (eql ,#'1-))) 4) (def-type-prop-test member-if-not.4 'member-if-not `((eql identity) list (eql :allow-other-keys) (and t (not null)) (member :foo :bar #:xyz) t) 6) (def-type-prop-test mapc.1 'mapc '((eql list)) 2 :rest-type 'list :maxargs 10) (def-type-prop-test mapc.2 'mapc `((eql ,#'values)) 2 :rest-type 'list :maxargs 10) (def-type-prop-test mapcar.1 'mapcar '((eql list)) 2 :rest-type 'list :maxargs 10) (def-type-prop-test mapcar.2 'mapcar `((eql ,#'vector)) 2 :rest-type 'list :maxargs 10) (def-type-prop-test maplist.1 'maplist '((eql list)) 2 :rest-type 'list :maxargs 10) (def-type-prop-test maplist.2 'maplist `((eql ,#'vector)) 2 :rest-type 'list :maxargs 10) (def-type-prop-test mapl.1 'mapl '((eql list)) 2 :rest-type 'list :maxargs 10) (def-type-prop-test mapl.2 'mapl `((eql ,#'vector)) 2 :rest-type 'list :maxargs 10) (def-type-prop-test mapcan.1 'mapcan '((eql list)) 2 :rest-type 'list :maxargs 10) (def-type-prop-test mapcon.1 'mapcon '((eql copy-list) list) 2) (def-type-prop-test acons 'acons (list t t #'(lambda (x y) (make-list-type (random 5) 'null '(or null (cons t t))))) 3) (def-type-prop-test assoc.1 'assoc (list t #'(lambda (x) (make-list-type (random 6) 'null '(or null (cons t t))))) 2) (def-type-prop-test assoc.2 'assoc (list t #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t t) (cons (eql ,x) t))))) 2) (def-type-prop-test assoc.3 'assoc (list t #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t t) (cons (eql ,x) t)))) '(eql :key) `(or (eql not) (eql ,#'not))) 4) (def-type-prop-test assoc.4 'assoc (list 'real #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons real t) (cons (eql ,x) t)))) `(member :test :test-not) `(member <= < = /= > >= ,#'<= ,#'< ,#'= ,#'/= ,#'> ,#'>=)) 4) (def-type-prop-test assoc-if.1 'assoc-if (list `(member identity not symbolp numberp arrayp ,#'identity ,#'not ,#'symbolp ,#'numberp ,#'arrayp) (make-list-type (random 8) 'null '(or null (cons t t)))) 2) (def-type-prop-test assoc-if.2 'assoc-if (list `(member plusp minusp zerop ,#'plusp ,#'minusp ,#'zerop) (make-list-type (random 8) 'null '(or null (cons real t))) '(eql :key) `(member 1+ 1- - abs signum ,#'1+ ,#'1- ,#'- ,#'abs ,#'signum)) 2) (def-type-prop-test assoc-if-not.1 'assoc-if-not (list `(member identity not symbolp numberp arrayp ,#'identity ,#'not ,#'symbolp ,#'numberp ,#'arrayp) (make-list-type (random 8) 'null '(or null (cons t t)))) 2) (def-type-prop-test assoc-if-not.2 'assoc-if-not (list `(member plusp minusp zerop ,#'plusp ,#'minusp ,#'zerop) (make-list-type (random 8) 'null '(or null (cons real t))) '(eql :key) `(member 1+ 1- - abs signum ,#'1+ ,#'1- ,#'- ,#'abs ,#'signum)) 2) (def-type-prop-test copy-alist 'copy-alist (list #'(lambda () (make-list-type (random 10) 'null '(or null (cons t t))))) 1) (def-type-prop-test pairlis.1 'pairlis (list 'list #'(lambda (x) (make-list-type (length x) 'null t))) 2) (def-type-prop-test pairlis.2 'pairlis (list 'list #'(lambda (x) (make-list-type (length x) 'null t)) #'(lambda (x y) (make-list-type (random 6) 'null '(or null (cons t t))))) 3) (def-type-prop-test rassoc.1 'rassoc (list t #'(lambda (x) (make-list-type (random 6) 'null '(or null (cons t t))))) 2) (def-type-prop-test rassoc.2 'rassoc (list t #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t t) (cons t (eql ,x)))))) 2) (def-type-prop-test rassoc.3 'rassoc (list t #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t t) (cons t (eql ,x))))) '(eql :key) `(or (eql not) (eql ,#'not))) 4) (def-type-prop-test rassoc.4 'rassoc (list 'real #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t real) (cons t (eql ,x))))) `(member :test :test-not) `(member <= < = /= > >= ,#'<= ,#'< ,#'= ,#'/= ,#'> ,#'>=)) 4) (def-type-prop-test rassoc-if.1 'rassoc-if (list `(member identity not symbolp numberp arrayp ,#'identity ,#'not ,#'symbolp ,#'numberp ,#'arrayp) (make-list-type (random 8) 'null '(or null (cons t t)))) 2) (def-type-prop-test rassoc-if.2 'rassoc-if (list `(member plusp minusp zerop ,#'plusp ,#'minusp ,#'zerop) (make-list-type (random 8) 'null '(or null (cons t real))) '(eql :key) `(member 1+ 1- - abs signum ,#'1+ ,#'1- ,#'- ,#'abs ,#'signum)) 2) (def-type-prop-test rassoc-if-not.1 'rassoc-if-not (list `(member identity not symbolp numberp arrayp ,#'identity ,#'not ,#'symbolp ,#'numberp ,#'arrayp) (make-list-type (random 8) 'null '(or null (cons t t)))) 2) (def-type-prop-test rassoc-if-not.2 'rassoc-if-not (list `(member plusp minusp zerop ,#'plusp ,#'minusp ,#'zerop) (make-list-type (random 8) 'null '(or null (cons t real))) '(eql :key) `(member 1+ 1- - abs signum ,#'1+ ,#'1- ,#'- ,#'abs ,#'signum)) 2) ;;; We don't use numbers or characters as indicators, since the test is EQ, ;;; which is not well-behaved on these types. (def-type-prop-test get-properties.1 'get-properties (list #'(lambda () (make-list-type (* 2 (random 5)) 'null '(not (or number character)))) 'list) 2) (def-type-prop-test get-properties.2 'get-properties (list #'(lambda () (make-list-type (* 2 (random 5)) 'null '(not (or number character)))) #'(lambda (plist) (let ((len (length plist))) (if (= len 0) '(cons t null) (let ((ind (elt plist (* 2 (random (floor len 2)))))) `(cons (eql ,ind) null)))))) 2) (def-type-prop-test getf.1 'getf (list #'(lambda () (make-list-type (* 2 (random 5)) 'null '(not (or number character)))) t) 2) (def-type-prop-test getf.2 'getf (list #'(lambda () (make-list-type (* 2 (random 5)) 'null '(not (or number character)))) #'(lambda (plist) (let ((len (length plist))) (if (= len 0) t (let ((ind (elt plist (* 2 (random (floor len 2)))))) `(eql ,ind)))))) 2) (def-type-prop-test getf.3 'getf (list #'(lambda () (make-list-type (* 2 (random 5)) 'null '(not (or number character)))) t t) 3) (def-type-prop-test intersection.1 'intersection '(list list) 2 :test #'same-set-p) (def-type-prop-test intersection.2 'intersection '(list list (eql :key) (eql identity)) 4 :test #'same-set-p) (def-type-prop-test intersection.3 'intersection (list #'(lambda () (make-list-type (random 10) 'null 'integer)) #'(lambda (x) (make-list-type (random 10) 'null 'integer)) '(eql :key) `(member 1+ ,#'1+)) 4 :test #'same-set-p) (def-type-prop-test intersection.4 'intersection (list #'(lambda () (make-list-type (random 10) 'null '(cons integer null))) #'(lambda (x) (make-list-type (random 10) 'null '(cons integer null))) '(eql :key) `(member car ,#'car)) 4 :test #'(lambda (x y) (same-set-p x y :key #'car))) (def-type-prop-test intersection.5 'intersection (list #'(lambda () (make-list-type (random 10) 'null '(cons integer null))) #'(lambda (x) (make-list-type (random 10) 'null '(cons integer null))) '(eql :test) `(member equal ,#'equal)) 4 :test #'(lambda (x y) (same-set-p x y :key #'car))) (def-type-prop-test nintersection.1 'nintersection '(list list) 2 :test #'same-set-p :replicate '(t t)) (def-type-prop-test nintersection.2 'nintersection '(list list (eql :key) (eql identity)) 4 :test #'same-set-p :replicate '(t t nil nil)) (def-type-prop-test nintersection.3 'nintersection (list #'(lambda () (make-list-type (random 10) 'null 'integer)) #'(lambda (x) (make-list-type (random 10) 'null 'integer)) '(eql :key) `(member 1+ ,#'1+)) 4 :test #'same-set-p :replicate '(t t nil nil)) (def-type-prop-test nintersection.4 'nintersection (list #'(lambda () (make-list-type (random 10) 'null '(cons integer null))) #'(lambda (x) (make-list-type (random 10) 'null '(cons integer null))) '(eql :key) `(member car ,#'car)) 4 :test #'(lambda (x y) (same-set-p x y :key #'car)) :replicate '(t t nil nil)) (def-type-prop-test nintersection.5 'nintersection (list #'(lambda () (make-list-type (random 10) 'null '(cons integer null))) #'(lambda (x) (make-list-type (random 10) 'null '(cons integer null))) '(eql :test) `(member equal ,#'equal)) 4 :test #'(lambda (x y) (same-set-p x y :key #'car)) :replicate '(t t nil nil)) (def-type-prop-test adjoin.1 'adjoin '(t list) 2) (def-type-prop-test adjoin.2 'adjoin '((integer 0 1) list) 2) (def-type-prop-test adjoin.3 'adjoin `((integer 0 10) (cons number (cons number (cons number null))) (eql :test) (or (eql =) (eql ,#'=))) 4) (def-type-prop-test adjoin.4 'adjoin `(number (cons number (cons number (cons number (cons number null)))) (eql :test-not) (or (eql /=) (eql ,#'/=))) 4) (def-type-prop-test adjoin.5 'adjoin `(number (cons number (cons number (cons number (cons number null)))) (eql :key) (or (member 1+ 1- ,#'1+ ,#'1-))) 4) (def-type-prop-test pushnew.1 '(lambda (x y) (list (pushnew x y) y)) '(t list) 2) (def-type-prop-test pushnew.2 '(lambda (x y) (list (pushnew x y) y)) '((integer 0 1) list) 2) (def-type-prop-test pushnew.3 '(lambda (x y) (list (pushnew x y :test #'=) y)) `((integer 0 10) (cons number (cons number (cons number null)))) 2) (def-type-prop-test pushnew.4 '(lambda (x y) (list (pushnew x y :test-not #'/=) y)) `((integer 0 10) (cons number (cons number (cons number null)))) 2) (def-type-prop-test pushnew.5 '(lambda (x y) (list (pushnew x y :key #'1+) y)) `(number (cons number (cons number (cons number (cons number null))))) 2) (def-type-prop-test set-difference.1 'set-difference '(list list) 2) (def-type-prop-test set-difference.2 'set-difference '((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))) 2) (def-type-prop-test set-difference.3 'set-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (eql :test) (member = ,#'=)) 4) (def-type-prop-test set-difference.4 'set-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (eql :test-not) (member /= ,#'/=)) 4) (def-type-prop-test set-difference.5 'set-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) (eql :key) (member evenp oddp ,#'evenp ,#'oddp)) 4) (def-type-prop-test nset-difference.1 'nset-difference '(list list) 2 :replicate '(t t)) (def-type-prop-test nset-difference.2 'nset-difference '((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))) 2 :replicate '(t t)) (def-type-prop-test nset-difference.3 'nset-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (eql :test) (member = ,#'=)) 4 :replicate '(t t nil nil)) (def-type-prop-test nset-difference.4 'nset-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (eql :test-not) (member /= ,#'/=)) 4 :replicate '(t t nil nil)) (def-type-prop-test nset-difference.5 'nset-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) (eql :key) (member evenp oddp ,#'evenp ,#'oddp)) 4 :replicate '(t t nil nil)) (def-type-prop-test set-exclusive-or.1 'set-exclusive-or '(list list) 2) (def-type-prop-test set-exclusive-or.2 'set-exclusive-or '((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))) 2) (def-type-prop-test set-exclusive-or.3 'set-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (eql :test) (member = ,#'=)) 4) (def-type-prop-test set-exclusive-or.4 'set-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (eql :test-not) (member /= ,#'/=)) 4) (def-type-prop-test set-exclusive-or.5 'set-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) (eql :key) (member evenp oddp ,#'evenp ,#'oddp)) 4) (def-type-prop-test nset-exclusive-or.1 'nset-exclusive-or '(list list) 2 :replicate '(t t)) (def-type-prop-test nset-exclusive-or.2 'nset-exclusive-or '((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))) 2 :replicate '(t t)) (def-type-prop-test nset-exclusive-or.3 'nset-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (eql :test) (member = ,#'=)) 4 :replicate '(t t nil nil)) (def-type-prop-test nset-exclusive-or.4 'nset-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (eql :test-not) (member /= ,#'/=)) 4 :replicate '(t t nil nil)) (def-type-prop-test nset-exclusive-or.5 'nset-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) (eql :key) (member evenp oddp ,#'evenp ,#'oddp)) 4 :replicate '(t t nil nil)) (def-type-prop-test subsetp.1 'subsetp '(list list) 2) (def-type-prop-test subsetp.2 'subsetp '((cons integer null) (cons integer (cons integer (cons integer (cons integer null))))) 2) gcl27-2.7.0/ansi-tests/random-type-prop-tests-06.lsp000066400000000000000000000162601454061450500220610ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 13 15:33:55 2005 ;;;; Contains: Random type prop tests, part 6 (arrays) (in-package :cl-test) (def-type-prop-test adjustable-array-p 'adjustable-array-p '(array) 1) (def-type-prop-test aref.0 'aref '((array * nil)) 1) (def-type-prop-test aref.1 'aref (list '(array * (*)) (index-type-for-dim 0)) 2) (def-type-prop-test aref.2 'aref (list '(array * (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3) (def-type-prop-test aref.3 'aref (list '(array * (* * *)) (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2)) 4) (def-type-prop-test array-dimension 'array-dimension (list 'array #'(lambda (x) (let ((r (array-rank x))) (and (> r 0) `(integer 0 (,r)))))) 2) (def-type-prop-test array-dimensions 'array-dimensions '(array) 1) (def-type-prop-test array-element-type 'array-element-type '(array) 1) (def-type-prop-test array-has-fill-pointer-p.1 'array-has-fill-pointer-p '(array) 1) (def-type-prop-test array-has-fill-pointer-p.2 'array-has-fill-pointer-p '(vector) 1) (def-type-prop-test array-displacement.1 'array-displacement '(array) 1) (def-type-prop-test array-displacement.2 'array-displacement '(vector) 1) (def-type-prop-test array-in-bounds-p.0 'array-in-bounds-p '((array * nil)) 1) (def-type-prop-test array-in-bounds-p.1 'array-in-bounds-p (list '(array * (*)) (index-type-for-dim 0)) 2) (def-type-prop-test array-in-bounds-p.2 'array-in-bounds-p (list '(array * (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3) (def-type-prop-test array-in-bounds-p.3 'array-in-bounds-p (list '(array * (* * *)) (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2)) 4) (def-type-prop-test array-in-bounds-p.4 'array-in-bounds-p '((array * (*)) integer) 2) (def-type-prop-test array-in-bounds-p.5 'array-in-bounds-p '((array * (* *)) integer integer) 3) (def-type-prop-test array-in-bounds-p.6 'array-in-bounds-p '((array * (* * *)) integer integer integer) 4) (def-type-prop-test array-rank 'array-rank '(array) 1) (def-type-prop-test array-row-major-index.0 'array-row-major-index '((array * nil)) 1) (def-type-prop-test array-row-major-index.1 'array-row-major-index (list '(array * (*)) (index-type-for-dim 0)) 2) (def-type-prop-test array-row-major-index.2 'array-row-major-index (list '(array * (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3) (def-type-prop-test array-row-major-index.3 'array-row-major-index (list '(array * (* * *)) (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2)) 4) (def-type-prop-test array-total-size 'array-total-size '(array) 1) (def-type-prop-test arrayp 'arrayp '(t) 1) (def-type-prop-test fill-pointer '(lambda (x) (and (array-has-fill-pointer-p x) (fill-pointer x))) '(vector) 1) (def-type-prop-test row-major-aref 'row-major-aref (list 'array #'(lambda (a) (let ((s (array-total-size a))) (and (> s 0) `(integer 0 (,s)))))) 2) (def-type-prop-test upgraded-array-element-type 'upgraded-array-element-type (list #'(lambda () (let ((x (make-random-element-of-type t))) `(eql ,(make-random-type-containing x))))) 1) (def-type-prop-test simple-vector-p.1 'simple-vector-p '(t) 1) (def-type-prop-test simple-vector-p.2 'simple-vector-p '(vector) 1) (def-type-prop-test svref 'svref (list 'simple-vector (index-type-for-dim 0)) 2) (def-type-prop-test vector 'vector nil 1 :rest-type t :maxargs 10) (def-type-prop-test vectorp.1 'vectorp '(t) 1) (def-type-prop-test vectorp.2 'vectorp '(array) 1) (def-type-prop-test bit.1 'bit (list '(array bit (*)) (index-type-for-dim 0)) 2) (def-type-prop-test bit.2 'bit (list '(array bit (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3) (def-type-prop-test bit.3 'bit (list '(array bit (* * *)) (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2)) 4) (def-type-prop-test sbit.1 'sbit (list '(simple-array bit (*)) (index-type-for-dim 0)) 2) (def-type-prop-test sbit.2 'sbit (list '(simple-array bit (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3) (def-type-prop-test sbit.3 'sbit (list '(simple-array bit (* * *)) (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2)) 4) (def-type-prop-test bit-and.1 'bit-and (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims)))) 2) (def-type-prop-test bit-and.2 'bit-and (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-andc1.1 'bit-andc1 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims)))) 2) (def-type-prop-test bit-andc1.2 'bit-andc1 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-andc2.1 'bit-andc2 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims)))) 2) (def-type-prop-test bit-andc2.2 'bit-andc2 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-ior.1 'bit-ior (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims)))) 2) (def-type-prop-test bit-ior.2 'bit-ior (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-orc1.1 'bit-orc1 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims)))) 2) (def-type-prop-test bit-orc1.2 'bit-orc1 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-orc2.1 'bit-orc2 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims)))) 2) (def-type-prop-test bit-orc2.2 'bit-orc2 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-eqv.1 'bit-eqv (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims)))) 2) (def-type-prop-test bit-eqv.2 'bit-eqv (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-xor.1 'bit-xor (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims)))) 2) (def-type-prop-test bit-xor.2 'bit-xor (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-nand.1 'bit-nand (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims)))) 2) (def-type-prop-test bit-nand.2 'bit-nand (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-nor.1 'bit-nor (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims)))) 2) (def-type-prop-test bit-nor.2 'bit-nor (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-not.1 'bit-not '((array bit)) 1) (def-type-prop-test bit-not.2 'bit-not '((array bit) null) 2) (def-type-prop-test bit-vector-p 'bit-vector-p '(t) 1) (def-type-prop-test simple-bit-vector-p 'simple-bit-vector-p '(t) 1) gcl27-2.7.0/ansi-tests/random-type-prop-tests-07.lsp000066400000000000000000000106301454061450500220550ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 13 17:03:52 2005 ;;;; Contains: Random type prop tests, part 7 (strings) (in-package :cl-test) (def-type-prop-test simple-string-p 'simple-string-p '(t) 1) (def-type-prop-test char 'char (list 'string (index-type-for-dim 0)) 2) (def-type-prop-test schar 'schar (list 'simple-string (index-type-for-dim 0)) 2) (def-type-prop-test string 'string '((or string symbol character)) 1) (def-type-prop-test string-upcase 'string-upcase '(string) 1) (def-type-prop-test string-downcase 'string-downcase '(string) 1) (def-type-prop-test string-capitalize 'string-capitalize '(string) 1) (def-type-prop-test string-trim.1 'string-trim '(string string) 2) (def-type-prop-test string-trim.2 'string-trim (list #'(lambda () (make-list-type (random 10) 'null 'character)) 'string) 2) (def-type-prop-test string-left-trim.1 'string-left-trim '(string string) 2) (def-type-prop-test string-left-trim.2 'string-left-trim (list #'(lambda () (make-list-type (random 10) 'null 'character)) 'string) 2) (def-type-prop-test string-right-trim.1 'string-right-trim '(string string) 2) (def-type-prop-test string-right-trim.2 'string-right-trim (list #'(lambda () (make-list-type (random 10) 'null 'character)) 'string) 2) (defmacro def-string-comparison-type-prop-test (op) (flet ((%makename (n) (intern (format nil "~A.~A" op n) :cl-test))) `(progn (def-type-prop-test ,(%makename 1) ',op '(string string) 2) (def-type-prop-test ,(%makename 2) ',op `(string string (eql :start1) ,#'index-type-for-v1) 4) (def-type-prop-test ,(%makename 3) ',op `(string string (eql :start2) ,#'index-type-for-v2) 4) (def-type-prop-test ,(%makename 4) ',op `(string string (eql :end1) ,#'end-type-for-v1) 4) (def-type-prop-test ,(%makename 5) ',op `(string string (eql :end2) ,#'end-type-for-v2) 4) (def-type-prop-test ,(%makename 6) ',op `(string string (eql :start1) ,#'index-type-for-v1 (eql :end1) ,#'end-type-for-v1) 6) (def-type-prop-test ,(%makename 7) ',op `(string string (eql :start1) ,#'index-type-for-v1 (eql :end2) ,#'end-type-for-v2) 6) (def-type-prop-test ,(%makename 8) ',op `(string string (eql :start2) ,#'index-type-for-v2 (eql :end1) ,#'end-type-for-v1) 6) (def-type-prop-test ,(%makename 9) ',op `(string string (eql :start2) ,#'index-type-for-v2 (eql :end2) ,#'end-type-for-v2) 6) (def-type-prop-test ,(%makename 10) ',op `(string string (eql :start1) ,#'index-type-for-v1 (eql :start2) ,#'index-type-for-v2 (eql :end1) ,#'end-type-for-v1) 8) (def-type-prop-test ,(%makename 11) ',op `(string string (eql :start1) ,#'index-type-for-v1 (eql :start2) ,#'index-type-for-v2 (eql :end2) ,#'end-type-for-v2) 8) (def-type-prop-test ,(%makename 12) ',op `(string string (eql :start1) ,#'index-type-for-v1 (eql :end2) ,#'end-type-for-v2 (eql :end1) ,#'end-type-for-v1) 8) (def-type-prop-test ,(%makename 13) ',op `(string string (eql :start2) ,#'index-type-for-v2 (eql :end2) ,#'end-type-for-v2 (eql :end1) ,#'end-type-for-v1) 8) (def-type-prop-test ,(%makename 14) ',op `(string string (eql :start1) ,#'index-type-for-v1 (eql :start2) ,#'index-type-for-v2 (eql :end2) ,#'end-type-for-v2 (eql :end1) ,#'end-type-for-v1) 10) ))) (def-string-comparison-type-prop-test string=) (def-string-comparison-type-prop-test string/=) (def-string-comparison-type-prop-test string<) (def-string-comparison-type-prop-test string<=) (def-string-comparison-type-prop-test string>) (def-string-comparison-type-prop-test string>=) (def-string-comparison-type-prop-test string-equal) (def-string-comparison-type-prop-test string-not-equal) (def-string-comparison-type-prop-test string-lessp) (def-string-comparison-type-prop-test string-greaterp) (def-string-comparison-type-prop-test string-not-lessp) (def-string-comparison-type-prop-test string-not-greaterp) (def-type-prop-test stringp 'stringp '(t) 1) (def-type-prop-test make-string.1 'make-string '((integer 0 100) (eql :initial-element) character) 3) (def-type-prop-test make-string.2 'make-string `((integer 0 100) (eql :initial-element) character (eql :element-type) ,#'(lambda (&rest args) `(eql (and character ,(make-random-type-containing (third args)))))) 5) gcl27-2.7.0/ansi-tests/random-type-prop-tests-08.lsp000066400000000000000000000232231454061450500220600ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 13 18:31:57 2005 ;;;; Contains: Random type prop tests, part 8 (sequences) (in-package :cl-test) (def-type-prop-test copy-seq 'copy-seq '((or vector list)) 1) (def-type-prop-test elt 'elt (list '(or vector list) #'(lambda (x) (let ((len (length x))) (and (> len 0) `(integer 0 (,len)))))) 2) (defmacro rfill (x y &rest other-args) `(fill ,y ,x ,@other-args)) (def-type-prop-test fill.1 'rfill (list t #'make-random-sequence-type-containing) 2 :replicate '(nil t)) (def-type-prop-test fill.2 'rfill (list 'integer #'make-random-sequence-type-containing) 2 :replicate '(nil t)) (def-type-prop-test fill.3 'rfill (list 'character #'make-random-sequence-type-containing) 2 :replicate '(nil t)) (def-type-prop-test fill.4 'rfill (list t #'make-random-sequence-type-containing '(eql :start) #'(lambda (v s k1) (declare (ignore v k1)) (let ((len (length s))) `(integer 0 ,len)))) 4 :replicate '(nil t nil nil)) (def-type-prop-test fill.5 'rfill (list t #'make-random-sequence-type-containing '(eql :end) #'(lambda (v s k1) (declare (ignore v k1)) (let ((len (length s))) `(integer 0 ,len)))) 4 :replicate '(nil t nil nil)) (def-type-prop-test fill.6 'rfill (list t #'make-random-sequence-type-containing '(eql :start) #'(lambda (v s k1) (declare (ignore v k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :end) #'(lambda (v s k1 start k2) (declare (ignore v k1 k2)) (let ((len (length s))) `(integer ,start ,len)))) 6 :replicate '(nil t nil nil nil nil)) ;;; make-sequence tests here (def-type-prop-test subseq.1 'subseq (list 'sequence #'(lambda (s) `(integer 0 ,(length s)))) 2) (def-type-prop-test subseq.2 'subseq (list 'sequence #'(lambda (s) `(integer 0 ,(length s))) #'(lambda (s start) `(integer ,start ,(length s)))) 3) ;;; map tests here (def-type-prop-test map.1 'map (list '(member list vector) '(member list #.#'list) '(or list vector)) 3) (def-type-prop-test map.2 'map (list '(member list vector) '(member list #.#'list) '(or list vector) '(or list vector)) 4) (def-type-prop-test map.3 'map (list '(member list vector) '(member list #.#'list) '(or list vector) '(or list vector) '(or list vector)) 5) (def-type-prop-test map.4 'map (list '(member list vector (vector (unsigned-byte 32))) '(member 1+ #.#'1+) `(or ,@(loop for i from 1 to 31 collect `(vector (unsigned-byte ,i))))) 3) (def-type-prop-test map.5 'map (list `(member ,@(loop for i from 1 to 32 collect `(vector (unsigned-byte ,i)))) '(member 1+ #.#'1+) #'(lambda (type fun) (declare (ignore fun)) (let ((i (cadadr type))) `(or ,@(loop for j from i to 32 collect `(vector (integer 0 ,(- (ash 1 i) 2)))))))) 3) ;;; map-into tests here (def-type-prop-test map-into.1 'map-into (list '(or list (vector t)) '(member list #.#'list) '(or list vector)) 3 :replicate '(t nil nil)) (def-type-prop-test map-into.2 'map-into (list '(or list (vector t)) '(member list #.#'list) '(or list vector) '(or list vector)) 4 :replicate '(t nil nil nil)) ;;; reduce tests here (def-type-prop-test count.1 'count '(t sequence) 2) (def-type-prop-test count.2 'count (list t #'make-random-sequence-type-containing) 2) (def-type-prop-test count.3 'count (list t #'make-random-sequence-type-containing '(eql :start) #'(lambda (x s k1) (declare (ignore x k1)) `(integer 0 ,(length s)))) 4) (def-type-prop-test count.4 'count (list t #'make-random-sequence-type-containing '(eql :end) #'(lambda (x s k1) (declare (ignore x k1)) `(integer 0 ,(length s)))) 4) (def-type-prop-test count.5 'count (list t #'make-random-sequence-type-containing '(eql :start) #'(lambda (x s k1) (declare (ignore x k1)) `(integer 0 ,(length s))) '(eql :end) #'(lambda (x s k1 start k2) (declare (ignore x k1 k2)) `(integer ,start ,(length s)))) 6) (def-type-prop-test count.6 'count (list '(or short-float single-float double-float long-float) #'(lambda (f) `(vector (or ,(typecase f (short-float 'short-float) (single-float 'single-float) (double-float 'double-float) (long-float 'long-float) (t 'float)) (eql ,f))))) 2) (def-type-prop-test count.7 'count '(bit (vector bit)) 2) (def-type-prop-test count.8 'count '((unsigned-byte 2) (vector (unsigned-byte 2))) 2) (def-type-prop-test count.9 'count '((unsigned-byte 4) (vector (unsigned-byte 4))) 2) (def-type-prop-test count.10 'count '((unsigned-byte 8) (vector (unsigned-byte 8))) 2) ;;; count-if tests (def-type-prop-test count-if.1 'count-if (list (let ((funs '(numberp rationalp realp floatp complexp symbolp identity null functionp listp consp arrayp vectorp simple-vector-p stringp simple-string-p bit-vector-p simple-bit-vector-p))) `(member ,@funs ,@(mapcar #'symbol-function funs))) '(or list vector)) 2) (def-type-prop-test count-if.2 'count-if (list (let ((funs '(numberp rationalp realp floatp complexp symbolp identity null functionp listp consp arrayp vectorp simple-vector-p stringp simple-string-p bit-vector-p simple-bit-vector-p))) `(member ,@funs ,@(mapcar #'symbol-function funs))) '(or list vector) '(eql :key) (let ((key-funs '(identity not null))) `(member ,@key-funs ,@(mapcar #'symbol-function key-funs)))) 4) ;;; Put count-if-not tests here (def-type-prop-test length.1 'length '(sequence) 1) (def-type-prop-test reverse.1 'reverse '(sequence) 1) (def-type-prop-test nreverse.1 'nreverse '(sequence) 1 :replicate '(t)) (def-type-prop-test sort.1 'sort `((vector bit) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test sort.2 'sort `((or (vector (unsigned-byte 2)) (vector (unsigned-byte 3)) (vector (unsigned-byte 4)) (vector (unsigned-byte 5)) (vector (unsigned-byte 6)) (vector (unsigned-byte 7)) (vector (unsigned-byte 8))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test sort.3 'sort `((or (vector (unsigned-byte 10)) (vector (unsigned-byte 13)) (vector (unsigned-byte 15)) (vector (unsigned-byte 16))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test sort.4 'sort `((or (vector (unsigned-byte 20)) (vector (unsigned-byte 24)) (vector (unsigned-byte 28)) (vector (unsigned-byte 31)) (vector (unsigned-byte 32))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test sort.5 'sort `((or (vector (signed-byte 2)) (vector (signed-byte 3)) (vector (signed-byte 4)) (vector (signed-byte 5)) (vector (signed-byte 6)) (vector (signed-byte 7)) (vector (signed-byte 8))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test sort.6 'sort `((or (vector (signed-byte 10)) (vector (signed-byte 13)) (vector (signed-byte 15)) (vector (signed-byte 16))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test sort.7 'sort `((or (vector (signed-byte 20)) (vector (signed-byte 24)) (vector (signed-byte 28)) (vector (signed-byte 31)) (vector (signed-byte 32))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test sort.8 'sort `((or (vector short-float) (vector single-float) (vector double-float) (vector long-float)) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) ;;; Stable sort (def-type-prop-test stable-sort.1 'stable-sort `((vector bit) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test stable-sort.2 'stable-sort `((or (vector (unsigned-byte 2)) (vector (unsigned-byte 3)) (vector (unsigned-byte 4)) (vector (unsigned-byte 5)) (vector (unsigned-byte 6)) (vector (unsigned-byte 7)) (vector (unsigned-byte 8))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test stable-sort.3 'stable-sort `((or (vector (unsigned-byte 10)) (vector (unsigned-byte 13)) (vector (unsigned-byte 15)) (vector (unsigned-byte 16))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test stable-sort.4 'stable-sort `((or (vector (unsigned-byte 20)) (vector (unsigned-byte 24)) (vector (unsigned-byte 28)) (vector (unsigned-byte 31)) (vector (unsigned-byte 32))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test stable-sort.5 'stable-sort `((or (vector (signed-byte 2)) (vector (signed-byte 3)) (vector (signed-byte 4)) (vector (signed-byte 5)) (vector (signed-byte 6)) (vector (signed-byte 7)) (vector (signed-byte 8))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test stable-sort.6 'stable-sort `((or (vector (signed-byte 10)) (vector (signed-byte 13)) (vector (signed-byte 15)) (vector (signed-byte 16))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test stable-sort.7 'stable-sort `((or (vector (signed-byte 20)) (vector (signed-byte 24)) (vector (signed-byte 28)) (vector (signed-byte 31)) (vector (signed-byte 32))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test stable-sort.8 'stable-sort `((or (vector short-float) (vector single-float) (vector double-float) (vector long-float)) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test stable-sort.9 'stable-sort `((vector (cons (integer 0 4) (eql nil))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=) (eql :key) (member car ,#'car)) 4 :replicate '(t nil nil nil) :test #'equalp-and-eql-elements) gcl27-2.7.0/ansi-tests/random-type-prop-tests-09.lsp000066400000000000000000000466471454061450500221000ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Contains: Random type prop tests, part 9 (sequences) (in-package :cl-test) ;;; FIND (def-type-prop-test find.1 'find (list t #'make-random-sequence-type-containing) 2) (def-type-prop-test find.2 'find (list 'integer #'make-random-sequence-type-containing) 2) (def-type-prop-test find.3 'find (list 'character #'make-random-sequence-type-containing) 2) (def-type-prop-test find.4 'find (list t #'make-random-sequence-type-containing '(eql :start) #'(lambda (v s k1) (declare (ignore v k1)) (let ((len (length s))) `(integer 0 ,len)))) 4) (def-type-prop-test find.5 'find (list t #'make-random-sequence-type-containing '(eql :end) #'(lambda (v s k1) (declare (ignore v k1)) (let ((len (length s))) `(integer 0 ,len)))) 4) (def-type-prop-test find.6 'find (list t #'make-random-sequence-type-containing '(eql :start) #'(lambda (v s k1) (declare (ignore v k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :end) #'(lambda (v s k1 start k2) (declare (ignore v k1 k2)) (let ((len (length s))) `(integer ,start ,len)))) 6) (def-type-prop-test find.7 'find (list 'integer #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) (random-from-seq #(bit integer float rational real number)))) '(eql :key) '(member 1+ #.#'1+ 1- #.#'1- - #.#'-)) 4) (def-type-prop-test find.8 'find (list 'character #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) (random-from-seq #(character base-char standard-char)))) '(eql :key) '(member char-upcase #.#'char-upcase char-downcase #.#'char-downcase upper-case-p #.#'upper-case-p lower-case-p #.#'lower-case-p both-case-p #.#'both-case-p char-code #.#'char-code char-int #.#'char-int alpha-char-p #.#'alpha-char-p digit-char-p #.#'digit-char-p alphanumericp #.#'alphanumericp)) 4) (def-type-prop-test find.9 'find (list t #'make-random-sequence-type-containing '(eql :from-end) '(or null t)) 4) (def-type-prop-test find.10 'find (list 'real #'(lambda (x) (make-sequence-type (random 10) (random-from-seq #(bit integer float rational real)))) '(eql :from-end) '(or null t) '(member :test :test-not) (list 'member '< #'< '> #'> '<= #'<= '>= #'>= '= #'= '/= #'/= 'equal #'equal 'eql #'eql)) 6) ;;; FIND-IF (def-type-prop-test find-if.1 'find-if (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence) 2) (def-type-prop-test find-if.2 'find-if (list (let ((char-predicates '(alpha-char-p digit-char-p upper-case-p lower-case-p both-case-p alphanumericp graphic-char-p standard-char-p))) (append '(member) char-predicates (mapcar #'symbol-function char-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) '(or standard-char base-char character)))) 2) (def-type-prop-test find-if.3 'find-if (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) `(or bit bit bit bit bit bit bit ,@(loop for x from 2 to 32 collect `(unsigned-byte ,x)) ,@(loop for x from 2 to 32 collect `(signed-byte ,x)))))) 2) (def-type-prop-test find-if.4 'find-if (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len)))) 4) (def-type-prop-test find-if.5 'find-if (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :end) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len)))) 4) (def-type-prop-test find-if.6 'find-if (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :end) #'(lambda (f s k1 start k2) (declare (ignore f k1 k2)) (let ((len (length s))) `(integer ,start ,len)))) 6) (def-type-prop-test find-if.7 'find-if (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) `(or bit bit bit bit bit bit bit ,@(loop for x from 2 to 32 collect `(unsigned-byte ,x)) ,@(loop for x from 2 to 32 collect `(signed-byte ,x))))) '(eql :key) (list 'member '1+ '1- 'identity '- #'1+ #'1- #'identity #'-)) 4) (def-type-prop-test find-if.8 'find-if (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) `(or bit bit bit bit bit bit bit ,@(loop for x from 2 to 32 collect `(unsigned-byte ,x)) ,@(loop for x from 2 to 32 collect `(signed-byte ,x))))) '(eql :from-end) '(or null t)) 4) (def-type-prop-test find-if.9 'find-if (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :from-end) '(or null t)) 6) (def-type-prop-test find-if.10 'find-if (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :end) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :from-end) '(or null t)) 6) ;;; FIND-IF-NOT (def-type-prop-test find-if-not.1 'find-if-not (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence) 2) (def-type-prop-test find-if-not.2 'find-if-not (list (let ((char-predicates '(alpha-char-p digit-char-p upper-case-p lower-case-p both-case-p alphanumericp graphic-char-p standard-char-p))) (append '(member) char-predicates (mapcar #'symbol-function char-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) '(or standard-char base-char character)))) 2) (def-type-prop-test find-if-not.3 'find-if-not (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) `(or bit bit bit bit bit bit bit ,@(loop for x from 2 to 32 collect `(unsigned-byte ,x)) ,@(loop for x from 2 to 32 collect `(signed-byte ,x)))))) 2) (def-type-prop-test find-if-not.4 'find-if-not (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len)))) 4) (def-type-prop-test find-if-not.5 'find-if-not (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :end) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len)))) 4) (def-type-prop-test find-if-not.6 'find-if-not (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :end) #'(lambda (f s k1 start k2) (declare (ignore f k1 k2)) (let ((len (length s))) `(integer ,start ,len)))) 6) (def-type-prop-test find-if-not.7 'find-if-not (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) `(or bit bit bit bit bit bit bit ,@(loop for x from 2 to 32 collect `(unsigned-byte ,x)) ,@(loop for x from 2 to 32 collect `(signed-byte ,x))))) '(eql :key) (list 'member '1+ '1- 'identity '- #'1+ #'1- #'identity #'-)) 4) (def-type-prop-test find-if-not.8 'find-if-not (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) `(or bit bit bit bit bit bit bit ,@(loop for x from 2 to 32 collect `(unsigned-byte ,x)) ,@(loop for x from 2 to 32 collect `(signed-byte ,x))))) '(eql :from-end) '(or null t)) 4) (def-type-prop-test find-if-not.9 'find-if-not (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :from-end) '(or null t)) 6) (def-type-prop-test find-if-not.10 'find-if-not (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :end) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :from-end) '(or null t)) 6) ;;; POSITION (def-type-prop-test position.1 'position (list t #'make-random-sequence-type-containing) 2) (def-type-prop-test position.2 'position (list 'integer #'make-random-sequence-type-containing) 2) (def-type-prop-test position.3 'position (list 'character #'make-random-sequence-type-containing) 2) (def-type-prop-test position.4 'position (list t #'make-random-sequence-type-containing '(eql :start) #'(lambda (v s k1) (declare (ignore v k1)) (let ((len (length s))) `(integer 0 ,len)))) 4) (def-type-prop-test position.5 'position (list t #'make-random-sequence-type-containing '(eql :end) #'(lambda (v s k1) (declare (ignore v k1)) (let ((len (length s))) `(integer 0 ,len)))) 4) (def-type-prop-test position.6 'position (list t #'make-random-sequence-type-containing '(eql :start) #'(lambda (v s k1) (declare (ignore v k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :end) #'(lambda (v s k1 start k2) (declare (ignore v k1 k2)) (let ((len (length s))) `(integer ,start ,len)))) 6) (def-type-prop-test position.7 'position (list 'integer #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) (random-from-seq #(bit integer float rational real number)))) '(eql :key) '(member 1+ #.#'1+ 1- #.#'1- - #.#'-)) 4) (def-type-prop-test position.8 'position (list 'character #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) (random-from-seq #(character base-char standard-char)))) '(eql :key) '(member char-upcase #.#'char-upcase char-downcase #.#'char-downcase upper-case-p #.#'upper-case-p lower-case-p #.#'lower-case-p both-case-p #.#'both-case-p char-code #.#'char-code char-int #.#'char-int alpha-char-p #.#'alpha-char-p digit-char-p #.#'digit-char-p alphanumericp #.#'alphanumericp)) 4) (def-type-prop-test position.9 'position (list t #'make-random-sequence-type-containing '(eql :from-end) '(or null t)) 4) (def-type-prop-test position.10 'position (list 'real #'(lambda (x) (make-sequence-type (random 10) (random-from-seq #(bit integer float rational real)))) '(eql :from-end) '(or null t) '(member :test :test-not) (list 'member '< #'< '> #'> '<= #'<= '>= #'>= '= #'= '/= #'/= 'equal #'equal 'eql #'eql)) 6) ;;; POSITION-IF (def-type-prop-test position-if.1 'position-if (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence) 2) (def-type-prop-test position-if.2 'position-if (list (let ((char-predicates '(alpha-char-p digit-char-p upper-case-p lower-case-p both-case-p alphanumericp graphic-char-p standard-char-p))) (append '(member) char-predicates (mapcar #'symbol-function char-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) '(or standard-char base-char character)))) 2) (def-type-prop-test position-if.3 'position-if (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) `(or bit bit bit bit bit bit bit ,@(loop for x from 2 to 32 collect `(unsigned-byte ,x)) ,@(loop for x from 2 to 32 collect `(signed-byte ,x)))))) 2) (def-type-prop-test position-if.4 'position-if (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len)))) 4) (def-type-prop-test position-if.5 'position-if (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :end) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len)))) 4) (def-type-prop-test position-if.6 'position-if (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :end) #'(lambda (f s k1 start k2) (declare (ignore f k1 k2)) (let ((len (length s))) `(integer ,start ,len)))) 6) (def-type-prop-test position-if.7 'position-if (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) `(or bit bit bit bit bit bit bit ,@(loop for x from 2 to 32 collect `(unsigned-byte ,x)) ,@(loop for x from 2 to 32 collect `(signed-byte ,x))))) '(eql :key) (list 'member '1+ '1- 'identity '- #'1+ #'1- #'identity #'-)) 4) (def-type-prop-test position-if.8 'position-if (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) `(or bit bit bit bit bit bit bit ,@(loop for x from 2 to 32 collect `(unsigned-byte ,x)) ,@(loop for x from 2 to 32 collect `(signed-byte ,x))))) '(eql :from-end) '(or null t)) 4) (def-type-prop-test position-if.9 'position-if (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :from-end) '(or null t)) 6) (def-type-prop-test position-if.10 'position-if (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :end) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :from-end) '(or null t)) 6) ;;; POSITION-IF-NOT (def-type-prop-test position-if-not.1 'position-if-not (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence) 2) (def-type-prop-test position-if-not.2 'position-if-not (list (let ((char-predicates '(alpha-char-p digit-char-p upper-case-p lower-case-p both-case-p alphanumericp graphic-char-p standard-char-p))) (append '(member) char-predicates (mapcar #'symbol-function char-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) '(or standard-char base-char character)))) 2) (def-type-prop-test position-if-not.3 'position-if-not (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) `(or bit bit bit bit bit bit bit ,@(loop for x from 2 to 32 collect `(unsigned-byte ,x)) ,@(loop for x from 2 to 32 collect `(signed-byte ,x)))))) 2) (def-type-prop-test position-if-not.4 'position-if-not (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len)))) 4) (def-type-prop-test position-if-not.5 'position-if-not (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :end) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len)))) 4) (def-type-prop-test position-if-not.6 'position-if-not (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :end) #'(lambda (f s k1 start k2) (declare (ignore f k1 k2)) (let ((len (length s))) `(integer ,start ,len)))) 6) (def-type-prop-test position-if-not.7 'position-if-not (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) `(or bit bit bit bit bit bit bit ,@(loop for x from 2 to 32 collect `(unsigned-byte ,x)) ,@(loop for x from 2 to 32 collect `(signed-byte ,x))))) '(eql :key) (list 'member '1+ '1- 'identity '- #'1+ #'1- #'identity #'-)) 4) (def-type-prop-test position-if-not.8 'position-if-not (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) `(or bit bit bit bit bit bit bit ,@(loop for x from 2 to 32 collect `(unsigned-byte ,x)) ,@(loop for x from 2 to 32 collect `(signed-byte ,x))))) '(eql :from-end) '(or null t)) 4) (def-type-prop-test position-if-not.9 'position-if-not (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :from-end) '(or null t)) 6) (def-type-prop-test position-if-not.10 'position-if-not (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :end) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :from-end) '(or null t)) 6) gcl27-2.7.0/ansi-tests/random-type-prop-tests-10.lsp000066400000000000000000000057071454061450500220600ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Contains: Random type prop tests, part 10 (sequences, cont.) (in-package :cl-test) ;;; SEARCH (def-type-prop-test search.1 'search (list 'sequence 'sequence) 2) (def-type-prop-test search.2 'search (list 'bit-vector 'bit-vector) 2) (def-type-prop-test search.3 'search (list '(vector * 1) 'sequence) 2) (def-type-prop-test search.4 'search (list '(vector * 2) 'sequence '(eql :from-end) '(or null t)) 4) (def-type-prop-test search.5 'search (list 'sequence 'sequence '(eql :key) (list 'member 'identity nil #'identity 'not #'not)) 4) (def-type-prop-test search.6 'search (list #'(lambda () (make-sequence-type (random 10) (let ((i1 (make-random-integer)) (i2 (make-random-integer))) `(integer ,(min i1 i2) ,(max i1 i2))))) #'(lambda (s) (declare (ignore s)) (make-sequence-type (random 10) (let ((i1 (make-random-integer)) (i2 (make-random-integer))) `(integer ,(min i1 i2) ,(max i1 i2)))))) 2) (def-type-prop-test search.7 'search (list #'(lambda () (make-sequence-type (random 10) (let ((i1 (make-random-integer)) (i2 (make-random-integer))) `(integer ,(min i1 i2) ,(max i1 i2))))) #'(lambda (s) (declare (ignore s)) (make-sequence-type (random 10) (let ((i1 (make-random-integer)) (i2 (make-random-integer))) `(integer ,(min i1 i2) ,(max i1 i2))))) '(eql :test) (list 'member 'eql #'eql 'equal #'equal '= #'= '/= #'/= #'(lambda (x y) (= (logand x 1) (logand y 1))))) 4) (def-type-prop-test search.8 'search (labels ((%random-char-type () (random-from-seq #(base-char standard-char character))) (%random-char-sequence-type (&rest ignored) (declare (ignore ignored)) (make-sequence-type (random 10) (%random-char-type)))) (list #'%random-char-sequence-type #'%random-char-sequence-type '(member :test :test-not) (let ((char-compare-funs '(char= char/= char< char> char<= char>= char-equal char-not-equal char-lessp char-greaterp char-not-lessp char-not-greaterp))) `(member ,@char-compare-funs ,@(mapcar #'symbol-function char-compare-funs))))) 4) (def-type-prop-test search.9 'search (list 'sequence 'sequence '(eql :start1) #'(lambda (s1 s2 k) (declare (ignore s2 k)) (let ((len (length s1))) `(integer 0 ,len)))) 4) (def-type-prop-test search.10 'search (list 'sequence 'sequence '(eql :end1) #'(lambda (s1 s2 k) (declare (ignore s2 k)) (let ((len (length s1))) `(integer 0 ,len)))) 4) (def-type-prop-test search.11 'search (list 'sequence 'sequence '(eql :start2) #'(lambda (s1 s2 k) (declare (ignore s1 k)) (let ((len (length s2))) `(integer 0 ,len)))) 4) (def-type-prop-test search.12 'search (list 'sequence 'sequence '(eql :end2) #'(lambda (s1 s2 k) (declare (ignore s1 k)) (let ((len (length s2))) `(integer 0 ,len)))) 4) gcl27-2.7.0/ansi-tests/random-type-prop-tests-structs.lsp000066400000000000000000000044231454061450500233410ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Contains: Random type prop tests: structures (in-package :cl-test) (defstruct rtpt-1 a b) (defmethod make-random-element-of-type ((type (eql 'rtpt-1))) (make-rtpt-1 :a (make-random-element-of-type t) :b (make-random-element-of-type t))) (defmethod replicate ((obj rtpt-1)) (or (gethash obj *replicate-table*) (let ((x (make-rtpt-1))) (setf (gethash obj *replicate-table*) x) (setf (rtpt-1-a x) (replicate (rtpt-1-a obj))) (setf (rtpt-1-b x) (replicate (rtpt-1-b obj))) x))) (defmethods make-random-type-containing* (1 ((val rtpt-1)) 'rtpt-1)) (def-type-prop-test structure-ref.1 'rtpt-1-a '(rtpt-1) 1) (def-type-prop-test copy-structure.1 'copy-structure '(rtpt-1) 1 :test #'equalp) (defstruct rtpt-2 a) (defstruct (rtpt-2.1 (:include rtpt-2)) c d) (defstruct (rtpt-2.2 (:include rtpt-2)) d e) (defmethod make-random-element-of-type ((type (eql 'rtpt-2))) (rcase (1 (make-rtpt-2 :a (make-random-element-of-type t))) (1 (make-random-element-of-type 'rtpt-2.1)) (1 (make-random-element-of-type 'rtpt-2.2)))) (defmethod make-random-element-of-type ((type (eql 'rtpt-2.1))) (make-rtpt-2.1 :a (make-random-element-of-type t) :c (make-random-element-of-type t) :d (make-random-element-of-type t))) (defmethod make-random-element-of-type ((type (eql 'rtpt-2.2))) (make-rtpt-2.2 :a (make-random-element-of-type t) :d (make-random-element-of-type t) :e (make-random-element-of-type t))) (defmethod replicate ((obj rtpt-2)) (replicate-with (obj x (make-rtpt-2)) (setf (rtpt-2-a x) (replicate (rtpt-2-a obj))))) (defmethod replicate ((obj rtpt-2.1)) (replicate-with (obj x (make-rtpt-2.1)) (setf (rtpt-2.1-a x) (replicate (rtpt-2.1-a obj))) (setf (rtpt-2.1-c x) (replicate (rtpt-2.1-c obj))) (setf (rtpt-2.1-d x) (replicate (rtpt-2.1-d obj))))) (defmethod replicate ((obj rtpt-2.2)) (replicate-with (obj x (make-rtpt-2.2)) (setf (rtpt-2.2-a x) (replicate (rtpt-2.2-a obj))) (setf (rtpt-2.2-d x) (replicate (rtpt-2.2-d obj))) (setf (rtpt-2.2-e x) (replicate (rtpt-2.2-e obj))))) (defmethods make-random-type-containing* (1 ((val rtpt-2)) 'rtpt-2) (1 ((val rtpt-2.1)) 'rtpt-2.1) (1 ((val rtpt-2.2)) 'rtpt-2.2)) (def-type-prop-test structure-ref.2 'rtpt-2-a '(rtpt-2) 1) gcl27-2.7.0/ansi-tests/random-type-prop-tests.lsp000066400000000000000000000012301454061450500216250ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Feb 20 11:50:26 2005 ;;;; Contains: Randomized tests of type propagation during compilation (compile-and-load "random-type-prop.lsp") (in-package :cl-test) (load "random-type-prop-tests-01.lsp") (load "random-type-prop-tests-02.lsp") (load "random-type-prop-tests-03.lsp") (load "random-type-prop-tests-04.lsp") (load "random-type-prop-tests-05.lsp") (load "random-type-prop-tests-06.lsp") (load "random-type-prop-tests-07.lsp") (load "random-type-prop-tests-08.lsp") (load "random-type-prop-tests-09.lsp") (load "random-type-prop-tests-10.lsp") (load "random-type-prop-tests-structs.lsp") gcl27-2.7.0/ansi-tests/random-type-prop.lsp000066400000000000000000000557451454061450500205110ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Dec 23 20:39:22 2004 ;;;; Contains: Randomized tests of type propagation in the compiler (in-package :cl-test) (eval-when (:compile-toplevel :load-toplevel) (compile-and-load "random-aux.lsp") (compile-and-load "random-int-form.lsp")) (defvar *print-random-type-prop-input* nil) (defparameter *random-type-prop-result* nil) (declaim (special *param-types* *params* *is-var?* *form*)) (declaim (special *replicate-type*)) (defparameter *default-reps* 1000) (defparameter *default-cell* nil) (defparameter *default-ignore* 'arithmetic-error) (defparameter *default-arg-the* t) ;;; ;;; The random type prop tester takes three required arguments: ;;; ;;; operator A lisp operator (either a symbol or a lambda form) ;;; arg-types A list consisting either of certain kinds of lisp types ;;; (that make-random-element-of-type understands) and/or ;;; functions that yield types. ;;; minargs Minimum number of arguments to be given to the operator. ;;; Must be a positive integer <= maxargs. ;;; ;;; There are also keyword arguments, some with defaults given by special ;;; variables. ;;; ;;; The random type prop tester generates between minargs and maxargs ;;; (maxargs defaults to minargs) random arguments. The type of each ;;; argument is given by the corresponding type in arg-types (or by rest-type, ;;; if there aren't enough elements of arg-types). If the element of arg-types ;;; is a function, the type for the parameter is produced by calling the function ;;; with the previously generated actual parameters as its arguments. ;;; ;;; The list of parameters is stored into the special variable *params*. ;;; ;;; The tester evaluates (operator . arguments), and also builds a lambda ;;; form to be compiled and called on (a subset of) the parameters. The lambda ;;; form is stored in the special variable *form*. ;;; ;;; The macro def-type-prop-test wraps a call to do-random-type-prop-tests ;;; in a deftest form. See random-type-prop-tests.lsp (and subfiles) for examples ;;; of its use testing CL builtin operators. To use it: ;;; ;;; (load "gclload1.lsp") ;;; (compile-and-load "random-int-form.lsp") ;; do this on lisps not supporting recursive compiles ;;; (compile-and-load "random-type-prop.lsp") ;;; (in-package :cl-test) ;;; (load "random-type-prop-tests.lsp") ;;; (let (*catch-errors*) (do-test ')) ;;; or (let (*catch-errors*) (do-tests)) ;;; ;;; Running all the tests may take a while, particularly on lisps with slow compilers. ;;; ;;; ;;; Keyword arguments to do-random-type-prop-tests: ;;; ;;; Argument Default Meaning ;;; ;;; maxargs minargs Maximum number of actual parameters to generate (max 20). ;;; rest-type t Type of arguments beyond those specified in arg-types ;;; reps *default-reps* Number of repetitions to try before stopping. ;;; The default is controlled by a special variable that ;;; is initially 1000. ;;; enclosing-the nil If true, with prob 1/2 randomly generate an enclosing ;;; (THE ...) form around the form invoking the operator. ;;; arg-the *default-arg-the* If true (which is the initial value of the default ;;; special variable), with probability 1/2 randomly generate ;;; a (THE ...) form around each actual parameter. ;;; cell *default-cell* If true (default is NIL), store the result into a rank-0 ;;; array of specialized type. This enables one to test ;;; forms where the result will be unboxed. Otherwise, just ;;; return the values. ;;; ignore *default-ignore* Ignore conditions that are elements of IGNORE. Default is ;;; ARITHMETIC-ERROR. ;;; test rt::equalp-with-case The test function used to compare outputs. It's ;;; also handy to use #'approx= to handle approximate equality ;;; when testing floating point computations, where compiled code ;;; may have different roundoff errors. ;;; replicate nil Cause arguments to be copied (preserving sharing in conses ;;; and arrays) before applying the operator. This is used to test ;;; destructive operators. ;;; ;;; (defun do-random-type-prop-tests (operator arg-types minargs &key (maxargs minargs) (rest-type t) (reps *default-reps*) (enclosing-the nil) (arg-the *default-arg-the*) (cell *default-cell*) (ignore *default-ignore*) (test #'regression-test::equalp-with-case) (replicate nil replicate-p)) (assert (<= 1 minargs maxargs 20)) (prog1 (dotimes (i reps) again (handler-bind #-lispworks ((error #'(lambda (c) (when (typep c ignore) (go again))))) #+lispworks () (let* ((param-names '(p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 p11 p12 p13 p14 p15 p16 p17 p18 p19 p20)) (nargs (+ minargs (random (- maxargs minargs -1)))) (types (subseq (append arg-types (make-list (max 0 (- nargs (length arg-types))) :initial-element rest-type)) 0 nargs)) (replicate (if replicate-p replicate (mapcar (constantly nil) types))) ; (vals (mapcar #'make-random-element-of-type types)) (vals (setq *params* (or (make-random-arguments types) (go again)))) (vals (if replicate (mapcar #'replicate vals) vals)) (is-var? (if (consp replicate) (progn (assert (= (length replicate) (length vals))) (loop for x in replicate collect (or x (coin)))) (loop repeat (length vals) collect (coin)))) (*is-var?* is-var?) (params (loop for x in is-var? for p in param-names when x collect p)) (param-types (mapcar #'make-random-type-containing vals replicate)) (*param-types* param-types) (type-decls (loop for x in is-var? for p in param-names for tp in param-types when x collect `(type ,tp ,p))) (rval (cl:handler-bind (#+sbcl (sb-ext::compiler-note #'muffle-warning) (warning #'muffle-warning)) (let* ((vals (if replicate (mapcar #'replicate vals) vals)) (eval-form (cons operator (loop for v in vals collect `(quote ,v))))) ;; (print eval-form) (terpri) ;; (dotimes (i 100) (eval eval-form)) (eval eval-form)))) (result-type (if (and enclosing-the (integerp rval)) (make-random-type-containing rval) t)) (expr `(,operator ,@(loop for x in is-var? for v in vals for r in replicate for p in param-names collect (if x (if (and arg-the (coin)) (let ((tp (make-random-type-containing v r))) `(the ,tp ,p)) p) (if (or (consp v) (and (symbolp v) (not (or (keywordp v) (member v '(nil t)))))) `(quote ,v) v))))) (speed (random 4)) (space (random 4)) (safety #-allegro (random 4) #+allegro (1+ (random 3))) (debug (random 4)) (store-into-cell? (and cell (coin))) (upgraded-result-type (and store-into-cell? (upgraded-array-element-type `(eql ,rval)))) (form (setq *form* `(lambda (,@(when store-into-cell? '(r)) ,@params) (declare (optimize (speed ,speed) (safety ,safety) (debug ,debug) (space ,space)) ,@(when store-into-cell? `((type (simple-array ,upgraded-result-type nil) r))) ,@ type-decls) ,(let ((result-form (if enclosing-the `(the ,result-type ,expr) expr))) (if store-into-cell? `(setf (aref r) ,result-form) result-form))))) ) (when *print-random-type-prop-input* (let ((*print-pretty* t) (*print-case* :downcase)) (print (list :form form :vals vals)))) (finish-output) (let* ((param-vals (loop for x in is-var? for v in vals when x collect v)) (fn (cl:handler-bind (#+sbcl (sb-ext::compiler-note #'muffle-warning) (warning #'muffle-warning)) (compile nil form))) (result (if store-into-cell? (let ((r (make-array nil :element-type upgraded-result-type))) (apply fn r param-vals) (aref r)) (apply fn param-vals)))) (setq *random-type-prop-result* (list :upgraded-result-type upgraded-result-type :form form :vals vals :result result :rval rval)) (unless (funcall test result rval) (return *random-type-prop-result*)))) ;; #+allegro (excl::gc t) )))) (defun make-random-arguments (types-or-funs) (let ((vals nil)) (loop for type-or-fun in types-or-funs for type = (or (typecase type-or-fun ((and function (not symbol)) (apply type-or-fun vals)) (t type-or-fun)) (return-from make-random-arguments nil) ;; null type ) for val = (make-random-element-of-type type) do (setf vals (nconc vals (list val)))) ;; (dolist (v vals) (describe v)) vals)) (defmacro defmethods (name &rest bodies) `(progn ,@(mapcar #'(lambda (body) `(defmethod ,name ,@body)) bodies))) (defgeneric make-random-type-containing* (val) (:method-combination randomized) (:documentation "Produce a random type containing VAL. If the special variable *REPLICATE-TYPE* is true, and the value is mutable, then do not use the value in MEMBER or EQL type specifiers.")) (defun make-random-type-containing (type &optional *replicate-type*) (declare (special *replicate-type*)) (make-random-type-containing* type)) (defmethods make-random-type-containing* (4 ((val t)) (declare (special *replicate-type*)) (rcase (1 t) (1 (if (consp val) 'cons 'atom)) (1 (if *replicate-type* (make-random-type-containing* val) `(eql ,val))) (1 (if *replicate-type* (make-random-type-containing* val) (let* ((n1 (random 4)) (n2 (random 4)) ;; Replace these calls with (make-random-element-of-type t) ;; at some point (l1 (loop repeat n1 collect (random-leaf))) (l2 (loop repeat n2 collect (random-leaf)))) `(member ,@l1 ,val ,@l2)))))) (1 ((val standard-object)) 'standard-object) (1 ((val structure-object)) 'structure-object) (1 ((val class)) 'class) (1 ((val standard-class)) 'standard-class) (1 ((val structure-class)) 'structure-class) (1 ((val number)) 'number) (1 ((val real)) 'real) (1 ((val ratio)) 'ratio) (1 ((val integer)) (rcase (1 'integer) (1 'signed-byte) (1 (let* ((n1 (random 4)) (n2 (random 4)) (l1 (loop repeat n1 collect (make-random-integer))) (l2 (loop repeat n2 collect (make-random-integer)))) `(member ,@l1 ,val ,@l2))) (1 (let ((lo (abs (make-random-integer)))) `(integer ,(- val lo)))) (2 (let ((lo (abs (make-random-integer)))) `(integer ,(- val lo) *))) (2 (let ((hi (abs (make-random-integer)))) `(integer * ,(+ val hi)))) (4 (let ((lo (abs (make-random-integer))) (hi (abs (make-random-integer)))) `(integer ,(- val lo) ,(+ val hi)))) (1 (if (>= val 0) 'unsigned-byte (throw 'fail nil))))) (2 ((val character)) (rcase (1 'character) (1 (if (typep val 'base-char) 'base-char #-sbcl 'extended-char #+sbcl (throw 'fail nil) )) (1 (if (typep val 'standard-char) 'standard-char (throw 'fail nil))) (1 (let* ((n1 (random 4)) (n2 (random 4)) (l1 (loop repeat n1 collect (make-random-character))) (l2 (loop repeat n2 collect (make-random-character)))) `(member ,@l1 ,val ,@l2))))) (1 ((val null)) 'null) (2 ((val symbol)) (rcase (1 'symbol) (1 (typecase val (boolean 'boolean) (keyword 'keyword) (otherwise (throw 'fail nil)))) (1 (let* ((n1 (random 4)) (n2 (random 4)) (l1 (loop repeat n1 collect (make-random-symbol))) (l2 (loop repeat n2 collect (make-random-symbol)))) `(member ,@l1 ,val ,@l2))))) (1 ((val rational)) (rcase (1 'rational) (1 (let* ((n1 (random 4)) (n2 (random 4)) (l1 (loop repeat n1 collect (make-random-element-of-type 'rational))) (l2 (loop repeat n2 collect (make-random-element-of-type 'rational)))) `(member ,@l1 ,val ,@l2))) (1 `(rational ,val)) (1 `(rational * ,val)) (1 (let ((v (make-random-element-of-type 'rational))) (if (<= v val) `(rational ,v ,val) `(rational ,val ,v)))))) (1 ((val float)) (rcase (1 (let* ((n1 (random 4)) (n2 (random 4)) (l1 (loop repeat n1 collect (- 2 (random (float 1.0 val))))) (l2 (loop repeat n2 collect (- 2 (random (float 1.0 val)))))) `(member ,@l1 ,val ,@l2))) (1 (let ((names (float-types-containing val))) (random-from-seq names))) (1 (let ((name (random-from-seq (float-types-containing val)))) (if (>= val 0) `(,name ,(coerce 0 name) ,val) `(,name ,val ,(coerce 0 name))))))) ) (defun float-types-containing (val) (loop for n in '(short-float single-float double-float long-float float) when (typep val n) collect n)) (defun make-random-array-dimension-spec (array dim-index) (assert (<= 0 dim-index)) (assert (< dim-index (array-rank array))) (let ((dim (array-dimension array dim-index))) (rcase (1 '*) (1 dim)))) ;;; More methods (defmethods make-random-type-containing* (3 ((val bit-vector)) (let ((root (if (and (coin) (typep val 'simple-bit-vector)) 'simple-bit-vector 'bit-vector))) (rcase (1 root) (1 `(,root)) (3 `(,root ,(make-random-array-dimension-spec val 0)))))) (3 ((val vector)) (let ((root 'vector) (alt-root (if (and (coin) (simple-vector-p val)) 'simple-vector 'vector)) (etype (rcase (1 '*) (1 (array-element-type val)) ;; Add rule for creating new element types? ))) (rcase (1 alt-root) (1 `(,alt-root)) (1 `(,root ,etype)) (2 (if (and (simple-vector-p val) (coin)) `(simple-vector ,(make-random-array-dimension-spec val 0)) `(,root ,etype ,(make-random-array-dimension-spec val 0))))))) (3 ((val array)) (let ((root (if (and (coin) (typep val 'simple-array)) 'simple-array 'array)) (etype (rcase (1 (array-element-type val)) (1 '*))) (rank (array-rank val))) (rcase (1 root) (1 `(,root)) (1 `(,root ,etype)) (1 `(,root ,etype ,(loop for i below rank collect (make-random-array-dimension-spec val i)))) (1 `(,root ,etype ,(loop for i below rank collect (array-dimension val i)))) #-ecl (1 `(,root ,etype ,rank))))) (3 ((val string)) (let ((root (cond ((and (coin) (typep val 'base-string)) (cond ((and (coin) (typep val 'simple-base-string)) 'simple-base-string) (t 'base-string))) ((and (coin) (typep val 'simple-string)) 'simple-string) (t 'string)))) (rcase (1 root) (1 `(,root)) (3 `(,root ,(make-random-array-dimension-spec val 0)))))) (1 ((val list)) 'list) (1 ((val cons)) (rcase (1 'cons) (2 `(cons ,(make-random-type-containing* (car val)) ,(make-random-type-containing* (cdr val)))) (1 `(cons ,(make-random-type-containing* (car val)) ,(random-from-seq #(t *)))) (1 `(cons ,(make-random-type-containing* (car val)))) (1 `(cons ,(random-from-seq #(t *)) ,(make-random-type-containing* (cdr val)) )))) (1 ((val complex)) (rcase (1 'complex) #-gcl (1 (let* ((t1 (type-of (realpart val))) (t2 (type-of (imagpart val))) (part-type (cond ((subtypep t1 t2) (upgraded-complex-part-type t2)) ((subtypep t2 t1) (upgraded-complex-part-type t1)) ((and (subtypep t1 'rational) (subtypep t2 'rational)) 'rational) (t (upgraded-complex-part-type `(or ,t1 ,t2)))))) (if (subtypep 'real part-type) '(complex real) `(complex ,part-type)))))) (1 ((val generic-function)) 'generic-function) (1 ((val function)) (rcase (1 'function) (1 (if (typep val 'compiled-function) 'compiled-function 'function)))) ) ;;; Macro for defining random type prop tests (defmacro def-type-prop-test (name &body args) `(deftest ,(intern (concatenate 'string "RANDOM-TYPE-PROP." (string name)) (find-package :cl-test)) (do-random-type-prop-tests ,@args) nil)) ;;; Function used in constructing list types for some random type prop tests (defun make-list-type (length &optional (rest-type 'null) (element-type t)) (let ((result rest-type)) (loop repeat length do (setq result `(cons ,element-type ,result))) result)) (defun make-sequence-type (length &optional (element-type t)) (rcase (1 `(vector ,element-type ,length)) (1 `(array ,element-type (,length))) (1 `(simple-array ,element-type (,length))) (2 (make-list-type length 'null element-type)))) (defun make-random-sequence-type-containing (element &optional *replicate-type*) (make-sequence-type (random 10) (make-random-type-containing* element))) (defun same-set-p (set1 set2 &rest args &key key test test-not) (declare (ignorable key test test-not)) (and (apply #'subsetp set1 set2 args) (apply #'subsetp set2 set2 args) t)) (defun index-type-for-dim (dim) "Returns a function that computes integer type for valid indices of an array dimension, or NIL if there are none." #'(lambda (array &rest other) (declare (ignore other)) (let ((d (array-dimension array dim))) (and (> d 0) `(integer 0 (,d)))))) (defun index-type-for-v1 (v1 &rest other) "Computes integer type for valid indices for the first of two vectors" (declare (ignore other)) (let ((d (length v1))) `(integer 0 ,d))) (defun index-type-for-v2 (v1 v2 &rest other) "Computes integer type for valid indices for the second of two vectors" (declare (ignore v1 other)) (let ((d (length v2))) `(integer 0 ,d))) (defun end-type-for-v1 (v1 v2 &rest other) (declare (ignore v2)) (let ((d (length v1)) (start1 (or (cadr (member :start1 other)) 0))) `(integer ,start1 ,d))) (defun end-type-for-v2 (v1 v2 &rest other) (declare (ignore v1)) (let ((d (length v2)) (start2 (or (cadr (member :start2 other)) 0))) `(integer ,start2 ,d))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defgeneric replicate (obj) (:documentation "Copies the structure of a lisp object recursively, preserving sharing.")) (defmacro replicate-with ((source-obj dest-obj copy-form) &body body) `(or (gethash ,source-obj *replicate-table*) (let ((,dest-obj ,copy-form)) (setf (gethash ,source-obj *replicate-table*) ,dest-obj) ,@body ,dest-obj))) (declaim (special *replicate-table*)) (defmethod replicate :around ((obj t)) "Wrapper to create a hash table for structure sharing, if none exists." (if (boundp '*replicate-table*) (call-next-method obj) (let ((*replicate-table* (make-hash-table))) (call-next-method obj)))) (defmethod replicate ((obj cons)) (or (gethash obj *replicate-table*) (let ((x (cons nil nil))) (setf (gethash obj *replicate-table*) x) (setf (car x) (replicate (car obj))) (setf (cdr x) (replicate (cdr obj))) x))) ;;; Default method for objects without internal structure (defmethod replicate ((obj t)) obj) (defmethod replicate ((obj array)) (multiple-value-bind (new-obj old-leaf new-leaf) (replicate-displaced-array obj) (when new-leaf (loop for i below (array-total-size new-leaf) do (setf (row-major-aref new-leaf i) (row-major-aref old-leaf i)))) new-obj)) (defun replicate-displaced-array (obj) "Replicate the non-terminal (and not already replicated) arrays in a displaced array chain. Return the new root array, the old leaf array, and the new (but empty) leaf array. The latter two are NIL if the leaf did not have to be copied again." (or (gethash obj *replicate-table*) (multiple-value-bind (displaced-to displaced-index-offset) (array-displacement obj) (let ((dims (array-dimensions obj)) (element-type (array-element-type obj)) (fill-pointer (and (array-has-fill-pointer-p obj) (fill-pointer obj))) (adj (adjustable-array-p obj))) (if displaced-to ;; The array is displaced ;; Copy recursively (multiple-value-bind (new-displaced-to old-leaf new-leaf) (replicate-displaced-array displaced-to) (let ((new-obj (make-array dims :element-type element-type :fill-pointer fill-pointer :adjustable adj :displaced-to new-displaced-to :displaced-index-offset displaced-index-offset))) (setf (gethash obj *replicate-table*) new-obj) (values new-obj old-leaf new-leaf))) ;; The array is not displaced ;; This is the leaf array (let ((new-obj (make-array dims :element-type element-type :fill-pointer fill-pointer :adjustable adj))) (setf (gethash obj *replicate-table*) new-obj) (values new-obj obj new-obj))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (declaim (special *isomorphism-table*)) (defun isomorphic-p (obj1 obj2) (let ((*isomorphism-table* (make-hash-table))) (isomorphic-p* obj1 obj2))) (defgeneric isomorphic-p* (obj1 obj2) (:documentation "Returns true iff obj1 and obj2 are 'isomorphic' (that is, have the same structure, including the same leaf values and the same pattern of sharing). It should be the case that (isomorphic-p obj (replicate obj)) is true.")) (defmethod isomorphic-p* ((obj1 t) (obj2 t)) (eql obj1 obj2)) (defmethod isomorphic-p* ((obj1 cons) (obj2 cons)) (let ((previous (gethash obj1 *isomorphism-table*))) (cond (previous ;; If we've already produced a mapping from obj1 to something, ;; isomorphism requires that obj2 be that object (eq previous obj2)) ;; Otherwise, assume obj1 will map to obj2 and recurse (t (setf (gethash obj1 *isomorphism-table*) obj2) (and (isomorphic-p* (car obj1) (car obj2)) (isomorphic-p* (cdr obj1) (cdr obj2))))))) (defmethod isomorphic-p* ((obj1 array) (obj2 array)) (let ((previous (gethash obj1 *isomorphism-table*))) (cond (previous ;; If we've already produced a mapping from obj1 to something, ;; isomorphism requires that obj2 be that object (eq previous obj2)) (t (setf (gethash obj1 *isomorphism-table*) obj2) (and (equal (array-dimensions obj1) (array-dimensions obj2)) (equal (array-element-type obj1) (array-element-type obj2)) (if (array-has-fill-pointer-p obj1) (and (array-has-fill-pointer-p obj2) (eql (fill-pointer obj1) (fill-pointer obj2))) (not (array-has-fill-pointer-p obj2))) (let (to-1 (index-1 0) to-2 (index-2 0)) (multiple-value-setq (to-1 index-1) (array-displacement obj1)) (multiple-value-setq (to-2 index-2) (array-displacement obj2)) (if to-1 (and to-2 (eql index-1 index-2) (isomorphic-p* to-1 to-2)) ;; Not displaced -- recurse on elements (let ((total-size (array-total-size obj1))) (loop for i below total-size always (isomorphic-p* (row-major-aref obj1 i) (row-major-aref obj2 i))))))))))) ;;; Test that sequences have identical elements (defun equalp-and-eql-elements (s1 s2) (and (equalp s1 s2) (every #'eql s1 s2))) gcl27-2.7.0/ansi-tests/random-types.lsp000066400000000000000000000242231454061450500177010ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Oct 6 05:04:45 2003 ;;;; Contains: Generating random types and testing relationships on them (in-package :cl-test) (compile-and-load "types-aux.lsp") (compile-and-load "random-aux.lsp") (compile-and-load "random-int-form.lsp") (defparameter *random-types* nil) (defun make-random-type (size) (if (<= size 1) (rcase (1 nil) (1 t) (1 `(eql ,(let ((r (ash 1 (random 45)))) (random-from-interval r (- r))))) (1 (random-from-seq #(integer unsigned-byte ratio rational real float short-float single-float double-float long-float complex symbol cons function))) (1 (let* ((len (random *maximum-random-int-bits*)) (r1 (ash 1 len)) (r2 (+ r1 r1)) (x (- (random r2) r1)) (y (- (random r2) r1)) (lo (min x y)) (hi (max x y))) `(integer ,lo ,hi))) (1 (make-random-real-type)) ;; (1 (make-random-complex-type)) ) (rcase (2 (let* ((op (random-from-seq #(cons cons and or))) (nargs (if (eq op 'cons) 2 (1+ (random (min size 4))))) (sizes (random-partition (1- size) nargs))) `(,op ,@(mapcar #'make-random-type sizes)))) (1 `(not ,(make-random-type (1- size)))) ; (1 (make-random-function-type size)) ))) (defun make-random-real-type () (rcase (1 (random-from-seq '(integer unsigned-byte short-float single-float double-float long-float rational real))) (1 (destructuring-bind (lo hi) (make-random-integer-range) (rcase (4 `(integer ,lo ,hi)) (1 `(integer ,lo)) (1 `(integer ,lo *)) (2 `(integer * ,hi))))) (1 (let ((r1 (random-real)) (r2 (random-real))) `(real ,(min r1 r2) ,(max r2 r2)))) ;;; Add more cases here )) (defun make-random-complex-type () `(complex ,(make-random-real-type))) (defun make-random-function-type (size) (let* ((sizes (random-partition (1- size) 2)) (types (mapcar #'make-random-type sizes))) `(function (,(car types)) ,(cadr types)))) (defun size-of-type (type) (if (consp type) (case (car type) (complex (1+ (size-of-type (cadr type)))) ((array simple-array) (1+ (size-of-type (cadr type)))) (vector (1+ (size-of-type (cadr type)))) (complex (1+ (size-of-type (cadr type)))) ((cons or and not) (reduce #'+ (cdr type) :initial-value 1 :key #'size-of-type)) (t 1)) 1)) (defun mutate-type (type) (let* ((size (size-of-type type)) (r (random size))) (flet ((%f () (rcase (6 (make-random-type (random (1+ size)))) (2 `(not ,type)) (1 `(and ,(make-random-type 1) ,type)) (1 `(and ,type ,(make-random-type 1))) (1 `(or ,(make-random-type 1) ,type)) (1 `(or ,type ,(make-random-type 1))))) (%random-int () (let ((bits (1+ (min (random 20) (random 20))))) (- (ash 1 bits) (random (ash 1 (1+ bits))))))) (if (or (and (= r 0) (coin)) (not (consp type))) (%f) (case (car type) ((and or not cons complex) (let ((sizes (mapcar #'size-of-type (cdr type)))) (loop with sum = 0 for e on sizes for ctype in (cdr type) for i from 0 do (setf sum (incf (car e) sum)) when (>= sum r) return (rcase (1 ctype) ;; replace with component type (1 (cons (car type) (append (subseq (cdr type) 0 i) (list (mutate-type ctype)) (subseq (cdr type) (1+ i))))))))) ((array simple-array vector) (let ((ctype (if (cdr type) (cadr type) t))) (rcase (1 (if (eql ctype *) t ctype)) (1 (cons (car type) (cons (mutate-type ctype) (cddr type))))))) ((unsigned-byte) (if (integerp (cadr type)) (rcase (1 'unsigned-byte) (1 `(unsigned-byte (+ (cadr type) (- 10 (random 20)))))) (%f))) ((integer) (let ((lo-delta (%random-int)) (hi-delta (%random-int)) (old-lo (or (cadr type) '*)) (old-hi (or (caddr type) '*))) (flet ((%inc (old delta) (if (or (coin) (not (integerp old))) delta (+ old delta)))) (rcase (1 `(integer ,old-lo *)) (1 `(integer * ,old-hi)) (1 (let ((new-lo (%inc old-lo lo-delta))) (if (or (null (cdr type)) (null (cddr type)) (not (integerp old-hi))) `(integer ,new-lo ,@(cddr type)) ;; caddr is integer (if (<= new-lo old-hi) `(integer ,new-lo ,old-hi) `(integer ,old-hi ,new-lo))))) (1 (let ((new-hi (%inc old-hi hi-delta))) (if (or (null (cdr type)) (null (cddr type)) (not (integerp old-lo))) `(integer ,old-lo ,new-hi) (if (<= old-lo new-hi) `(integer ,old-lo ,new-hi) `(integer ,new-hi ,old-lo))))) (1 (let ((new-lo (%inc old-lo lo-delta)) (new-hi (%inc old-hi hi-delta))) (if (<= new-lo new-hi) `(integer ,new-lo ,new-hi) `(integer ,new-hi ,new-lo)))))))) (t (%f))))))) (defun test-random-types (n size) (loop for t1 = (make-random-type size) for t2 = (make-random-type size) for i from 0 below n ;; do (print (list t1 t2)) do (setf *random-types* (list t1 t2)) do (when (and (= (mod i 100) 0) (> i 0)) (format t "~A " i) (finish-output *standard-output*)) when (test-types t1 t2) collect (list t1 t2) finally (terpri))) (defun test-random-mutated-types (n size &key (reps 1)) (loop for t1 = (make-random-type size) for t2 = (let ((x t1)) (loop repeat reps do (setq x (mutate-type x))) x) for i from 0 below n ;; do (print (list t1 t2)) do (setf *random-types* (list t1 t2)) do (when (and (= (mod i 100) 0) (> i 0)) (format t "~A " i) (finish-output *standard-output*)) when (test-types t1 t2) collect (list t1 t2) finally (terpri))) (defun test-types (t1 t2) (multiple-value-bind (sub success) (subtypep t1 t2) (when success (if sub (check-all-subtypep t1 t2) (let ((nt1 `(not ,t1)) (nt2 `(not ,t2))) (subtypep nt2 nt1)))))) (defun prune-type (tp try-fn) (declare (type function try-fn)) (flet ((try (x) (funcall try-fn x))) (cond ((member tp '(nil t))) ((symbolp tp) (try nil) (try t)) ((consp tp) (try nil) (try t) (let ((op (first tp)) (args (rest tp))) (case op ((cons) (try 'cons) (prune-list args #'prune-type #'(lambda (args) (try `(cons ,@args))))) ((integer) (try op) (try '(eql 0)) (when (= (length args) 2) (let ((arg1 (first args)) (arg2 (second args))) (when (and (integerp arg1) (integerp arg2)) (try `(eql ,arg1)) (try `(eql ,arg2)) (when (and (< arg1 0) (<= 0 arg2)) (try `(integer 0 ,arg2))) (when (and (<= arg1 0) (< 0 arg2)) (try `(integer ,arg1 0))) (when (> (- arg2 arg1) 1) (try `(integer ,(+ arg1 (floor (- arg2 arg1) 2)) ,arg2)) (try `(integer ,arg1 ,(- arg2 (floor (- arg2 arg1) 2))))))))) ((real float ratio single-float double-float short-float long-float) (try op)) ((or and) (mapc try-fn args) (loop for i from 0 below (length args) do (try `(,op ,@(subseq args 0 i) ,@(subseq args (1+ i))))) (prune-list args #'prune-type #'(lambda (args) (try (cons op args))))) ((not) (let ((arg (first args))) (try arg) (when (and (consp arg) (eq (car arg) 'not)) (try (second arg))) (prune-type arg #'(lambda (arg) (try `(not ,arg)))))) ((member) (dolist (arg (cdr tp)) (try `(eql ,arg))) (when (cddr tp) (try `(member ,@(cddr tp))))) ((eql) (assert (= (length args) 1)) (let ((arg (first args))) (unless (= arg 0) (try `(eql 0)) (cond ((< arg -1) (try `(eql ,(ceiling arg 2)))) ((> arg 1) (try `(eql ,(floor arg 2)))))))) ))))) (values)) (defun prune-type-pair (pair &optional (fn #'test-types)) (declare (type function fn)) (let ((t1 (first pair)) (t2 (second pair)) changed) (loop do (flet ((%try2 (new-tp) (when (funcall fn t1 new-tp) (print "Success in first loop") (print new-tp) (setq t2 new-tp changed t) (throw 'success nil)))) (catch 'success (prune-type t2 #'%try2))) do (flet ((%try1 (new-tp) (when (funcall fn new-tp t2) (print "Success in second loop") (print new-tp) (setq t1 new-tp changed t) (throw 'success nil)))) (catch 'success (prune-type t1 #'%try1))) while changed do (setq changed nil)) (list t1 t2))) (defun test-type-triple (t1 t2 t3) ;; Returns non-nil if a problem is found (catch 'problem (multiple-value-bind (sub1 success1) (subtypep t1 t2) (when success1 (if sub1 (append (check-all-subtypep t1 `(or ,t2 ,t3)) (check-all-subtypep `(and ,t1 ,t3) t2)) (or (subtypep `(or ,t1 ,t3) t2) (subtypep t1 `(and ,t2 ,t3)))))))) (defun test-random-types3 (n size) (loop for t1 = (make-random-type (1+ (random size))) for t2 = (make-random-type (1+ (random size))) for t3 = (make-random-type (1+ (random size))) for i from 1 to n ;; do (print (list t1 t2)) do (setf *random-types* (list t1 t2 t3)) do (when (and (= (mod i 100) 0) (> i 0)) (format t "~A " i) (finish-output *standard-output*)) when (test-type-triple t1 t2 t3) collect (list t1 t2 t3) finally (terpri))) (defun prune-type-triple (pair &optional (fn #'test-type-triple)) (declare (type function fn)) (let ((t1 (first pair)) (t2 (second pair)) (t3 (third pair)) changed) (loop do (flet ((%try2 (new-tp) (when (funcall fn t1 new-tp t3) (print "Success in first loop") (print new-tp) (setq t2 new-tp changed t) (throw 'success nil)))) (catch 'success (prune-type t2 #'%try2))) do (flet ((%try1 (new-tp) (when (funcall fn new-tp t2 t3) (print "Success in second loop") (print new-tp) (setq t1 new-tp changed t) (throw 'success nil)))) (catch 'success (prune-type t1 #'%try1))) do (flet ((%try3 (new-tp) (when (funcall fn t1 t2 new-tp) (print "Success in second loop") (print new-tp) (setq t3 new-tp changed t) (throw 'success nil)))) (catch 'success (prune-type t3 #'%try3))) while changed do (setq changed nil)) (list t1 t2 t3))) gcl27-2.7.0/ansi-tests/random.lsp000066400000000000000000000035331454061450500165400ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 6 15:47:42 2003 ;;;; Contains: Tests of RANDOM (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "random-aux.lsp") (deftest random.error.1 (signals-error (random) program-error) t) (deftest random.error.2 (signals-error (random 10 *random-state* nil) program-error) t) (deftest random.error.3 (check-type-error #'random (typef '(real (0)))) nil) (deftest random.1 (loop for i from 2 to 30 for n = (ash 1 i) nconc (loop for j = (1+ (random n)) repeat 20 nconc (loop for r = (random j) repeat i unless (and (integerp r) (<= 0 r) (< r j)) collect (list j r)))) nil) (deftest random.2 (loop for i from 2 to 20 for n = (ash 1 i) nconc (loop for j = (random (float n)) repeat 20 unless (zerop j) nconc (loop for r = (random j) repeat 20 unless (and (eql (float r j) r) (<= 0 r) (< r j)) collect (list j r)))) nil) (deftest random.3 (binomial-distribution-test 10000 #'(lambda () (eql (random 2) 0))) t) (deftest random.4 (binomial-distribution-test 10000 #'(lambda () (< (random 1.0s0) 0.5s0))) t) (deftest random.5 (binomial-distribution-test 10000 #'(lambda () (< (random 1.0d0) 0.5d0))) t) (deftest random.6 (binomial-distribution-test 10000 #'(lambda () (evenp (random 1024)))) t) (deftest random.7 (loop for x in '(10.0s0 20.0f0 30.0d0 40.0l0) for r = (random x) unless (eql (float r x) r) collect (list x r)) nil) (deftest random.8 (let* ((f1 '(lambda (x) (random (if x 10 20)))) (f2 (compile nil f1))) (values (loop repeat 100 always (<= 0 (funcall f2 t) 9)) (loop repeat 100 always (<= 0 (funcall f2 nil) 19)))) t t) ;;; Do more statistical tests here gcl27-2.7.0/ansi-tests/rassoc-if-not.lsp000066400000000000000000000074671454061450500177560ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:35:27 2003 ;;;; Contains: Tests of RASSOC-IF-NOT (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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 (signals-error (rassoc-if-not) program-error) t) (deftest rassoc-if-not.error.2 (signals-error (rassoc-if-not #'null) program-error) t) (deftest rassoc-if-not.error.3 (signals-error (rassoc-if-not #'null nil :bad t) program-error) t) (deftest rassoc-if-not.error.4 (signals-error (rassoc-if-not #'null nil :key) program-error) t) (deftest rassoc-if-not.error.5 (signals-error (rassoc-if-not #'null nil 1 1) program-error) t) (deftest rassoc-if-not.error.6 (signals-error (rassoc-if-not #'null nil :bad t :allow-other-keys nil) program-error) t) (deftest rassoc-if-not.error.7 (signals-error (rassoc-if-not #'cons '((a . b)(c . d))) program-error) t) (deftest rassoc-if-not.error.8 (signals-error (rassoc-if-not #'car '((a . b)(c . d))) type-error) t) (deftest rassoc-if-not.error.9 (signals-error (rassoc-if-not #'identity '((a . b)(c . d)) :key #'cons) program-error) t) (deftest rassoc-if-not.error.10 (signals-error (rassoc-if-not #'identity '((a . b)(c . d)) :key #'car) type-error) t) (deftest rassoc-if-not.error.11 (signals-error (rassoc-if-not #'identity '((a . b) . c)) type-error) t) (deftest rassoc-if-not.error.12 (check-type-error #'(lambda (x) (rassoc-if-not #'identity x)) #'listp) nil) gcl27-2.7.0/ansi-tests/rassoc-if.lsp000066400000000000000000000067001454061450500171450ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:34:59 2003 ;;;; Contains: Tests of RASSOC-IF (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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 (signals-error (rassoc-if) program-error) t) (deftest rassoc-if.error.2 (signals-error (rassoc-if #'null) program-error) t) (deftest rassoc-if.error.3 (signals-error (rassoc-if #'null nil :bad t) program-error) t) (deftest rassoc-if.error.4 (signals-error (rassoc-if #'null nil :key) program-error) t) (deftest rassoc-if.error.5 (signals-error (rassoc-if #'null nil 1 1) program-error) t) (deftest rassoc-if.error.6 (signals-error (rassoc-if #'null nil :bad t :allow-other-keys nil) program-error) t) (deftest rassoc-if.error.7 (signals-error (rassoc-if #'cons '((a . b)(c . d))) program-error) t) (deftest rassoc-if.error.8 (signals-error (rassoc-if #'car '((a . b)(c . d))) type-error) t) (deftest rassoc-if.error.9 (signals-error (rassoc-if #'identity '((a . b)(c . d)) :key #'cons) program-error) t) (deftest rassoc-if.error.10 (signals-error (rassoc-if #'identity '((a . b)(c . d)) :key #'car) type-error) t) (deftest rassoc-if.error.11 (signals-error (rassoc-if #'not '((a . b) . c)) type-error) t) (deftest rassoc-if.error.12 (check-type-error #'(lambda (x) (rassoc-if #'identity x)) #'listp) nil) gcl27-2.7.0/ansi-tests/rassoc.lsp000066400000000000000000000154751454061450500165620ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:33:49 2003 ;;;; Contains: Tests of RASSOC (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) (schar 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)) (deftest rassoc.26 (rassoc 10 '((a . 1) (b . 5) (c . 10) (d . 15) (e . 40)) :test #'<) (d . 15)) (deftest rassoc.27 (rassoc 10 '((a . 1) (b . 5) (c . 10) (d . 15) (e . 40)) :test-not #'>=) (d . 15)) (defharmless rassoc.test-and-test-not.1 (rassoc 'a '((x . b) (y . a) (z . c)) :test #'eql :test-not #'eql)) (defharmless rassoc.test-and-test-not.2 (rassoc 'a '((x . b) (y . a) (z . c)) :test-not #'eql :test #'eql)) ;;; 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 (signals-error (rassoc) program-error) t) (deftest rassoc.error.2 (signals-error (rassoc nil) program-error) t) (deftest rassoc.error.3 (signals-error (rassoc nil nil :bad t) program-error) t) (deftest rassoc.error.4 (signals-error (rassoc nil nil :key) program-error) t) (deftest rassoc.error.5 (signals-error (rassoc nil nil 1 1) program-error) t) (deftest rassoc.error.6 (signals-error (rassoc nil nil :bad t :allow-other-keys nil) program-error) t) (deftest rassoc.error.7 (signals-error (rassoc 'a '((b . a)(c . d)) :test #'identity) program-error) t) (deftest rassoc.error.8 (signals-error (rassoc 'a '((b . a)(c . d)) :test-not #'identity) program-error) t) (deftest rassoc.error.9 (signals-error (rassoc 'a '((b . a)(c . d)) :key #'cons) program-error) t) (deftest rassoc.error.10 (signals-error (rassoc 'z '((a . b) . c)) type-error) t) (deftest rassoci.error.11 (check-type-error #'(lambda (x) (rassoc 'a x)) #'listp) nil) gcl27-2.7.0/ansi-tests/rational.lsp000066400000000000000000000025101454061450500170630ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Sep 1 13:49:18 2003 ;;;; Contains: Tests of RATIONAL (in-package :cl-test) (deftest rational.error.1 (signals-error (rational) program-error) t) (deftest rational.error.2 (signals-error (rational 0 nil) program-error) t) (deftest rational.error.3 (signals-error (rational 0 0) program-error) t) (deftest rational.error.4 (check-type-error #'rational #'realp) nil) (deftest rational.1 (loop for x in (loop for r in *reals* when (or (not (floatp r)) (<= -1000 (nth-value 1 (integer-decode-float r)) 1000)) collect r) for r = (rational x) unless (and (rationalp r) (if (floatp x) (= (float r x) x) (eql x r))) collect (list x r)) nil) (deftest rational.2 (loop for type in '(short-float single-float double-float long-float) collect (loop for i from -10000 to 10000 for x = (coerce i type) for r = (rational x) count (not (eql r i)))) (0 0 0 0)) (deftest rational.3 (loop for type in '(short-float single-float double-float long-float) for bound in '(1.0s5 1.0f10 1.0d20 1.0l30) nconc (loop for x = (random-from-interval bound) for r = (rational x) for x2 = (float r x) repeat 1000 unless (and (rationalp r) (= x x2)) collect (list x r x2))) nil)gcl27-2.7.0/ansi-tests/rationalize.lsp000066400000000000000000000025661454061450500176060ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Sep 1 14:00:45 2003 ;;;; Contains: Tests of RATIONALIZE (in-package :cl-test) (deftest rationalize.error.1 (signals-error (rationalize) program-error) t) (deftest rationalize.error.2 (signals-error (rationalize 0 nil) program-error) t) (deftest rationalize.error.3 (signals-error (rationalize 0 0) program-error) t) (deftest rationalize.error.4 (check-type-error #'rationalize #'realp) nil) (deftest rationalize.1 (loop for x in (loop for r in *reals* when (or (not (floatp r)) (<= -1000 (nth-value 1 (integer-decode-float r)) 1000)) collect r) for r = (rationalize x) unless (and (rationalp r) (if (floatp x) (= (float r x) x) (eql x r))) collect (list x r)) nil) (deftest rationalize.2 (loop for type in '(short-float single-float double-float long-float) collect (loop for i from -10000 to 10000 for x = (coerce i type) for r = (rationalize x) count (not (eql r i)))) (0 0 0 0)) (deftest rationalize.3 (loop for type in '(short-float single-float double-float long-float) for bound in '(1.0s5 1.0f10 1.0d20 1.0l30) nconc (loop for x = (random-from-interval bound) for r = (rationalize x) for x2 = (float r x) repeat 1000 unless (and (rationalp r) (= x x2)) collect (list x r x2))) nil) gcl27-2.7.0/ansi-tests/rationalp.lsp000066400000000000000000000015441454061450500172510ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 7 08:36:31 2003 ;;;; Contains: Tests of RATIONALP (in-package :cl-test) (deftest rationalp.error.1 (signals-error (rationalp) program-error) t) (deftest rationalp.error.2 (signals-error (rationalp 0 nil) program-error) t) (deftest rationalp.error.3 (signals-error (rationalp 'a 0) program-error) t) (deftest rationalp.1 (loop for x in *rationals* for vals = (multiple-value-list (rationalp x)) unless (and (= (length vals) 1) (first vals)) collect (cons x vals)) nil) (deftest rationalp.2 (loop for x in (set-difference *universe* *rationals*) for vals = (multiple-value-list (rationalp x)) unless (and (= (length vals) 1) (null (first vals))) collect (cons x vals)) nil) (deftest rationalp.3 (check-type-predicate #'rationalp 'rational) nil) gcl27-2.7.0/ansi-tests/rctest/000077500000000000000000000000001454061450500160405ustar00rootroot00000000000000gcl27-2.7.0/ansi-tests/rctest/README000066400000000000000000000002511454061450500167160ustar00rootroot00000000000000This directory contains (or will contain) a program for generating random Lisp code. The intent is to generate random input cases to test for compile and/or eval bugs. gcl27-2.7.0/ansi-tests/rctest/form-generators.lsp000066400000000000000000000015651454061450500217010ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jun 21 10:56:09 2003 ;;;; Contains: Generators for forms (in-package :rctest) (defclass form-generator (composite-generator) ()) (defparameter *form-generator* (make-instance 'composite-generator)) (defclass implicit-progn-generator (random-iterative-generator) ((subgenerator :initform *form-generator*))) (defgenerator var-form-generator :keys (vars) :body (random-from-seq vars)) (defgenerator int-form-generator :body (random-case 0 (random-from-seq #.(apply #'vector (loop for i from 0 to 31 collect (ash 1 i)))) (random-from-seq #.(apply #'vector (loop for i from 0 to 31 collect (- (ash 1 i))))) (random-from-seq #.(make-array 128 :initial-contents (loop for i from 0 to 31 for x = (ash 1 i) nconc (list (1- x) (1+ x) (- 1 x) (- -1 x))))) (random 1000))) gcl27-2.7.0/ansi-tests/rctest/generator.lsp000066400000000000000000000074211454061450500205520ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Jun 6 18:15:50 2003 ;;;; Contains: Generator class and associated generic function definitions (in-package :rctest) (compile-and-load "rctest-util.lsp") (defvar *prototype-class-table* (make-hash-table) "Contains a map from names of classes to prototype instances for those classes.") (defgeneric prototype (class) ;; Map a class to a prototype instance of the class. Cache using ;; *prototype-class-table*. (:method ((class standard-class) &aux (name (class-name class))) (or (gethash name *prototype-class-table*) (setf (gethash name *prototype-class-table*) (make-instance class)))) (:method ((class symbol)) (prototype (find-class class)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Generators are objects that are used to create random instances. (defclass generator () ()) (defclass composite-generator (generator) ((subgenerators :type array :initform (make-array '(10) :adjustable t :fill-pointer 0)) (cumulative-weights :type array :initform (make-array '(10) :fill-pointer 0 :adjustable t :element-type 'single-float :initial-element 0.0f0)) )) (defclass simple-generator (generator) ()) (defgeneric generate (gen size &rest ctxt &key &allow-other-keys) (:method ((gen composite-generator) (size real) &rest ctxt) (let* ((subgens (slot-value gen 'subgenerators)) (n (fill-pointer subgens))) (when (<= n 0) (return-from generate (values nil nil))) (let* ((cum-weights (slot-value gen 'cumulative-weights)) (total-weight (aref cum-weights (1- n))) (random-weight (random total-weight)) ;; Replace POSITION call with a binary search if necessary (index (position random-weight cum-weights :test #'>=))) (loop for i from 1 to 10 do (multiple-value-bind (val success?) (apply #'generate (aref subgens index) size ctxt) (when success? (return (values val t)))) finally (return (values nil nil)))))) ) (defmethod generate ((gen symbol) size &rest ctxt &key &allow-other-keys) (apply #'generate (prototype gen) size ctxt)) (defgeneric add-subgenerator (gen subgen weight) (:method ((gen composite-generator) (subgen generator) weight) (let* ((subgens (slot-value gen 'subgenerators)) (n (fill-pointer subgens)) (cum-weights (slot-value gen 'cumulative-weights)) (total-weight (if (> n 0) (aref cum-weights (1- n)) 0.0f0))) (vector-push-extend gen subgens n) (vector-push-extend (+ total-weight weight) cum-weights n) (values)))) (defclass iterative-generator (generator) ((subgenerator :initarg :sub))) (defclass random-iterative-generator (iterative-generator) ()) (defmethod generate ((gen random-iterative-generator) size &rest ctxt) (if (<= size 1) nil (let ((subgen (slot-value gen 'subgenerator)) (subsizes (randomly-partition (1- size) (min (isqrt size) 10)))) (loop for subsize in subsizes for (element success) = (multiple-value-list (apply #'generate subgen subsize ctxt)) when success collect element)))) ;;; Macro for defining simple generator objects ;;; BODY is the body of the method with arguments (gen ctxt size) ;;; for computing the result. Inside the body the function FAIL causes ;;; the generator to return (nil nil). (defmacro defgenerator (name &key keys body (superclass 'simple-generator) slots) (let ((rtag (gensym))) (unless (listp keys) (setf keys (list keys))) `(progn (defclass ,name (,superclass) ,slots) (defmethod generate ((gen ,name) (size real) &rest ctxt &key ,@keys) (declare (ignorable gen size ctxt)) (block ,rtag (flet ((fail () (return-from ,rtag (values nil nil)))) ,body)))))) gcl27-2.7.0/ansi-tests/rctest/lambda-generator.lsp000066400000000000000000000017061454061450500217700ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jun 9 20:57:34 2003 ;;;; Contains: Generators for lambda expressions (in-package :rctest) (compile-and-load "generator.lsp") (defgenerator lambda-list-generator :body (let ((vars (loop for i from 1 to size collect (gensym)))) (values vars t vars))) (defvar *lambda-list-generator* (make-instance 'lambda-list-generator)) (defgenerator lambda-generator.1 :keys (vars) :body (let* ((s1 (random (min 5 size))) (s2 (- size s1))) (multiple-value-bind (lambda-list success1 lambda-vars) (apply #'generate *lambda-list-generator* s1 ctxt) (let ((vars (append (mapcar #'list lambda-vars) vars))) (multiple-value-bind (body success2) (apply #'generate 'implicit-progn-generator s2 :vars vars ctxt) (if (and success1 success2) (values `(lambda ,lambda-list ,@body)) (values nil nil))))))) (defvar *lambda-generator* (make-instance 'lambda-generator.1)) gcl27-2.7.0/ansi-tests/rctest/load.lsp000066400000000000000000000006011454061450500174740ustar00rootroot00000000000000;;; Compile and load the rctest system (load "../compile-and-load.lsp") (load "../rt-package.lsp") (compile-and-load "../rt.lsp") (load "../cl-test-package.lsp") (compile-and-load "../random-aux.lsp") (load "rctest-package.lsp") (compile-and-load "rctest-util.lsp") (compile-and-load "generator.lsp") (compile-and-load "lambda-generator.lsp") (compile-and-load "form-generators.lsp") gcl27-2.7.0/ansi-tests/rctest/makefile000066400000000000000000000001051454061450500175340ustar00rootroot00000000000000 clean: rm -f test.out *.fasl *.o *.so *~ *.fn *.x86f *.fasl *.ufsl gcl27-2.7.0/ansi-tests/rctest/rctest-package.lsp000066400000000000000000000004441454061450500214570ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Jun 6 16:46:31 2003 ;;;; Contains: Definition of the RCTEST package (defpackage :rctest (:use :cl :cl-test) (:import-from "COMMON-LISP-USER" #:compile-and-load) (:export #:generate )) ;; (in-package :rctest) gcl27-2.7.0/ansi-tests/rctest/rctest-util.lsp000066400000000000000000000011161454061450500210360ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jun 7 21:42:23 2003 ;;;; Contains: Utility functions for RCTEST (in-package :rctest) (defun randomly-partition (size &optional (limit 1)) "Return a randomly generated list of positive integers whose sum is SIZE. Try to make no element be < LIMIT." (declare (type unsigned-byte size limit)) (let ((result nil)) (loop while (> size 0) do (let* ((e0 (min size (max limit (1+ (min (random size) (random size))))))) (push e0 result) (decf size e0))) (random-permute result))) gcl27-2.7.0/ansi-tests/read-byte.lsp000066400000000000000000000101361454061450500171310ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 17 17:30:49 2004 ;;;; Contains: Tests of READ-BYTE, WRITE-BYTE (in-package :cl-test) (deftest read-byte.1 (let ((s (open "foo.txt" :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)))) (values (write-byte 17 s) (close s) (progn (setq s (open "foo.txt" :direction :input :element-type '(unsigned-byte 8))) (read-byte s)) (close s))) 17 t 17 t) (deftest read-byte.2 (let ((s (open "foo.txt" :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)))) (values (close s) (progn (setq s (open "foo.txt" :direction :input :element-type '(unsigned-byte 8))) (read-byte s nil 'foo)) (read-byte s nil) (close s))) t foo nil t) (deftest read-byte.3 (loop with b1 = 0 and b2 = 0 for i from 1 to 32 do (let ((s (open "foo.txt" :direction :output :if-exists :supersede :element-type `(unsigned-byte ,i)))) (write-byte (1- (ash 1 i)) s) (write-byte 1 s) (close s)) unless (let ((s (open "foo.txt" :direction :input :element-type `(unsigned-byte ,i)))) (prog1 (and (eql (setq b1 (read-byte s)) (1- (ash 1 i))) (eql (setq b2 (read-byte s)) 1)) (close s))) collect (list i b1 b2)) nil) (deftest read-byte.4 (loop with b1 = 0 and b2 = 0 for i from 33 to 200 by 7 do (let ((s (open "foo.txt" :direction :output :if-exists :supersede :element-type `(unsigned-byte ,i)))) (write-byte (1- (ash 1 i)) s) (write-byte 1 s) (close s)) unless (let ((s (open "foo.txt" :direction :input :element-type `(unsigned-byte ,i)))) (prog1 (and (eql (setq b1 (read-byte s)) (1- (ash 1 i))) (eql (setq b2 (read-byte s)) 1)) (close s))) collect (list i b1 b2)) nil) ;;; Error tests (deftest read-byte.error.1 (signals-error (read-byte) program-error) t) (deftest read-byte.error.2 (progn (let ((s (open "foo.txt" :direction :output :if-exists :supersede :element-type `(unsigned-byte 8)))) (close s)) (signals-error (let ((s (open "foo.txt" :direction :input :element-type '(unsigned-byte 8)))) (read-byte s)) end-of-file)) t) (deftest read-byte.error.3 (progn (let ((s (open "foo.txt" :direction :output :if-exists :supersede))) (close s)) (signals-error (let ((s (open "foo.txt" :direction :input))) (unwind-protect (read-byte s) (close s))) error)) t) (deftest read-byte.error.4 (signals-error-always (progn (let ((s (open "foo.txt" :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)))) (close s)) (let ((s (open "foo.txt" :direction :input :element-type '(unsigned-byte 8)))) (unwind-protect (read-byte s t) (close s)))) end-of-file) t t) (deftest read-byte.error.5 (check-type-error #'read-byte #'streamp) nil) (deftest read-byte.error.6 (progn (let ((s (open "foo.txt" :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)))) (close s)) (signals-error (let ((s (open "foo.txt" :direction :input :element-type '(unsigned-byte 8)))) (unwind-protect (read-byte s t t nil) (close s))) program-error)) t) (deftest write-byte.error.1 (signals-error (write-byte) program-error) t) (deftest write-byte.error.2 (signals-error (write-byte 0) program-error) t) (deftest write-byte.error.3 (signals-error (let ((s (open "foo.txt" :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)))) (unwind-protect (write 1 s nil) (close s))) program-error) t) (deftest write-byte.error.4 (check-type-error #'(lambda (x) (write-byte 0 x)) #'streamp) nil) (deftest write-byte.error.5 (signals-error (let ((s (open "foo.txt" :direction :output :if-exists :supersede))) (unwind-protect (write 1 s) (close s))) error) t) gcl27-2.7.0/ansi-tests/read-char-no-hang.lsp000066400000000000000000000047501454061450500204350ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 18 20:32:38 2004 ;;;; Contains: Tests of READ-CHAR-NO-HANG (in-package :cl-test) (deftest read-char-no-hang.1 (with-input-from-string (*standard-input* "a") (read-char-no-hang)) #\a) (deftest read-char-no-hang.2 (with-input-from-string (*standard-input* "abc") (values (read-char-no-hang) (read-char-no-hang) (read-char-no-hang))) #\a #\b #\c) (when (code-char 0) (deftest read-char-no-hang.3 (with-input-from-string (*standard-input* (concatenate 'string "a" (string (code-char 0)) "b")) (values (read-char-no-hang) (read-char-no-hang) (read-char-no-hang))) #\a #.(code-char 0) #\b)) (deftest read-char-no-hang.4 (with-input-from-string (s "abc") (values (read-char-no-hang s) (read-char-no-hang s) (read-char-no-hang s))) #\a #\b #\c) (deftest read-char-no-hang.5 (with-input-from-string (s "") (read-char-no-hang s nil)) nil) (deftest read-char-no-hang.6 (with-input-from-string (s "") (read-char-no-hang s nil 'foo)) foo) (deftest read-char-no-hang.7 (with-input-from-string (s "abc") (values (read-char-no-hang s nil nil) (read-char-no-hang s nil nil) (read-char-no-hang s nil nil))) #\a #\b #\c) (deftest read-char-no-hang.8 (with-input-from-string (s "abc") (values (read-char-no-hang s nil t) (read-char-no-hang s nil t) (read-char-no-hang s nil t))) #\a #\b #\c) (deftest read-char-no-hang.9 (with-input-from-string (is "!?*") (let ((*terminal-io* (make-two-way-stream is (make-string-output-stream)))) (read-char-no-hang t))) #\!) (deftest read-char-no-hang.10 (with-input-from-string (*standard-input* "345") (read-char-no-hang nil)) #\3) ;;; Need a test of the non-hanging. ;;; This is hard to do portably. ;;; Error tests (deftest read-char-no-hang.error.1 (signals-error (with-input-from-string (s "abc") (read-char-no-hang s nil nil nil nil)) program-error) t) (deftest read-char-no-hang.error.2 (signals-error-always (with-input-from-string (s "") (read-char-no-hang s)) end-of-file) t t) (deftest read-char-no-hang.error.3 (signals-error-always (with-input-from-string (s "") (read-char-no-hang s t)) end-of-file) t t) (deftest read-char-no-hang.error.4 (signals-error-always (with-input-from-string (s "") (read-char-no-hang s t t)) end-of-file) t t) gcl27-2.7.0/ansi-tests/read-char.lsp000066400000000000000000000041531454061450500171050ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 18 08:53:56 2004 ;;;; Contains: Tests of READ-CHAR (in-package :cl-test) (deftest read-char.1 (with-input-from-string (*standard-input* "a") (read-char)) #\a) (deftest read-char.2 (with-input-from-string (*standard-input* "abc") (values (read-char) (read-char) (read-char))) #\a #\b #\c) (when (code-char 0) (deftest read-char.3 (with-input-from-string (*standard-input* (concatenate 'string "a" (string (code-char 0)) "b")) (values (read-char) (read-char) (read-char))) #\a #.(code-char 0) #\b)) (deftest read-char.4 (with-input-from-string (s "abc") (values (read-char s) (read-char s) (read-char s))) #\a #\b #\c) (deftest read-char.5 (with-input-from-string (s "") (read-char s nil)) nil) (deftest read-char.6 (with-input-from-string (s "") (read-char s nil 'foo)) foo) (deftest read-char.7 (with-input-from-string (s "abc") (values (read-char s nil nil) (read-char s nil nil) (read-char s nil nil))) #\a #\b #\c) (deftest read-char.8 (with-input-from-string (s "abc") (values (read-char s nil t) (read-char s nil t) (read-char s nil t))) #\a #\b #\c) (deftest read-char.9 (with-input-from-string (is "!?*") (let ((*terminal-io* (make-two-way-stream is (make-string-output-stream)))) (read-char t))) #\!) (deftest read-char.10 (with-input-from-string (*standard-input* "345") (read-char nil)) #\3) ;;; Error tests (deftest read-char.error.1 (signals-error (with-input-from-string (s "abc") (read-char s nil nil nil nil)) program-error) t) (deftest read-char.error.2 (signals-error-always (with-input-from-string (s "") (read-char s)) end-of-file) t t) (deftest read-char.error.3 (signals-error-always (with-input-from-string (s "") (read-char s t)) end-of-file) t t) (deftest read-char.error.4 (signals-error-always (with-input-from-string (s "") (read-char s t t)) end-of-file) t t) gcl27-2.7.0/ansi-tests/read-delimited-list.lsp000066400000000000000000000030221454061450500210730ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 1 11:17:21 2005 ;;;; Contains: Tests of READ-DELIMITED-LIST (in-package :cl-test) (deftest read-delimited-list.1 (with-input-from-string (*standard-input* "1 2 3)") (read-delimited-list #\))) (1 2 3)) (deftest read-delimited-list.2 (with-input-from-string (*standard-input* "1 2 3 ]") (read-delimited-list #\] nil)) (1 2 3)) (deftest read-delimited-list.3 (with-input-from-string (is "1 2 3)") (with-open-stream (os (make-broadcast-stream)) (with-open-stream (*terminal-io* (make-two-way-stream is os)) (read-delimited-list #\) t)))) (1 2 3)) (deftest read-delimited-list.4 (with-input-from-string (is "1 2 3)X") (values (read-delimited-list #\) is) (notnot (eql (read-char is) #\X)))) (1 2 3) t) (deftest read-delimited-list.5 (with-input-from-string (is "1 2 3) X") (values (read-delimited-list #\) is nil) (notnot (eql (read-char is) #\Space)))) (1 2 3) t) (deftest read-delimited-list.6 (with-input-from-string (is (concatenate 'string "1 2 3" (string #\Newline) "]")) (read-delimited-list #\] is)) (1 2 3)) ;;; Tests with RECURSIVE-P set to true must be done inside a reader macro function ;;; Error tests (deftest read-delimited-list.error.1 (signals-error (read-delimited-list) program-error) t) (deftest read-delimited-list.error.2 (signals-error (with-input-from-string (is "1 2 3)") (read-delimited-list #\) is nil nil)) program-error) t) gcl27-2.7.0/ansi-tests/read-from-string.lsp000066400000000000000000000144111454061450500204350ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 1 14:50:09 2005 ;;;; Contains: Tests of READ-FROM-STRING (in-package :cl-test) (deftest read-from-string.1 (let ((*package* (find-package :cl-test))) (do-special-strings (s "123") (let ((vals (multiple-value-list (read-from-string s)))) (assert (= (length vals) 2)) (assert (eql (first vals) 123)) (assert (member (second vals) '(3 4)))))) nil) (deftest read-from-string.2 (let ((*package* (find-package :cl-test))) (do-special-strings (s "XYZ ") (let ((vals (multiple-value-list (read-from-string s)))) (assert (equal vals '(|XYZ| 4)))))) nil) (deftest read-from-string.3 (let ((*package* (find-package :cl-test))) (do-special-strings (s "(1 2 3)X") (let ((vals (multiple-value-list (read-from-string s)))) (assert (equal vals '((1 2 3) 7)))))) nil) (deftest read-from-string.4 (do-special-strings (s "") (let ((vals (multiple-value-list (read-from-string s nil :good)))) (assert (= (length vals) 2)) (assert (equal (first vals) :good)) (assert (member (second vals) '(0 1))))) nil) (deftest read-from-string.5 (let ((*package* (find-package :cl-test))) (do-special-strings (s "71235") (let ((vals (multiple-value-list (read-from-string s t nil :start 1 :end 4)))) (assert (equal vals '(123 4)))))) nil) (deftest read-from-string.6 (let ((*package* (find-package :cl-test))) (do-special-strings (s "7123 ") (let ((vals (multiple-value-list (read-from-string s t nil :start 1)))) (assert (equal vals '(123 5)))))) nil) (deftest read-from-string.7 (let ((*package* (find-package :cl-test))) (do-special-strings (s "7123 ") (let ((vals (multiple-value-list (read-from-string s t nil :end 4)))) (assert (equal vals '(7123 4)))))) nil) (deftest read-from-string.8 (let ((*package* (find-package :cl-test))) (do-special-strings (s "7123") (let ((vals (multiple-value-list (read-from-string s nil 'foo :start 2 :end 2)))) (assert (equal vals '(foo 2)))))) nil) (deftest read-from-string.9 (let ((*package* (find-package :cl-test))) (do-special-strings (s "123 ") (let ((vals (multiple-value-list (read-from-string s t nil :preserve-whitespace t)))) (assert (equal vals '(123 3)))))) nil) (deftest read-from-string.10 (let ((*package* (find-package :cl-test))) (do-special-strings (s (concatenate 'string "( )" (string #\Newline))) (let ((vals (multiple-value-list (read-from-string s t nil :preserve-whitespace t)))) (assert (equal vals '(nil 3)))))) nil) ;;; Multiple keywords (deftest read-from-string.11 (let ((*package* (find-package :cl-test))) (do-special-strings (s "7123 ") (let ((vals (multiple-value-list (read-from-string s t nil :start 1 :start 2)))) (assert (equal vals '(123 5)))))) nil) (deftest read-from-string.12 (let ((*package* (find-package :cl-test))) (do-special-strings (s "7123 ") (let ((vals (multiple-value-list (read-from-string s t nil :end 4 :end 2)))) (assert (equal vals '(7123 4)))))) nil) (deftest read-from-string.13 (let ((*package* (find-package :cl-test))) (do-special-strings (s (concatenate 'string "( )" (string #\Newline))) (let ((vals (multiple-value-list (read-from-string s t nil :preserve-whitespace t :preserve-whitespace nil)))) (assert (equal vals '(nil 3)))))) nil) ;;; Allow other keys (deftest read-from-string.14 (with-standard-io-syntax (let ((*package* (find-package :cl-test))) (do-special-strings (s "abc ") (let ((vals (multiple-value-list (read-from-string s t nil :allow-other-keys nil)))) (assert (equal vals '(|ABC| 4)) (vals) "VALS is ~A" vals))))) nil) (deftest read-from-string.15 (let ((*package* (find-package :cl-test))) (do-special-strings (s "123 ") (let ((vals (multiple-value-list (read-from-string s t nil :foo 'bar :allow-other-keys t)))) (assert (equal vals '(123 4)) (vals) "VALS is ~A" vals)))) nil) (deftest read-from-string.16 (let ((*package* (find-package :cl-test))) (do-special-strings (s "123 ") (let ((vals (multiple-value-list (read-from-string s t nil :allow-other-keys t :allow-other-keys nil :foo 'bar)))) (assert (equal vals '(123 4)) (vals) "VALS is ~A" vals)))) nil) ;;; default for :end (deftest read-from-string.17 (let ((*package* (find-package :cl-test))) (do-special-strings (s "XYZ ") (let ((vals (multiple-value-list (read-from-string s t nil :end nil)))) (assert (equal vals '(|XYZ| 4)))))) nil) ;;; TODO Add tests for reading from strings containing non-base characters ;;; Error tests (deftest read-from-string.error.1 (signals-error (read-from-string "") error) t) (deftest read-from-string.error.2 (signals-error (read-from-string "(A B ") error) t) (deftest read-from-string.error.3 (signals-error (read-from-string "" t) error) t) (deftest read-from-string.error.4 (signals-error (read-from-string "" t nil) error) t) (deftest read-from-string.error.5 (signals-error (read-from-string "(A B " nil) error) t) (deftest read-from-string.error.6 (signals-error (read-from-string "(A B " t) error) t) (deftest read-from-string.error.7 (signals-error (read-from-string "123" t nil :start 0 :end 0) error) t) (deftest read-from-string.error.8 (signals-error (read-from-string) program-error) t) (deftest read-from-string.error.9 (signals-error (read-from-string "A" nil t :bad-keyword t) program-error) t) (deftest read-from-string.error.10 (signals-error (read-from-string "A" nil t :bad-keyword t :allow-other-keys nil) program-error) t) (deftest read-from-string.error.11 (signals-error (read-from-string "A" nil t :bad-keyword t :allow-other-keys nil :allow-other-keys t) program-error) t) (deftest read-from-string.error.12 (signals-error (read-from-string "A" nil t :allow-other-keys nil :allow-other-keys t :bad-keyword t) program-error) t) (deftest read-from-string.error.13 (signals-error (read-from-string "A" nil t :start) program-error) t) gcl27-2.7.0/ansi-tests/read-line.lsp000066400000000000000000000045311454061450500171170ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 18 20:53:59 2004 ;;;; Contains: Tests of READ-LINE (in-package :cl-test) (deftest read-line.1 (with-input-from-string (*standard-input* " abcd ") (let ((vals (multiple-value-list (read-line)))) (assert (= (length vals) 2)) (values (first vals) (notnot (second vals))))) " abcd " t) (deftest read-line.2 (with-input-from-string (*standard-input* (string #\Newline)) (read-line)) "" nil) (deftest read-line.3 (with-input-from-string (s (concatenate 'string "abc" (string #\Newline))) (read-line s)) "abc" nil) (deftest read-line.4 (with-input-from-string (s "") (let ((vals (multiple-value-list (read-line s nil)))) (assert (= (length vals) 2)) (values (first vals) (notnot (second vals))))) nil t) (deftest read-line.5 (with-input-from-string (s "") (let ((vals (multiple-value-list (read-line s nil 'foo)))) (assert (= (length vals) 2)) (values (first vals) (notnot (second vals))))) foo t) (deftest read-line.6 (with-input-from-string (s " abcd ") (let ((vals (multiple-value-list (read-line s t nil t)))) (assert (= (length vals) 2)) (values (first vals) (notnot (second vals))))) " abcd " t) (deftest read-line.7 (with-input-from-string (is "abc") (let ((*terminal-io* (make-two-way-stream is *standard-output*))) (let ((vals (multiple-value-list (read-line t)))) (assert (= (length vals) 2)) (assert (second vals)) (first vals)))) "abc") (deftest read-line.8 (with-input-from-string (*standard-input* "abc") (let ((vals (multiple-value-list (read-line nil)))) (assert (= (length vals) 2)) (assert (second vals)) (first vals))) "abc") ;;; Error tests (deftest read-line.error.1 (signals-error (with-input-from-string (s (concatenate 'string "abc" (string #\Newline))) (read-line s t nil nil nil)) program-error) t) (deftest read-line.error.2 (signals-error-always (with-input-from-string (s "") (read-line s)) end-of-file) t t) (deftest read-line.error.3 (signals-error-always (with-input-from-string (*standard-input* "") (read-line)) end-of-file) t t) (deftest read-line.error.4 (signals-error-always (with-input-from-string (s "") (read-line s t)) end-of-file) t t) gcl27-2.7.0/ansi-tests/read-preserving-whitespace.lsp000066400000000000000000000105651454061450500225120ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 1 08:54:28 2005 ;;;; Contains: Tests of READ-PRESERVING-WHITESPACE (in-package :cl-test) ;;; Input stream designators (deftest read-preserving-whitespace.1 (block done (with-input-from-string (is "1 2 3") (with-output-to-string (os) (with-open-stream (*terminal-io* (make-two-way-stream is os)) (return-from done (read-preserving-whitespace t)))))) 1) (deftest read-preserving-whitespace.2 (with-input-from-string (*standard-input* "1 2 3") (read-preserving-whitespace nil)) 1) (deftest read-preserving-whitespace.3 (with-input-from-string (*standard-input* "1 2 3") (read-preserving-whitespace)) 1) (deftest read-preserving-whitespace.4 (with-input-from-string (s "1 2 3") (read-preserving-whitespace s)) 1) ;;; eof handling (deftest read-preserving-whitespace.5 (with-input-from-string (s "") (read-preserving-whitespace s nil)) nil) (deftest read-preserving-whitespace.6 (with-input-from-string (s "") (read-preserving-whitespace s nil 'foo)) foo) (deftest read-preserving-whitespace.7 (with-input-from-string (s "1") (read-preserving-whitespace s)) 1) (deftest read-preserving-whitespace.8 (let ((*package* (find-package "CL-TEST"))) (with-input-from-string (s "X") (read-preserving-whitespace s))) |X|) (deftest read-preserving-whitespace.9 (with-input-from-string (s "1.2") (read-preserving-whitespace s)) 1.2) (deftest read-preserving-whitespace.10 (with-input-from-string (s "1.0s0") (read-preserving-whitespace s)) 1.0s0) (deftest read-preserving-whitespace.11 (with-input-from-string (s "1.0f0") (read-preserving-whitespace s)) 1.0f0) (deftest read-preserving-whitespace.12 (with-input-from-string (s "1.0d0") (read-preserving-whitespace s)) 1.0d0) (deftest read-preserving-whitespace.13 (with-input-from-string (s "1.0l0") (read-preserving-whitespace s)) 1.0l0) (deftest read-preserving-whitespace.14 (with-input-from-string (s "()") (read-preserving-whitespace s)) nil) (deftest read-preserving-whitespace.15 (with-input-from-string (s "(1 2 3)") (read-preserving-whitespace s)) (1 2 3)) ;;; Throwing away whitespace chars (deftest read-preserving-whitespace.16 (with-standard-io-syntax (with-input-from-string (s ":ABC X") (assert (eq (read-preserving-whitespace s) :|ABC|)) (read-char s))) #\Space) (deftest read-preserving-whitespace.17 (with-standard-io-syntax (with-input-from-string (s ":ABC X") (assert (eq (read-preserving-whitespace s) :|ABC|)) (read-char s))) #\Space) (deftest read-preserving-whitespace.18 (with-standard-io-syntax (with-input-from-string (s ":ABC(") (assert (eq (read-preserving-whitespace s) :|ABC|)) (read-char s))) #\() ;;; eof value (deftest read-preserving-whitespace.19 (with-input-from-string (s "") (read-preserving-whitespace s nil 'foo)) foo) ;;; Error tests (deftest read-preserving-whitespace.error.1 (signals-error (with-input-from-string (s "") (read-preserving-whitespace s)) end-of-file) t) (deftest read-preserving-whitespace.error.2 (signals-error (with-input-from-string (s "") (read-preserving-whitespace s)) stream-error) t) (deftest read-preserving-whitespace.error.3 (signals-error (with-input-from-string (s "") (read-preserving-whitespace s t)) stream-error) t) (deftest read-preserving-whitespace.error.4 (signals-error (with-input-from-string (s "(") (read-preserving-whitespace s nil)) end-of-file) t) (deftest read-preserving-whitespace.error.5 (signals-error (with-input-from-string (s "(") (read-preserving-whitespace s t)) end-of-file) t) (deftest read-preserving-whitespace.error.6 (signals-error (with-input-from-string (s "#(") (read-preserving-whitespace s t)) end-of-file) t) (deftest read-preserving-whitespace.error.7 (signals-error (with-input-from-string (s "#S(") (read-preserving-whitespace s t)) end-of-file) t) ;;; Note -- cannot easily test calls with RECURSIVE-P set to T. These have to be ;;; done from read-preserving-whitespaceer macro functions so that READ-PRESERVING-WHITESPACE ;;; is not called without having any requisite dynamic environment created ;;; around the call. (deftest read-preserving-whitespace.error.8 (signals-error (with-input-from-string (s "1 2 3") (read-preserving-whitespace s nil nil nil nil)) program-error) t) gcl27-2.7.0/ansi-tests/read-sequence.lsp000066400000000000000000000220531454061450500177770ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 19 06:55:04 2004 ;;;; Contains: Tests of READ-SEQUENCE (in-package :cl-test) ;;; Read into a string (defmacro def-read-sequence-test (name init args input &rest expected) `(deftest ,name (let ((s ,init)) (with-input-from-string (is ,input) (values (read-sequence s is ,@args) s))) ,@expected)) (def-read-sequence-test read-sequence.string.1 (copy-seq " ") () "abcdefghijk" 5 "abcde") (def-read-sequence-test read-sequence.string.2 (copy-seq " ") () "abc" 3 "abc ") (def-read-sequence-test read-sequence.string.3 (copy-seq " ") (:start 1) "abcdefghijk" 5 " abcd") (def-read-sequence-test read-sequence.string.4 (copy-seq " ") (:end 3) "abcdefghijk" 3 "abc ") (def-read-sequence-test read-sequence.string.5 (copy-seq " ") (:start 1 :end 4) "abcdefghijk" 4 " abc ") (def-read-sequence-test read-sequence.string.6 (copy-seq " ") (:start 0 :end 0) "abcdefghijk" 0 " ") (def-read-sequence-test read-sequence.string.7 (copy-seq " ") (:end nil) "abcdefghijk" 5 "abcde") (def-read-sequence-test read-sequence.string.8 (copy-seq " ") (:allow-other-keys nil) "abcdefghijk" 5 "abcde") (def-read-sequence-test read-sequence.string.9 (copy-seq " ") (:allow-other-keys t :foo 'bar) "abcdefghijk" 5 "abcde") (def-read-sequence-test read-sequence.string.10 (copy-seq " ") (:foo 'bar :allow-other-keys 'x) "abcdefghijk" 5 "abcde") (def-read-sequence-test read-sequence.string.11 (copy-seq " ") (:foo 'bar :allow-other-keys 'x :allow-other-keys nil) "abcdefghijk" 5 "abcde") (def-read-sequence-test read-sequence.string.12 (copy-seq " ") (:end 5 :end 3 :start 0 :start 1) "abcdefghijk" 5 "abcde") ;;; Read into a base string (def-read-sequence-test read-sequence.base-string.1 (make-array 5 :element-type 'base-char) () "abcdefghijk" 5 "abcde") (def-read-sequence-test read-sequence.base-string.2 (make-array 5 :element-type 'base-char :initial-element #\Space) () "abc" 3 "abc ") (def-read-sequence-test read-sequence.base-string.3 (make-array 5 :element-type 'base-char :initial-element #\Space) (:start 1) "abcdefghijk" 5 " abcd") (def-read-sequence-test read-sequence.base-string.4 (make-array 5 :element-type 'base-char :initial-element #\Space) (:end 3) "abcdefghijk" 3 "abc ") (def-read-sequence-test read-sequence.base-string.5 (make-array 5 :element-type 'base-char :initial-element #\Space) (:start 1 :end 4) "abcdefghijk" 4 " abc ") (def-read-sequence-test read-sequence.base-string.6 (make-array 5 :element-type 'base-char :initial-element #\Space) (:start 0 :end 0) "abcdefghijk" 0 " ") (def-read-sequence-test read-sequence.base-string.7 (make-array 5 :element-type 'base-char :initial-element #\Space) (:end nil) "abcdefghijk" 5 "abcde") ;;; Read into a list (def-read-sequence-test read-sequence.list.1 (make-list 5) () "abcdefghijk" 5 (#\a #\b #\c #\d #\e)) (def-read-sequence-test read-sequence.list.2 (make-list 5) () "abc" 3 (#\a #\b #\c nil nil)) (def-read-sequence-test read-sequence.list.3 (make-list 5) (:start 1) "abcdefghijk" 5 (nil #\a #\b #\c #\d)) (def-read-sequence-test read-sequence.list.4 (make-list 5) (:end 3) "abcdefghijk" 3 (#\a #\b #\c nil nil)) (def-read-sequence-test read-sequence.list.5 (make-list 5) (:end 4 :start 1) "abcdefghijk" 4 (nil #\a #\b #\c nil)) (def-read-sequence-test read-sequence.list.6 (make-list 5) (:start 0 :end 0) "abcdefghijk" 0 (nil nil nil nil nil)) (def-read-sequence-test read-sequence.list.7 (make-list 5) (:end nil) "abcdefghijk" 5 (#\a #\b #\c #\d #\e)) ;;; Read into a vector (def-read-sequence-test read-sequence.vector.1 (vector nil nil nil nil nil) () "abcdefghijk" 5 #(#\a #\b #\c #\d #\e)) (def-read-sequence-test read-sequence.vector.2 (vector nil nil nil nil nil) () "abc" 3 #(#\a #\b #\c nil nil)) (def-read-sequence-test read-sequence.vector.3 (vector nil nil nil nil nil) (:start 2) "abcdefghijk" 5 #(nil nil #\a #\b #\c)) (def-read-sequence-test read-sequence.vector.4 (vector nil nil nil nil nil) (:start 1 :end 4) "abcdefghijk" 4 #(nil #\a #\b #\c nil)) (def-read-sequence-test read-sequence.vector.5 (vector nil nil nil nil nil) (:end 2) "abcdefghijk" 2 #(#\a #\b nil nil nil)) (def-read-sequence-test read-sequence.vector.6 (vector nil nil nil nil nil) (:end 0 :start 0) "abcdefghijk" 0 #(nil nil nil nil nil)) (def-read-sequence-test read-sequence.vector.7 (vector nil nil nil nil nil) (:end nil) "abcdefghijk" 5 #(#\a #\b #\c #\d #\e)) ;;; Read into a vector with a fill pointer (def-read-sequence-test read-sequence.fill-vector.1 (make-array 10 :initial-element nil :fill-pointer 5) () "abcdefghijk" 5 #(#\a #\b #\c #\d #\e)) (def-read-sequence-test read-sequence.fill-vector.2 (make-array 10 :initial-element nil :fill-pointer 5) () "ab" 2 #(#\a #\b nil nil nil)) (def-read-sequence-test read-sequence.fill-vector.3 (make-array 10 :initial-element nil :fill-pointer 5) () "" 0 #(nil nil nil nil nil)) (def-read-sequence-test read-sequence.fill-vector.4 (make-array 10 :initial-element nil :fill-pointer 5) (:start 2) "abcdefghijk" 5 #(nil nil #\a #\b #\c)) (def-read-sequence-test read-sequence.fill-vector.5 (make-array 10 :initial-element nil :fill-pointer 5) (:start 1 :end 4) "abcdefghijk" 4 #(nil #\a #\b #\c nil)) (def-read-sequence-test read-sequence.fill-vector.6 (make-array 10 :initial-element nil :fill-pointer 5) (:end 2) "abcdefghijk" 2 #(#\a #\b nil nil nil)) (def-read-sequence-test read-sequence.fill-vector.7 (make-array 10 :initial-element nil :fill-pointer 5) (:end 0 :start 0) "abcdefghijk" 0 #(nil nil nil nil nil)) (def-read-sequence-test read-sequence.fill-vector.8 (make-array 10 :initial-element nil :fill-pointer 5) (:end nil) "abcdefghijk" 5 #(#\a #\b #\c #\d #\e)) ;;; Nil vectors (deftest read-sequence.nil-vector.1 :notes (:nil-vectors-are-strings) (let ((s (make-array 0 :element-type nil))) (with-input-from-string (is "abcde") (values (read-sequence s is) s))) 0 "") ;;; Read into a bit vector (defmacro def-read-sequence-bv-test (name init args &rest expected) `(deftest ,name ;; Create output file (progn (let (os) (unwind-protect (progn (setq os (open "temp.dat" :direction :output :element-type '(unsigned-byte 8) :if-exists :supersede)) (loop for i in '(0 1 1 0 0 1 1 0 1 0 1 1 1 0) do (write-byte i os))) (when os (close os)))) (let (is (bv (copy-seq ,init))) (unwind-protect (progn (setq is (open "temp.dat" :direction :input :element-type '(unsigned-byte 8))) (values (read-sequence bv is ,@args) bv)) (when is (close is))))) ,@expected)) (def-read-sequence-bv-test read-sequence.bv.1 #*00000000000000 () 14 #*01100110101110) (def-read-sequence-bv-test read-sequence.bv.2 #*00000000000000 (:start 0) 14 #*01100110101110) (def-read-sequence-bv-test read-sequence.bv.3 #*00000000000000 (:end 14) 14 #*01100110101110) (def-read-sequence-bv-test read-sequence.bv.4 #*00000000000000 (:end nil) 14 #*01100110101110) (def-read-sequence-bv-test read-sequence.bv.5 #*00000000000000 (:start 2) 14 #*00011001101011) (def-read-sequence-bv-test read-sequence.bv.6 #*00000000000000 (:start 2 :end 13) 13 #*00011001101010) (def-read-sequence-bv-test read-sequence.bv.7 #*00000000000000 (:end 6) 6 #*01100100000000) ;;; Error cases (deftest read-sequence.error.1 (signals-error (read-sequence) program-error) t) (deftest read-sequence.error.2 (signals-error (read-sequence (make-string 10)) program-error) t) (deftest read-sequence.error.3 (signals-error (read-sequence (make-string 5) (make-string-input-stream "abc") :start) program-error) t) (deftest read-sequence.error.4 (signals-error (read-sequence (make-string 5) (make-string-input-stream "abc") :foo 1) program-error) t) (deftest read-sequence.error.5 (signals-error (read-sequence (make-string 5) (make-string-input-stream "abc") :allow-other-keys nil :bar 2) program-error) t) (deftest read-sequence.error.6 (check-type-error #'(lambda (x) (read-sequence x (make-string-input-stream "abc"))) #'sequencep) nil) (deftest read-sequence.error.7 (signals-error (read-sequence (cons 'a 'b) (make-string-input-stream "abc")) type-error) t) ;;; This test appears to cause Allegro CL to crash (deftest read-sequence.error.8 (signals-type-error x -1 (read-sequence (make-string 3) (make-string-input-stream "abc") :start x)) t) (deftest read-sequence.error.9 (check-type-error #'(lambda (s) (read-sequence (make-string 3) (make-string-input-stream "abc") :start s)) (typef 'unsigned-byte)) nil) (deftest read-sequence.error.10 (signals-type-error x -1 (read-sequence (make-string 3) (make-string-input-stream "abc") :end x)) t) (deftest read-sequence.error.11 (check-type-error #'(lambda (e) (read-sequence (make-string 3) (make-string-input-stream "abc") :end e)) (typef '(or unsigned-byte null))) nil) gcl27-2.7.0/ansi-tests/read-suppress.lsp000066400000000000000000000266671454061450500200720ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 15 13:55:27 2005 ;;;; Contains: Tests of reading with *READ-SUPPRESS* bound to true (in-package :cl-test) (compile-and-load "reader-aux.lsp") (defmacro def-read-suppress-test (name string) `(def-syntax-test ,name (let ((*read-suppress* t)) (read-from-string ,string)) nil ,(length string))) (def-read-suppress-test read-suppress.1 "NONEXISTENT-PACKAGE::FOO") (def-read-suppress-test read-suppress.2 ":") (def-read-suppress-test read-suppress.3 "::") (def-read-suppress-test read-suppress.4 ":::") (def-read-suppress-test read-suppress.5 "123.45") ;; (def-read-suppress-test read-suppress.6 ".") (def-read-suppress-test read-suppress.7 "..") (def-read-suppress-test read-suppress.8 "...") (def-read-suppress-test read-suppress.9 "(1 2)") (def-read-suppress-test read-suppress.10 "(1 . 2)") (def-read-suppress-test read-suppress.11 "(1 .. 2 . 3)") (def-read-suppress-test read-suppress.12 "(...)") (defparameter *non-macro-chars* "1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ-=+_~!@$%^&*{}[]<>/?.") (declaim (type simple-base-string *non-macro-chars*)) (defmacro def-random-suppress-test (name &key (chars '*non-macro-chars*) (reps 1000) (maxlen 8) (count 10) (prefix "") (suffix "")) `(def-syntax-test ,name (let* ((chars ,chars) (prefix ,prefix) (suffix ,suffix) (*read-suppress* t) (count 0) (maxlen ,maxlen) (reps ,reps) (maxcount ,count)) (loop for n = (1+ (random maxlen)) for s = (concatenate 'string prefix (loop repeat n collect (random-from-seq chars)) suffix) for vals = (multiple-value-list (handler-case (read-from-string s) (reader-error (rc) rc))) repeat reps unless (equal vals (list nil (length s))) collect (progn (when (> (incf count) maxcount) (loop-finish)) (list n s vals)))) nil)) (def-random-suppress-test read-suppress.13) (def-random-suppress-test read-suppress.14 :prefix "(" :suffix ")") (def-random-suppress-test read-suppress.15 :prefix "#(" :suffix ")") (def-random-suppress-test read-suppress.16 :chars "0123456789.eEfFsSdDlL+-") (def-read-suppress-test read-suppress.sharp-slash.1 "#\\boguscharname") (def-read-suppress-test read-suppress.sharp-slash.2 "#\\:x") (def-read-suppress-test read-suppress.sharp-slash.3 "#\\::::") (def-read-suppress-test read-suppress.sharp-slash.4 "#\\123") (def-read-suppress-test read-suppress.sharp-slash.5 "#0\\ ") (def-read-suppress-test read-suppress.sharp-slash.6 "#100000000\\Space") (def-read-suppress-test read-suppress.sharp-quote.1 "#'foo") (def-read-suppress-test read-suppress.sharp-quote.2 "#'1") (def-read-suppress-test read-suppress.sharp-quote.3 "#'(setf bar)") (def-read-suppress-test read-suppress.sharp-quote.5 "#'.") (def-read-suppress-test read-suppress.sharp-quote.6 "#'1.2.3") (def-read-suppress-test read-suppress.sharp-quote.7 "#0'F") (def-read-suppress-test read-suppress.sharp-quote.8 "#1000000'F") (def-read-suppress-test read-suppress.sharp-left-paren.1 "#()") (def-read-suppress-test read-suppress.sharp-left-paren.2 "#(A)") (def-read-suppress-test read-suppress.sharp-left-paren.3 "#(A B)") (def-read-suppress-test read-suppress.sharp-left-paren.4 "#0()") (def-read-suppress-test read-suppress.sharp-left-paren.5 "#0(A)") (def-read-suppress-test read-suppress.sharp-left-paren.6 "#1(A)") (def-read-suppress-test read-suppress.sharp-left-paren.7 "#1(A B C D E)") (def-read-suppress-test read-suppress.sharp-left-paren.8 "#4(A B C D E)") (def-read-suppress-test read-suppress.sharp-left-paren.9 "#10(A B C D E)") (def-read-suppress-test read-suppress.sharp-left-paren.10 "#100()") (def-read-suppress-test read-suppress.sharp-left-paren.11 "#10000000000000()") (def-read-suppress-test read-suppress.sharp-left-paren.12 "#10000000000000(A)") (def-read-suppress-test read-suppress.sharp-asterisk.1 "#*") (def-read-suppress-test read-suppress.sharp-asterisk.2 "#0*") (def-read-suppress-test read-suppress.sharp-asterisk.3 "#*1") (def-read-suppress-test read-suppress.sharp-asterisk.4 "#*0111001") (def-read-suppress-test read-suppress.sharp-asterisk.5 "#*73298723497132") (def-read-suppress-test read-suppress.sharp-asterisk.6 "#*abcdefghijklmnopqrstuvwxyz") (def-read-suppress-test read-suppress.sharp-asterisk.7 "#*ABCDEFGHIJKLMNOPQRSTUVWXYZ") (def-read-suppress-test read-suppress.sharp-asterisk.8 "#*:") (def-read-suppress-test read-suppress.sharp-asterisk.9 "#*::::") (def-read-suppress-test read-suppress.sharp-asterisk.10 "#1*") (def-read-suppress-test read-suppress.sharp-asterisk.11 "#10000*") (def-read-suppress-test read-suppress.sharp-asterisk.12 "#10000000000000*") (def-read-suppress-test read-suppress.sharp-asterisk.13 "#4*001101001") (def-read-suppress-test read-suppress.sharp-asterisk.14 "#2*") (def-read-suppress-test read-suppress.sharp-colon.1 "#:1") (def-read-suppress-test read-suppress.sharp-colon.2 "#:foo") (def-read-suppress-test read-suppress.sharp-colon.3 "#0:1/2") (def-read-suppress-test read-suppress.sharp-colon.4 "#10:-2") (def-read-suppress-test read-suppress.sharp-colon.5 "#100000000000:x") (def-read-suppress-test read-suppress.sharp-colon.6 "#3:foo") (def-read-suppress-test read-suppress.sharp-colon.7 "#::") (def-read-suppress-test read-suppress.sharp-colon.8 "#:123") (def-read-suppress-test read-suppress.sharp-colon.9 "#:.") (def-read-suppress-test read-suppress.sharp-dot.1 "#.1") (def-read-suppress-test read-suppress.sharp-dot.2 "#.#:foo") (def-read-suppress-test read-suppress.sharp-dot.3 "#.(throw 'foo nil)") (def-read-suppress-test read-suppress.sharp-dot.4 "#0.1") (def-read-suppress-test read-suppress.sharp-dot.5 "#10.1") (def-read-suppress-test read-suppress.sharp-dot.6 "#1000000000000000.1") (def-read-suppress-test read-suppress.sharp-b.1 "#b0") (def-read-suppress-test read-suppress.sharp-b.2 "#B1") (def-read-suppress-test read-suppress.sharp-b.3 "#BX") (def-read-suppress-test read-suppress.sharp-b.4 "#b.") (def-read-suppress-test read-suppress.sharp-b.5 "#0b0") (def-read-suppress-test read-suppress.sharp-b.6 "#1B1") (def-read-suppress-test read-suppress.sharp-b.7 "#100b010") (def-read-suppress-test read-suppress.sharp-b.8 "#1000000000000b010") (def-read-suppress-test read-suppress.sharp-b.9 "#B101/100") (def-read-suppress-test read-suppress.sharp-b.10 "#b101/100/11") (def-read-suppress-test read-suppress.sharp-o.1 "#o0") (def-read-suppress-test read-suppress.sharp-o.2 "#O1") (def-read-suppress-test read-suppress.sharp-o.3 "#OX") (def-read-suppress-test read-suppress.sharp-o.4 "#o.") (def-read-suppress-test read-suppress.sharp-o.5 "#od6") (def-read-suppress-test read-suppress.sharp-o.6 "#1O9") (def-read-suppress-test read-suppress.sharp-o.7 "#100O010") (def-read-suppress-test read-suppress.sharp-o.8 "#1000000000000o27423") (def-read-suppress-test read-suppress.sharp-o.9 "#O123/457") (def-read-suppress-test read-suppress.sharp-o.10 "#o12/17/21") (def-read-suppress-test read-suppress.sharp-c.1 "#c(0 0)") (def-read-suppress-test read-suppress.sharp-c.2 "#C(1.0 1.0)") (def-read-suppress-test read-suppress.sharp-c.3 "#cFOO") (def-read-suppress-test read-suppress.sharp-c.4 "#c1") (def-read-suppress-test read-suppress.sharp-c.5 "#C(1 2 3)") (def-read-suppress-test read-suppress.sharp-c.6 "#c.") (def-read-suppress-test read-suppress.sharp-c.7 "#c()") (def-read-suppress-test read-suppress.sharp-c.8 "#c(1)") (def-read-suppress-test read-suppress.sharp-c.9 "#C(1 . 2)") (def-read-suppress-test read-suppress.sharp-c.10 "#c(1 2 3)") (def-read-suppress-test read-suppress.sharp-c.11 "#0c(1 2)") (def-read-suppress-test read-suppress.sharp-c.12 "#1C(1 2)") (def-read-suppress-test read-suppress.sharp-c.13 "#10c(1 2)") (def-read-suppress-test read-suppress.sharp-c.14 "#123456789c(1 2)") (def-read-suppress-test read-suppress.sharp-c.15 "#c(..)") (def-read-suppress-test read-suppress.sharp-x.1 "#x0") (def-read-suppress-test read-suppress.sharp-x.2 "#X1") (def-read-suppress-test read-suppress.sharp-x.3 "#XX") (def-read-suppress-test read-suppress.sharp-x.4 "#x.") (def-read-suppress-test read-suppress.sharp-x.5 "#xy6") (def-read-suppress-test read-suppress.sharp-x.6 "#1X9") (def-read-suppress-test read-suppress.sharp-x.7 "#100X010") (def-read-suppress-test read-suppress.sharp-x.8 "#1000000000000x2af23") (def-read-suppress-test read-suppress.sharp-x.9 "#X123/DE7") (def-read-suppress-test read-suppress.sharp-x.10 "#x12/17/21") (def-read-suppress-test read-suppress.sharp-r.1 "#2r1101") (def-read-suppress-test read-suppress.sharp-r.2 "#10R9871") (def-read-suppress-test read-suppress.sharp-r.3 "#36r721zwoqnASLDKJA22") (def-read-suppress-test read-suppress.sharp-r.4 "#r.") (def-read-suppress-test read-suppress.sharp-r.5 "#2r379ze") (def-read-suppress-test read-suppress.sharp-r.6 "#0r0") (def-read-suppress-test read-suppress.sharp-r.7 "#1r0") (def-read-suppress-test read-suppress.sharp-r.8 "#100r0A") (def-read-suppress-test read-suppress.sharp-r.9 "#1000000000000r0A") (def-read-suppress-test read-suppress.sharp-r.10 "#2r!@#$%^&*_-+={}[]:<>.?/") (def-read-suppress-test read-suppress.sharp-a.1 "#a()") (def-read-suppress-test read-suppress.sharp-a.2 "#2a((a)(b c))") (def-read-suppress-test read-suppress.sharp-a.3 "#a1") (def-read-suppress-test read-suppress.sharp-a.4 "#1a1") (def-read-suppress-test read-suppress.sharp-a.5 "#10a(a b c)") (def-read-suppress-test read-suppress.sharp-a.6 "#100a(a b c)") (def-read-suppress-test read-suppress.sharp-a.7 "#10000000000000a(a b c)") (def-read-suppress-test read-suppress.sharp-a.8 "#a..") (def-read-suppress-test read-suppress.sharp-a.9 "#a(...)") (def-read-suppress-test read-suppress.sharp-s.1 "#s()") (def-read-suppress-test read-suppress.sharp-s.2 "#S(invalid-sname)") (def-read-suppress-test read-suppress.sharp-s.3 "#s(..)") (def-read-suppress-test read-suppress.sharp-s.4 "#S(foo bar)") (def-read-suppress-test read-suppress.sharp-s.5 "#0s()") (def-read-suppress-test read-suppress.sharp-s.6 "#1S()") (def-read-suppress-test read-suppress.sharp-s.7 "#10s()") (def-read-suppress-test read-suppress.sharp-s.8 "#271S()") (def-read-suppress-test read-suppress.sharp-s.9 "#712897459812s()") (def-read-suppress-test read-suppress.sharp-p.1 "#p\"\"") (def-read-suppress-test read-suppress.sharp-p.2 "#P123") (def-read-suppress-test read-suppress.sharp-p.3 "#p1/3") (def-read-suppress-test read-suppress.sharp-p.4 "#0P\"\"") (def-read-suppress-test read-suppress.sharp-p.5 "#1p\"\"") (def-read-suppress-test read-suppress.sharp-p.6 "#100P\"\"") (def-read-suppress-test read-suppress.sharp-p.7 "#1234567890p\"\"") (def-read-suppress-test read-suppress.sharp-equal.1 "#=nil") (def-read-suppress-test read-suppress.sharp-equal.2 "#1=nil") (def-read-suppress-test read-suppress.sharp-equal.3 "#100=nil") (def-read-suppress-test read-suppress.sharp-equal.4 "(#1=nil #1=nil)") (def-read-suppress-test read-suppress.sharp-sharp.1 "##") (def-read-suppress-test read-suppress.sharp-sharp.2 "#1#") (def-read-suppress-test read-suppress.sharp-sharp.3 "#100#") (def-read-suppress-test read-suppress.sharp-sharp.4 "#123456789#") ;;; Error cases (def-syntax-test read-suppress.error.1 (signals-error (let ((*read-suppress* t)) (read-from-string "')")) reader-error) t) (def-syntax-test read-suppress.error.2 (signals-error (let ((*read-suppress* t)) (read-from-string "#<")) reader-error) t) (def-syntax-test read-suppress.error.3 (signals-error (let ((*read-suppress* t)) (read-from-string "# ")) reader-error) t) (def-syntax-test read-suppress.error.4 (signals-error (let ((*read-suppress* t)) (read-from-string "#)")) reader-error) t) gcl27-2.7.0/ansi-tests/read.lsp000066400000000000000000000062111454061450500161670ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Dec 31 07:52:06 2004 ;;;; Contains: Tests of READ (in-package :cl-test) ;;; Input stream designators (deftest read.1 (block done (with-input-from-string (is "1 2 3") (with-output-to-string (os) (with-open-stream (*terminal-io* (make-two-way-stream is os)) (return-from done (read t)))))) 1) (deftest read.2 (with-input-from-string (*standard-input* "1 2 3") (read nil)) 1) (deftest read.3 (with-input-from-string (*standard-input* "1 2 3") (read)) 1) (deftest read.4 (with-input-from-string (s "1 2 3") (read s)) 1) ;;; eof handling (deftest read.5 (with-input-from-string (s "") (read s nil)) nil) (deftest read.6 (with-input-from-string (s "") (read s nil 'foo)) foo) (deftest read.7 (with-input-from-string (s "1") (read s)) 1) (deftest read.8 (let ((*package* (find-package "CL-TEST"))) (with-input-from-string (s "X") (read s))) |X|) (deftest read.9 (with-input-from-string (s "1.2") (read s)) 1.2) (deftest read.10 (with-input-from-string (s "1.0s0") (read s)) 1.0s0) (deftest read.11 (with-input-from-string (s "1.0f0") (read s)) 1.0f0) (deftest read.12 (with-input-from-string (s "1.0d0") (read s)) 1.0d0) (deftest read.13 (with-input-from-string (s "1.0l0") (read s)) 1.0l0) (deftest read.14 (with-input-from-string (s "()") (read s)) nil) (deftest read.15 (with-input-from-string (s "(1 2 3)") (read s)) (1 2 3)) ;;; Throwing away whitespace chars (deftest read.16 (with-standard-io-syntax (with-input-from-string (s ":ABC X") (assert (eq (read s) :|ABC|)) (read-char s))) #\X) (deftest read.17 (with-standard-io-syntax (with-input-from-string (s ":ABC X") (assert (eq (read s) :|ABC|)) (read-char s))) #\Space) (deftest read.18 (with-standard-io-syntax (with-input-from-string (s ":ABC(") (assert (eq (read s) :|ABC|)) (read-char s))) #\() ;;; eof value (deftest read.19 (with-input-from-string (s "") (read s nil 'foo)) foo) ;;; Error tests (deftest read.error.1 (signals-error (with-input-from-string (s "") (read s)) end-of-file) t) (deftest read.error.2 (signals-error (with-input-from-string (s "") (read s)) stream-error) t) (deftest read.error.3 (signals-error (with-input-from-string (s "") (read s t)) stream-error) t) (deftest read.error.4 (signals-error (with-input-from-string (s "(") (read s nil)) end-of-file) t) (deftest read.error.5 (signals-error (with-input-from-string (s "(") (read s t)) end-of-file) t) (deftest read.error.6 (signals-error (with-input-from-string (s "#(") (read s t)) end-of-file) t) (deftest read.error.7 (signals-error (with-input-from-string (s "#S(") (read s t)) end-of-file) t) ;;; Note -- cannot easily test calls with RECURSIVE-P set to T ;;; These have to be done from reader macro functions so that READ is not ;;; called without having any requisite dynamic environment created ;;; around the call. (deftest read.error.8 (signals-error (with-input-from-string (s "1 2 3") (read s nil nil nil nil)) program-error) t) gcl27-2.7.0/ansi-tests/reader-aux.lsp000066400000000000000000000030051454061450500173070ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Jan 14 07:43:48 2005 ;;;; Contains: Auxiliary functions and macros for reader tests (in-package :cl-test) ;;; Define a test using standard io syntax (defmacro def-syntax-test (name form &body expected-results) `(deftest ,name (with-standard-io-syntax (let ((*package* (find-package :cl-test))) ,form)) ,@expected-results)) ;;; Macros for testing specific features (defmacro def-syntax-vector-test (name form &body expected-elements) `(def-syntax-test ,name (let ((v (read-from-string ,form))) (assert (simple-vector-p v)) v) ,(apply #'vector expected-elements))) (defmacro def-syntax-bit-vector-test (name form &body expected-elements) `(def-syntax-test ,name (let ((v (read-from-string ,form))) (assert (simple-bit-vector-p v)) v) ,(make-array (length expected-elements) :element-type 'bit :initial-contents expected-elements))) (defmacro def-syntax-unintern-test (name string) `(deftest ,name (let ((s (read-from-string ,(concatenate 'string "#:" string)))) (values (symbol-package s) (symbol-name s))) nil ,(string-upcase string))) (defmacro def-syntax-array-test (name form expected-result) `(def-syntax-test ,name (let ((v (read-from-string ,form))) (assert (typep v 'simple-array)) (assert (not (array-has-fill-pointer-p v))) (assert (eql (array-element-type v) (upgraded-array-element-type t))) v) ,(eval expected-result))) gcl27-2.7.0/ansi-tests/reader-test.lsp000066400000000000000000000176121454061450500175020ustar00rootroot00000000000000;-*- 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) (compile-and-load "reader-aux.lsp") (def-syntax-test read-symbol.1 (read-from-string "a") a 1) (def-syntax-test read-symbol.2 (read-from-string "|a|") |a| 3) (def-syntax-test read-symbol.3 (multiple-value-bind (s n) (read-from-string "#:abc") (not (and (symbolp s) (eql n 5) (not (symbol-package s)) (string-equal (symbol-name s) "abc")))) nil) (def-syntax-test read-symbol.4 (multiple-value-bind (s n) (read-from-string "#:|abc|") (not (and (symbolp s) (eql n 7) (not (symbol-package s)) (string= (symbol-name s) "abc")))) nil) (def-syntax-test read-symbol.5 (multiple-value-bind (s n) (read-from-string "#:||") (if (not (symbolp s)) s (not (not (and (eql n 4) (not (symbol-package s)) (string= (symbol-name s) "")))))) t) (def-syntax-test read-symbol.6 (let ((str "cl-test::abcd0123")) (multiple-value-bind (s n) (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) (def-syntax-test read-symbol.7 (multiple-value-bind (s n) (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 &optional (chars +standard-chars+)) (loop repeat 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 (random-from-seq chars))) (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) (read-from-string (concatenate 'string "#:|" actual-string "|")) (unless (and (symbolp sym) (eql nread (+ 4 actual-len)) (string-equal s2 (symbol-name sym))) (let ((*print-readably* t)) (format t "Symbol read failed: ~S (~S) read as ~S~%" actual-string s2 sym)) t)))))) (def-syntax-test read-symbol.9 (read-symbol.9-body 1000 100) 0) (def-syntax-test read-symbol.9a (let ((chars (coerce (loop for i below (min 256 char-code-limit) for c = (code-char i) when c collect c) 'string))) (if (> (length chars) 0) (read-symbol.9-body 1000 100) 0)) 0) (def-syntax-test read-symbol.9b (let ((chars (coerce (loop for i below (min 65536 char-code-limit) for c = (code-char i) when c collect c) 'string))) (if (> (length chars) 0) (read-symbol.9-body 1000 100) 0)) 0) (def-syntax-test read-symbol.10 (equalt (symbol-name (read-from-string (with-output-to-string (s) (write (make-symbol ":") :readably t :stream s)))) ":") t) (def-syntax-test read-symbol.11 (loop for c across +standard-chars+ for str = (make-array 2 :element-type 'character :initial-contents (list #\\ c)) for sym = (read-from-string str) unless (and (symbolp sym) (eql sym (find-symbol (string c))) (equal (symbol-name sym) (string c))) collect (list c str sym)) nil) (def-syntax-test read-symbol.12 (loop for c across +standard-chars+ for str = (make-array 2 :element-type 'base-char :initial-contents (list #\\ c)) for sym = (read-from-string str) unless (and (symbolp sym) (eql sym (find-symbol (string c))) (equal (symbol-name sym) (string c))) collect (list c str sym)) nil) (def-syntax-test read-symbol.13 (loop for i below (min 65536 char-code-limit) for c = (code-char i) for str = (and c (make-array 2 :element-type 'character :initial-contents (list #\\ c))) for sym = (and c (read-from-string str)) unless (or (not c) (and (symbolp sym) (eql sym (find-symbol (string c))) (equal (symbol-name sym) (string c)))) collect (list c str sym)) nil) (def-syntax-test read-symbol.14 (loop for i = (random (min (ash 1 24) char-code-limit)) for c = (code-char i) for str = (and c (make-array 2 :element-type 'character :initial-contents (list #\\ c))) for sym = (and c (read-from-string str)) repeat 1000 unless (or (not c) (and (symbolp sym) (eql sym (find-symbol (string c))) (equal (symbol-name sym) (string c)))) collect (list c str sym)) nil) (def-syntax-test read-symbol.15 (loop for c across "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!@$%^&*_-+={}[]<>?/~" for str = (string c) for sym = (read-from-string str) unless (eql sym (find-symbol (string (char-upcase c)))) collect (list c str sym)) nil) (def-syntax-test read-symbol.16 (let ((*readtable* (copy-readtable))) (setf (readtable-case *readtable*) :downcase) (loop for c across "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!@$%^&*_-+={}[]<>?/~" for str = (string c) for sym = (read-from-string str) unless (eql sym (find-symbol (string (char-downcase c)))) collect (list c str sym))) nil) (def-syntax-test read-symbol.17 (let ((*readtable* (copy-readtable))) (setf (readtable-case *readtable*) :preserve) (loop for c across "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!@$%^&*_-+={}[]<>?/~" for str = (string c) for sym = (read-from-string str) unless (eql sym (find-symbol str)) collect (list c str sym))) nil) (def-syntax-test read-symbol.18 (let ((*readtable* (copy-readtable))) (setf (readtable-case *readtable*) :invert) (loop for c across "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!@$%^&*_-+={}[]<>?/~" for str = (string c) for sym = (read-from-string str) for c2 = (cond ((upper-case-p c) (char-downcase c)) ((lower-case-p c) (char-upcase c)) (t c)) unless (eql sym (find-symbol (string c2))) collect (list c c2 str sym))) nil) (def-syntax-test read-symbol.19 (read-from-string "123||") |123| 5) (def-syntax-test read-symbol.20 (read-from-string "123\\4") |1234| 5) (def-syntax-test read-symbol.21 (read-from-string "\\:1234") |:1234| 6) (def-syntax-test read-symbol.22 (read-from-string "||") #.(intern "" (find-package "CL-TEST")) 2) (def-syntax-test read-symbol.23 (loop for c across +standard-chars+ for s = (concatenate 'string (string c) ".") for sym = (intern (string-upcase s)) when (alpha-char-p c) nconc (let ((sym2 (let ((*read-base* 36)) (read-from-string s)))) (if (eq sym sym2) nil (list c s sym sym2)))) nil) (def-syntax-test read-symbol.24 (loop for c1 = (random-from-seq +alpha-chars+) for c2 = (random-from-seq +alpha-chars+) for d1 = (loop repeat (random 4) collect (random-from-seq +digit-chars+)) for d2 = (loop repeat (random 4) collect (random-from-seq +digit-chars+)) for s = (concatenate 'string d1 (list c1 c2) d2) for sym = (intern (string-upcase s)) repeat 1000 nconc (let ((sym2 (read-from-string s))) (if (eq sym sym2) nil (list c1 c2 d1 d2 s sym sym2)))) nil) (def-syntax-test read-symbol.25 (let ((potential-chars "01234567890123456789+-esdlf_^/") (*readtable* (copy-readtable))) (setf (readtable-case *readtable*) :preserve) (loop for d1 = (loop repeat (random 6) collect (random-from-seq potential-chars)) for c = (random-from-seq potential-chars) for d2 = (loop repeat (random 6) collect (random-from-seq potential-chars)) for s1 = (concatenate 'string d1 (list c) d2) for sym1 = (intern s1) for s2 = (concatenate 'string d1 (list #\\ c) d2) for sym2 = (read-from-string s2) repeat 1000 unless (eql sym1 sym2) collect (list d1 c d2 s1 sym1 s2 sym2))) nil) (deftest read-float.1 (eqlt -0.0 (- 0.0)) t) gcl27-2.7.0/ansi-tests/readtable-case.lsp000066400000000000000000000036041454061450500201130ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 1 18:43:46 2005 ;;;; Contains: Tests of READTABLE-CASE (in-package :cl-test) (deftest readtable-case.1 (with-standard-io-syntax (readtable-case *readtable*)) :upcase) (deftest readtable-case.2 (with-standard-io-syntax (let ((rt (copy-readtable))) (readtable-case rt))) :upcase) (deftest readtable-case.3 (let ((rt (copy-readtable))) (values (setf (readtable-case rt) :upcase) (readtable-case rt))) :upcase :upcase) (deftest readtable-case.4 (let ((rt (copy-readtable))) (values (setf (readtable-case rt) :downcase) (readtable-case rt))) :downcase :downcase) (deftest readtable-case.5 (let ((rt (copy-readtable))) (values (setf (readtable-case rt) :preserve) (readtable-case rt))) :preserve :preserve) (deftest readtable-case.6 (let ((rt (copy-readtable))) (values (setf (readtable-case rt) :invert) (readtable-case rt))) :invert :invert) (deftest readtable-case.7 (let ((rt (copy-readtable))) (loop for rtc in '(:upcase :downcase :preserve :invert) do (setf (readtable-case rt) rtc) nconc (let ((rt2 (copy-readtable rt))) (unless (eq (readtable-case rt2) rtc) (list rtc rt2))))) nil) ;;; Error cases (deftest readtable-case.error.1 (signals-error (readtable-case) program-error) t) (deftest readtable-case.error.2 (signals-error (readtable-case *readtable* nil) program-error) t) (deftest readtable-case.error.3 (check-type-error #'readtable-case (typef 'readtable)) nil) (deftest readtable-case.error.4 (check-type-error #'(lambda (x) (let ((rt (copy-readtable))) (setf (readtable-case rt) x))) (typef '(member :upcase :downcase :preserve :invert))) nil) (deftest readtable-case.error.5 (check-type-error #'(lambda (x) (setf (readtable-case x) :upcase)) (typef 'readtable)) nil) gcl27-2.7.0/ansi-tests/readtablep.lsp000066400000000000000000000030751454061450500173640ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 1 19:19:42 2005 ;;;; Contains: Tests of READTABLEP (in-package :cl-test) (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 readtablep.2 (check-type-predicate #'readtablep 'readtable) nil) (deftest readtablep.3 (notnot-mv (readtablep *readtable*)) t) (deftest readtablep.4 (notnot-mv (readtablep (copy-readtable))) t) ;;; Error tests (deftest readtablep.error.1 (signals-error (readtablep) program-error) t) (deftest readtablep.error.2 (signals-error (readtablep *readtable* nil) program-error) t) (deftest readtablep.error.3 (signals-error (readtablep *readtable* nil t t t t) program-error) t) gcl27-2.7.0/ansi-tests/real.lsp000066400000000000000000000025701454061450500162030ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Oct 31 21:41:49 2004 ;;;; Contains: Additional tests of the REAL type specifier (in-package :cl-test) (deftest real.1 (loop for i = 1 then (ash i 1) for tp = `(real 0 ,i) repeat 200 unless (and (not (typep -1 tp)) (not (typep -0.0001 tp)) (typep 0 tp) (typep 0.0001 tp) (typep 1 tp) (typep i tp) (not (typep (1+ i) tp))) collect (list i tp)) nil) (deftest real.2 (loop for i = 1 then (ash i 1) for tp = `(real ,(- i) 0) repeat 200 unless (and (not (typep (- -1 i) tp)) (typep (- i) tp) (typep -1 tp) (typep 0 tp) (not (typep 1 tp)) (not (typep i tp)) (not (typep (1+ i) tp))) collect (list i tp)) nil) (deftest real.3 (loop for i = 4 then (ash i 1) for tp = `(real 0 ,(/ i 3)) repeat 200 unless (and (not (typep -1 tp)) (not (typep -0.0001 tp)) (typep 0 tp) (typep 0.0001 tp) (typep 1 tp) (typep (/ i 3) tp) (not (typep (/ (1+ i) 3) tp))) collect (list i tp)) nil) (deftest real.4 (loop for i = 4 then (ash i 1) for tp = `(real ,(- (/ i 3)) 0) repeat 200 unless (and (not (typep (- -1 (/ i 3)) tp)) (typep (- (/ i 3)) tp) (typep -1 tp) (typep 0 tp) (not (typep 1 tp)) (not (typep (/ i 3) tp)) (not (typep (1+ (/ i 3)) tp))) collect (list i tp)) nil) gcl27-2.7.0/ansi-tests/realp.lsp000066400000000000000000000012271454061450500163610ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 7 08:22:06 2003 ;;;; Contains: Tests of REALP (in-package :cl-test) (deftest realp.error.1 (signals-error (realp) program-error) t) (deftest realp.error.2 (signals-error (realp 0 nil) program-error) t) (deftest realp.error.3 (signals-error (realp nil nil) program-error) t) (deftest realp.1 (notnot-mv (realp 0)) t) (deftest realp.2 (notnot-mv (realp 0.0)) t) (deftest realp.3 (realp #c(1 2)) nil) (deftest realp.4 (notnot-mv (realp 17/13)) t) (deftest realp.5 (realp 'a) nil) (deftest realp.6 (check-type-predicate #'realp 'real) nil) gcl27-2.7.0/ansi-tests/realpart.lsp000066400000000000000000000020021454061450500170600ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 7 07:41:15 2003 ;;;; Contains: Tests of REALPART (in-package :cl-test) (deftest realpart.error.1 (signals-error (realpart) program-error) t) (deftest realpart.error.2 (signals-error (realpart #c(1.0 2.0) nil) program-error) t) (deftest realpart.error.3 (check-type-error #'realpart #'numberp) nil) (deftest realpart.1 (loop for x in *reals* for c = (complex x 0) for rp = (realpart c) unless (eql x rp) collect (list x c rp)) nil) (deftest realpart.2 (loop for x in *reals* for c = (complex x 1) for rp = (realpart c) unless (eql x rp) collect (list x c rp)) nil) (deftest realpart.3 (loop for x in *reals* for c = (complex x x) for rp = (realpart c) unless (eql x rp) collect (list x c rp)) nil) ;;; Should move this to complex.lsp (deftest realpart.4 (loop for c in *complexes* for rp = (realpart c) for ip = (imagpart c) for c2 = (complex rp ip) unless (eql c c2) collect (list c rp ip c2)) nil) gcl27-2.7.0/ansi-tests/reduce.lsp000066400000000000000000000327741454061450500165400ustar00rootroot00000000000000;-*- 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) ;;; Specialized vectors (deftest reduce-array.20 (do-special-integer-vectors (v #(1 0 0 1 1 0) nil) (assert (eql (reduce #'+ v) 3))) nil) (deftest reduce-array.21 (do-special-integer-vectors (v #(1 0 0 1 1 0) nil) (assert (equal (reduce #'cons v :from-end t :initial-value nil) '(1 0 0 1 1 0)))) nil) (deftest reduce-array.22 (do-special-integer-vectors (v #(1 2 3 4 5 6 7) nil) (assert (eql (reduce #'+ v) 28)) (assert (eql (reduce #'+ v :from-end t) 28)) (assert (eql (reduce #'+ v :start 1) 27)) (assert (eql (reduce #'+ v :initial-value 10) 38)) (assert (eql (reduce #'+ v :end 6) 21))) nil) (deftest reduce-array.23 (let* ((len 10) (expected (* 1/2 (1+ len) len))) (loop for etype in '(short-float single-float double-float long-float) for vals = (loop for i from 1 to len collect (coerce i etype)) for vec = (make-array len :initial-contents vals :element-type etype) for result = (reduce #'+ vec) unless (= result (coerce expected etype)) collect (list etype vals vec result))) nil) (deftest reduce-array.24 (let* ((len 10) (expected (* 1/2 (1+ len) len))) (loop for cetype in '(short-float single-float double-float long-float) for etype = `(complex ,cetype) for vals = (loop for i from 1 to len collect (complex (coerce i cetype) (coerce (- i) cetype))) for vec = (make-array len :initial-contents vals :element-type etype) for result = (reduce #'+ vec) unless (= result (complex (coerce expected cetype) (coerce (- expected) cetype))) collect (list etype vals vec result))) nil) (deftest reduce-array.25 (do-special-integer-vectors (v (vector 0 most-positive-fixnum 0 most-positive-fixnum 0) nil) (assert (eql (reduce #'+ v) (* 2 most-positive-fixnum)))) nil) ;;;;;;;; (deftest reduce.error.1 (check-type-error #'(lambda (x) (reduce 'cons x)) #'sequencep) nil) (deftest reduce.error.2 (signals-error (reduce) program-error) t) (deftest reduce.error.3 (signals-error (reduce #'list nil :start) program-error) t) (deftest reduce.error.4 (signals-error (reduce #'list nil 'bad t) program-error) t) (deftest reduce.error.5 (signals-error (reduce #'list nil 'bad t :allow-other-keys nil) program-error) t) (deftest reduce.error.6 (signals-error (reduce #'list nil 1 2) program-error) t) (deftest reduce.error.7 (signals-error (locally (reduce 'cons 'a) t) type-error) t) (deftest reduce.error.8 (signals-error (reduce #'identity '(a b c)) program-error) t) (deftest reduce.error.9 (signals-error (reduce #'cons '(a b c) :key #'cons) program-error) t) (deftest reduce.error.10 (signals-error (reduce #'cons '(a b c) :key #'car) type-error) t) ;;;;;;;; (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-string.18 (do-special-strings (s "12345" nil) (let ((x (reduce #'(lambda (x y) (cons y x)) s))) (assert (equal x '(#\5 #\4 #\3 #\2 . #\1))))) nil) (deftest reduce-string.19 (do-special-strings (s "54321" nil) (let ((x (reduce #'cons s :from-end t))) (assert (equal x '(#\5 #\4 #\3 #\2 . #\1))))) nil) (deftest reduce-string.20 (do-special-strings (s "12345" nil) (let ((x (reduce #'(lambda (x y) (cons y x)) s :initial-value nil))) (assert (equal x '(#\5 #\4 #\3 #\2 #\1))))) nil) ;;;;;;;; (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)) gcl27-2.7.0/ansi-tests/reinitialize-instance.lsp000066400000000000000000000065751454061450500215630ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Apr 28 21:56:47 2003 ;;;; Contains: Tests for REINITIALIZE-INSTANCE (in-package :cl-test) ;;; Many of the classes used here are defined in defclass-??.lsp (deftest reinitialize-instance.1 (let* ((obj (make-instance 'class-01)) (obj2 (reinitialize-instance obj))) (values (eqt obj obj2) (map-slot-boundp* obj '(s1 s2 s3)))) t (nil nil nil)) (deftest reinitialize-instance.2 (let* ((obj (make-instance 'class-01)) (obj2 (reinitialize-instance obj :allow-other-keys nil))) (values (eqt obj obj2) (map-slot-boundp* obj '(s1 s2 s3)))) t (nil nil nil)) (deftest reinitialize-instance.3 (let* ((obj (make-instance 'class-01)) (obj2 (reinitialize-instance obj :allow-other-keys t))) (values (eqt obj obj2) (map-slot-boundp* obj '(s1 s2 s3)))) t (nil nil nil)) (deftest reinitialize-instance.4 (let* ((obj (make-instance 'class-01)) (obj2 (reinitialize-instance obj :allow-other-keys t :allow-other-keys nil))) (values (eqt obj obj2) (map-slot-boundp* obj '(s1 s2 s3)))) t (nil nil nil)) (deftest reinitialize-instance.5 (let* ((obj (make-instance 'class-07)) (obj2 (reinitialize-instance obj :s1a 'a :s2 'b :s1a 'bad :s2 'bad2 :s1b 'bad3))) (values (eqt obj obj2) (map-slot-value obj '(s1 s2)))) t (a b)) (deftest reinitialize-instance.6 (let* ((obj (make-instance 'class-07 :s1a 'a)) (obj2 (reinitialize-instance obj :s1b 'b))) (values (eqt obj obj2) (slot-value obj 's1) (slot-boundp* obj 's2))) t b nil) (deftest reinitialize-instance.7 (let* ((obj (make-instance 'class-07 :s1a 'a)) (obj2 (reinitialize-instance obj :s2 'b))) (values (eqt obj obj2) (slot-value obj 's1) (slot-value obj 's2))) t a b) ;;; Tests of user-defined methods (defclass reinit-class-01 () ((a :initarg :a) (b :initarg :b))) (defmethod reinitialize-instance :after ((instance reinit-class-01) &rest initargs &key (x nil x-p)) (declare (ignore initargs)) (when x-p (setf (slot-value instance 'a) x)) instance) (deftest reinitialize-instance.8 (let* ((obj (make-instance 'reinit-class-01)) (obj2 (reinitialize-instance obj :a 1 :b 3))) (values (eqt obj obj2) (map-slot-value obj2 '(a b)))) t (1 3)) (deftest reinitialize-instance.9 (let* ((obj (make-instance 'reinit-class-01 :a 10 :b 20)) (obj2 (reinitialize-instance obj :x 3))) (values (eqt obj obj2) (map-slot-value obj2 '(a b)))) t (3 20)) (deftest reinitialize-instance.10 (let* ((obj (make-instance 'reinit-class-01 :a 10 :b 20)) (obj2 (reinitialize-instance obj :x 3 :x 100))) (values (eqt obj obj2) (map-slot-value obj2 '(a b)))) t (3 20)) ;;; Order of evaluation tests (deftest reinitialize-instance.order.1 (let* ((obj (make-instance 'reinit-class-01)) (i 0) x y z w (obj2 (reinitialize-instance (progn (setf x (incf i)) obj) :b (setf y (incf i)) :a (setf z (incf i)) :b (setf w (incf i))))) (values (eqt obj obj2) (map-slot-value obj2 '(a b)) i x y z w)) t (3 2) 4 1 2 3 4) ;;; Error cases (deftest reinitialize-instance.error.1 (handler-case (eval '(reinitialize-instance (make-instance 'class-01) :garbage t)) (error () :good)) :good) (deftest reinitialize-instance.error.2 (signals-error (reinitialize-instance) program-error) t) gcl27-2.7.0/ansi-tests/remf.lsp000066400000000000000000000036031454061450500162070ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:38:18 2003 ;;;; Contains: Tests of REMF (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest remf.5 (macrolet ((%m (z) z)) (let ((x nil)) (values (remf (expand-in-current-env (%m x)) 'a) x))) nil nil) (deftest remf.6 (macrolet ((%m (z) z)) (let ((x (list 'a 'b))) (values (notnot (remf (expand-in-current-env (%m x)) 'a)) x))) t nil) (deftest remf.7 (macrolet ((%m (z) z)) (let ((x (list 'a 'b 'c 'd))) (values (notnot (remf x (expand-in-current-env (%m 'a)))) x))) t (c d)) (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) (deftest remf.order.2 (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 remf.order.3 (let ((x (list 'a 'b 'c 'd))) (progn "See CLtS 5.1.3" (values (remf x (progn (setq x (list 'e 'f)) 'a)) x))) nil (e f)) (def-macro-test remf.error.1 (remf x 'a)) gcl27-2.7.0/ansi-tests/remhash.lsp000066400000000000000000000034411454061450500167050ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Nov 28 08:58:06 2003 ;;;; Contains: Tests of REMHASH (in-package :cl-test) (deftest remhash.1 (let ((table (make-hash-table))) (values (gethash 'a table) (remhash 'a table) (setf (gethash 'a table) 'b) (gethash 'a table) (notnot (remhash 'a table)) (gethash 'a table))) nil nil b b t nil) (deftest remhash.2 (let ((table (make-hash-table :test 'eq))) (values (gethash 'a table) (remhash 'a table) (setf (gethash 'a table) 'b) (gethash 'a table) (notnot (remhash 'a table)) (gethash 'a table))) nil nil b b t nil) (deftest remhash.3 (let ((table (make-hash-table :test 'equal))) (values (gethash 'a table) (remhash 'a table) (setf (gethash 'a table) 'b) (gethash 'a table) (notnot (remhash 'a table)) (gethash 'a table))) nil nil b b t nil) (deftest remhash.4 (let ((table (make-hash-table :test 'equalp))) (values (gethash 'a table) (remhash 'a table) (setf (gethash 'a table) 'b) (gethash 'a table) (notnot (remhash 'a table)) (gethash 'a table))) nil nil b b t nil) (deftest remhash.5 (remhash 'a (make-hash-table)) nil) (deftest remhash.6 (notnot-mv (remhash nil (let ((table (make-hash-table))) (setf (gethash nil table) t) table))) t) (deftest remhash.order.1 (let ((i 0) x y) (values (remhash (progn (setf x (incf i)) 'a) (progn (setf y (incf i)) (make-hash-table))) i x y)) nil 2 1 2) ;;; Error tests (deftest remhash.error.1 (signals-error (remhash) program-error) t) (deftest remhash.error.2 (signals-error (remhash 'a) program-error) t) (deftest remhash.error.3 (signals-error (remhash 'a (make-hash-table) nil) program-error) t) gcl27-2.7.0/ansi-tests/remove-aux.lsp000066400000000000000000000224211454061450500173450ustar00rootroot00000000000000;-*- 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)) ((and (listp type) (eql (car type) 'integer) (integerp (cadr type)) (integerp (caddr type)) (null (cdddr type))) (+ (cadr type) (random (- (1+ (caddr type)) (cadr type))))) ((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 (setf test (coerce test 'function)) #'(lambda (x) (funcall (the function test) element x))) (test-not-p (setf test-not (coerce test-not 'function)) #'(lambda (x) (not (funcall (the function 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))) (setf predicate (coerce predicate 'function)) (setf key (coerce key 'function)) ;; 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 (the function predicate) (funcall (the function 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 (rcase (2 t) (1 'bit) (1 '(integer 0 2)) (1 'symbol))) (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)) (setf tested-fn (coerce tested-fn 'function)) (setf check-fn (coerce check-fn 'function)) (multiple-value-bind (element seq arg-list) (random-test-remove-args maxlen) (let* ((seq1 (copy-seq seq)) (seq2 (copy-seq seq)) (seq1r (apply (the function tested-fn) element seq1 arg-list)) (seq2r (apply (the function check-fn) element seq2 arg-list))) (setq *remove-fail-args* (list* element seq 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)) (setf test (coerce test 'function)) (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 (the function 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)) (setf test (coerce test 'function)) (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 (the function 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)))))) gcl27-2.7.0/ansi-tests/remove-duplicates-aux.lsp000066400000000000000000000063121454061450500215010ustar00rootroot00000000000000;-*- 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)) (setf key (coerce key 'function)) (cond (test (setf test (coerce test 'function)) (assert (not test-not))) (test-not (setf test-not (coerce test-not 'function)) (setq test #'(lambda (x y) (not (funcall (the function 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 = (funcall (the function key) x) unless (position kx sequence :start (1+ i) :end end :test (the function test) :key (the function 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 len 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))) (list :fail1 seq seq1r seq2r arg-list)) ((and pure (not (equalp seq seq2))) (list :fail2 seq seq1r seq2r arg-list)) ((not (equalp seq1r seq2r)) (list :fail3 seq seq1r seq2r arg-list)) (t t))))) gcl27-2.7.0/ansi-tests/remove-duplicates.lsp000066400000000000000000000306421454061450500207110ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 29 20:49:47 2002 ;;;; Contains: Tests for REMOVE-DUPLICATES, DELETE-DUPLICATES (in-package :cl-test) (compile-and-load "remove-aux.lsp") (compile-and-load "remove-duplicates-aux.lsp") (deftest random-remove-duplicates (loop for result = (random-test-remove-dups (1+ (random 20))) repeat 1000 unless (eq result t) collect result) nil) (deftest random-delete-duplicates (loop for result = (random-test-remove-dups (1+ (random 20)) nil) repeat 1000 unless (eq result t) collect result) nil) ;;; 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)) (defharmless remove-duplicates.test-and-test-not.1 (remove-duplicates (list 'a 'b 'c 'd 'a 'e 'f 'd 'g) :test #'eql :test-not #'eql)) (defharmless remove-duplicates.test-and-test-not.2 (remove-duplicates (list 'a 'b 'c 'd 'a 'e 'f 'd 'g) :test-not #'eql :test #'eql)) (defharmless delete-duplicates.test-and-test-not.1 (delete-duplicates (list 'a 'b 'c 'd 'a 'e 'f 'd 'g) :test #'eql :test-not #'eql)) (defharmless delete-duplicates.test-and-test-not.2 (delete-duplicates (list 'a 'b 'c 'd 'a 'e 'f 'd 'g) :test-not #'eql :test #'eql)) ;;; Const fold tests (def-fold-test remove-duplicates.fold.1 (remove-duplicates '(1 2 3 3))) (def-fold-test remove-duplicates.fold.2 (remove-duplicates #(1 2 3 3))) (def-fold-test remove-duplicates.fold.3 (remove-duplicates #*0011)) (def-fold-test remove-duplicates.fold.4 (remove-duplicates "1233")) ;;; 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 (signals-error (remove-duplicates) program-error) t) (deftest remove-duplicates.error.2 (signals-error (remove-duplicates nil :start) program-error) t) (deftest remove-duplicates.error.3 (signals-error (remove-duplicates nil 'bad t) program-error) t) (deftest remove-duplicates.error.4 (signals-error (remove-duplicates nil 'bad t :allow-other-keys nil) program-error) t) (deftest remove-duplicates.error.5 (signals-error (remove-duplicates nil 1 2) program-error) t) (deftest remove-duplicates.error.6 (signals-error (remove-duplicates (list 'a 'b 'c) :test #'identity) program-error) t) (deftest remove-duplicates.error.7 (signals-error (remove-duplicates (list 'a 'b 'c) :test-not #'identity) program-error) t) (deftest remove-duplicates.error.8 (signals-error (remove-duplicates (list 'a 'b 'c) :key #'cons) program-error) t) (deftest remove-duplicates.error.9 (signals-error (remove-duplicates (list 'a 'b 'c) :key #'car) type-error) t) (deftest remove-duplicates.error.10 (check-type-error #'remove-duplicates #'sequencep) nil) ;;; (deftest delete-duplicates.error.1 (signals-error (delete-duplicates) program-error) t) (deftest delete-duplicates.error.2 (signals-error (delete-duplicates nil :start) program-error) t) (deftest delete-duplicates.error.3 (signals-error (delete-duplicates nil 'bad t) program-error) t) (deftest delete-duplicates.error.4 (signals-error (delete-duplicates nil 'bad t :allow-other-keys nil) program-error) t) (deftest delete-duplicates.error.5 (signals-error (delete-duplicates nil 1 2) program-error) t) (deftest delete-duplicates.error.6 (signals-error (delete-duplicates (list 'a 'b 'c) :test #'identity) program-error) t) (deftest delete-duplicates.error.7 (signals-error (delete-duplicates (list 'a 'b 'c) :test-not #'identity) program-error) t) (deftest delete-duplicates.error.8 (signals-error (delete-duplicates (list 'a 'b 'c) :key #'cons) program-error) t) (deftest delete-duplicates.error.9 (signals-error (delete-duplicates (list 'a 'b 'c) :key #'car) type-error) t) (deftest delete-duplicates.error.10 (check-type-error #'delete-duplicates #'sequencep) nil) ;;; Specialized string tests (deftest remove-duplicates.string.1 (do-special-strings (s "abcadefabgz" nil) (let ((s2 (remove-duplicates s))) (assert (string= s "abcadefabgz")) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "cdefabgz")))) nil) (deftest remove-duplicates.string.2 (do-special-strings (s "abcadefabgz" nil) (let ((s2 (remove-duplicates s :from-end t))) (assert (string= s "abcadefabgz")) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "abcdefgz")))) nil) (deftest delete-duplicates.string.1 (do-special-strings (s "abcadefabgz" nil) (let ((aet (array-element-type s)) (s2 (delete-duplicates s))) (assert (equal aet (array-element-type s2))) (assert (string= s2 "cdefabgz")))) nil) (deftest delete-duplicates.string.2 (do-special-strings (s "abcadefabgz" nil) (let ((aet (array-element-type s)) (s2 (delete-duplicates s :from-end t))) (assert (equal aet (array-element-type s2))) (assert (string= s2 "abcdefgz")))) nil) ;;; Order of elements kept under EQUAL, EQUALP tests (deftest remove-duplicates.2 (let* ((x (list 'a)) (y (list 'a)) (result (remove-duplicates (list x y) :test 'equal))) (values result (notnot (eql (car result) x)) (notnot (eql (car result) y)))) ((a)) nil t) (deftest remove-duplicates.2a (let* ((x (list 'a)) (y (list 'a)) (result (remove-duplicates (list x 'x y) :test 'equal))) (values result (notnot (eql (cadr result) x)) (notnot (eql (cadr result) y)))) (x (a)) nil t) (deftest remove-duplicates.3 (let* ((x (list 'a)) (y (list 'a)) (result (remove-duplicates (list x y) :test 'equal :from-end t))) (values result (notnot (eql (car result) x)) (notnot (eql (car result) y)))) ((a)) t nil) (deftest remove-duplicates.3a (let* ((x (list 'a)) (y (list 'a)) (result (remove-duplicates (list x 'u 'v y) :test 'equal :from-end t))) (values result (notnot (eql (car result) x)) (notnot (eql (car result) y)))) ((a) u v) t nil) (deftest remove-duplicates.4 (let* ((x (list 'a)) (y (list 'a)) (result (remove-duplicates (list x y) :test 'equalp))) (values result (notnot (eql (car result) x)) (notnot (eql (car result) y)))) ((a)) nil t) (deftest remove-duplicates.5 (let* ((x (list 'a)) (y (list 'a)) (result (remove-duplicates (list x y) :test 'equalp :from-end t))) (values result (notnot (eql (car result) x)) (notnot (eql (car result) y)))) ((a)) t nil) ;;; Similar, but destructive (deftest delete-duplicates.2 (let* ((x (list 'a)) (y (list 'a)) (result (delete-duplicates (list x y) :test 'equal))) (values result (notnot (eql (car result) x)) (notnot (eql (car result) y)))) ((a)) nil t) (deftest delete-duplicates.2a (let* ((x (list 'a)) (y (list 'a)) (result (delete-duplicates (list x 'x y) :test 'equal))) (values result (notnot (eql (cadr result) x)) (notnot (eql (cadr result) y)))) (x (a)) nil t) (deftest delete-duplicates.3 (let* ((x (list 'a)) (y (list 'a)) (result (delete-duplicates (list x y) :test 'equal :from-end t))) (values result (notnot (eql (car result) x)) (notnot (eql (car result) y)))) ((a)) t nil) (deftest delete-duplicates.3a (let* ((x (list 'a)) (y (list 'a)) (result (delete-duplicates (list x 'u 'v y) :test 'equal :from-end t))) (values result (notnot (eql (car result) x)) (notnot (eql (car result) y)))) ((a) u v) t nil) (deftest delete-duplicates.4 (let* ((x (list 'a)) (y (list 'a)) (result (delete-duplicates (list x y) :test 'equalp))) (values result (notnot (eql (car result) x)) (notnot (eql (car result) y)))) ((a)) nil t) (deftest delete-duplicates.5 (let* ((x (list 'a)) (y (list 'a)) (result (delete-duplicates (list x y) :test 'equalp :from-end t))) (values result (notnot (eql (car result) x)) (notnot (eql (car result) y)))) ((a)) t nil) gcl27-2.7.0/ansi-tests/remove-method.lsp000066400000000000000000000155411454061450500200350ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 11 19:53:37 2003 ;;;; Contains: Tests of REMOVE-METHOD (in-package :cl-test) (defparameter *remove-meth-gf-01* (defgeneric remove-meth-gf-01 (x))) (defparameter *remove-meth-gf-01-method-t* (defmethod remove-meth-gf-01 ((x t)) x)) (defparameter *remove-meth-gf-02* (defgeneric remove-meth-gf-02 (x))) (defparameter *remove-meth-gf-02-method-t* (defmethod remove-meth-gf-02 ((x t)) x)) ;;; remove method must not signal an error if the method ;;; does not belong to the generic function (deftest remove-method.1 (and (eqt (remove-method *remove-meth-gf-01* *remove-meth-gf-02-method-t*) *remove-meth-gf-01*) (remove-meth-gf-01 :good)) :good) ;;; Add, then remove, a method (deftest remove-method.2 (let (meth) (values (remove-meth-gf-01 10) (progn (setf meth (eval '(defmethod remove-meth-gf-01 ((x integer)) (1+ x)))) nil) (remove-meth-gf-01 10) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth)) (remove-meth-gf-01 10))) 10 nil 11 t 10) ;;; Add two disjoint methods, then remove (deftest remove-method.3 (let (meth1 meth2) (values (mapcar #'remove-meth-gf-01 '(19 a)) (progn (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x symbol)) (list x)))) (mapcar #'remove-meth-gf-01 '(19 a))) (progn (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x number)) (1+ x)))) (mapcar #'remove-meth-gf-01 '(19 a))) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth1)) (mapcar #'remove-meth-gf-01 '(19 a)) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth2)) (mapcar #'remove-meth-gf-01 '(19 a)))) (19 a) (19 (a)) (20 (a)) t (20 a) t (19 a)) ;;; Remove in the other order (deftest remove-method.4 (let (meth1 meth2) (values (mapcar #'remove-meth-gf-01 '(19 a)) (progn (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x symbol)) (list x)))) (mapcar #'remove-meth-gf-01 '(19 a))) (progn (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x number)) (1+ x)))) (mapcar #'remove-meth-gf-01 '(19 a))) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth2)) (mapcar #'remove-meth-gf-01 '(19 a)) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth1)) (mapcar #'remove-meth-gf-01 '(19 a)))) (19 a) (19 (a)) (20 (a)) t (19 (a)) t (19 a)) ;;; Now methods that shadow one another (deftest remove-method.5 (let (meth1 meth2) (values (mapcar #'remove-meth-gf-01 '(10 20.0)) (progn (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x integer)) (1- x)))) (mapcar #'remove-meth-gf-01 '(10 20.0))) (progn (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x number)) (1+ x)))) (mapcar #'remove-meth-gf-01 '(10 20.0))) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth1)) (mapcar #'remove-meth-gf-01 '(10 20.0)) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth2)) (mapcar #'remove-meth-gf-01 '(10 20.0)))) (10 20.0) (9 20.0) (9 21.0) t (11 21.0) t (10 20.0)) (deftest remove-method.6 (let (meth1 meth2) (values (mapcar #'remove-meth-gf-01 '(10 20.0)) (progn (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x integer)) (1- x)))) (mapcar #'remove-meth-gf-01 '(10 20.0))) (progn (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x number)) (1+ x)))) (mapcar #'remove-meth-gf-01 '(10 20.0))) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth2)) (mapcar #'remove-meth-gf-01 '(10 20.0)) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth1)) (mapcar #'remove-meth-gf-01 '(10 20.0)))) (10 20.0) (9 20.0) (9 21.0) t (9 20.0) t (10 20.0)) (deftest remove-method.7 (let (meth1 meth2) (values (mapcar #'remove-meth-gf-01 '(10 20.0)) (progn (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x number)) (1+ x)))) (mapcar #'remove-meth-gf-01 '(10 20.0))) (progn (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x integer)) (1- x)))) (mapcar #'remove-meth-gf-01 '(10 20.0))) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth1)) (mapcar #'remove-meth-gf-01 '(10 20.0)) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth2)) (mapcar #'remove-meth-gf-01 '(10 20.0)))) (10 20.0) (11 21.0) (9 21.0) t (9 20.0) t (10 20.0)) (deftest remove-method.8 (let (meth1 meth2) (values (mapcar #'remove-meth-gf-01 '(10 20.0)) (progn (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x number)) (1+ x)))) (mapcar #'remove-meth-gf-01 '(10 20.0))) (progn (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x integer)) (1- x)))) (mapcar #'remove-meth-gf-01 '(10 20.0))) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth2)) (mapcar #'remove-meth-gf-01 '(10 20.0)) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth1)) (mapcar #'remove-meth-gf-01 '(10 20.0)))) (10 20.0) (11 21.0) (9 21.0) t (11 21.0) t (10 20.0)) ;;; Adding and removing auxiliary methods (declaim (special *rmgf-03-var*)) (defparameter *remove-meth-gf-03* (defgeneric remove-meth-gf-03 (x))) (defparameter *remove-meth-gf-03-method-t* (defmethod remove-meth-gf-03 ((x t)) (list *rmgf-03-var* x))) (deftest remove-method.9 (let (meth (*rmgf-03-var* 0)) (values (mapcar #'remove-meth-gf-03 '(5 a)) (progn (setf meth (eval '(defmethod remove-meth-gf-03 :before ((x number)) (incf *rmgf-03-var*)))) (mapcar #'remove-meth-gf-03 '(5 a))) (eqt *remove-meth-gf-03* (remove-method *remove-meth-gf-03* meth)) (mapcar #'remove-meth-gf-03 '(5 a)))) ((0 5) (0 a)) ((1 5) (1 a)) t ((1 5) (1 a))) (deftest remove-method.10 (let (meth (*rmgf-03-var* 0)) (values (mapcar #'remove-meth-gf-03 '(5 a)) (progn (setf meth (eval '(defmethod remove-meth-gf-03 :after ((x number)) (incf *rmgf-03-var*)))) (mapcar #'remove-meth-gf-03 '(5 a))) (eqt *remove-meth-gf-03* (remove-method *remove-meth-gf-03* meth)) (mapcar #'remove-meth-gf-03 '(5 a)))) ((0 5) (0 a)) ((0 5) (1 a)) t ((1 5) (1 a))) (deftest remove-method.11 (let (meth (*rmgf-03-var* 0)) (values (mapcar #'remove-meth-gf-03 '(5 a)) (progn (setf meth (eval '(defmethod remove-meth-gf-03 :around ((x number)) (incf *rmgf-03-var*) (prog1 (call-next-method) (decf *rmgf-03-var*))))) (mapcar #'remove-meth-gf-03 '(5 a))) (eqt *remove-meth-gf-03* (remove-method *remove-meth-gf-03* meth)) (mapcar #'remove-meth-gf-03 '(5 a)))) ((0 5) (0 a)) ((1 5) (0 a)) t ((0 5) (0 a))) ;;; Must add tests for nonstandard method combinations gcl27-2.7.0/ansi-tests/remove.lsp000066400000000000000000000665701454061450500165670ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 14 11:46:05 2002 ;;;; Contains: Tests for REMOVE (compile-and-load "remove-aux.lsp") (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 ;;; NOTE: this test was bogus, since we can't sure non-EQness is preserved #| (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 remove-string.4 (do-special-strings (s "abcdbad" nil) (let ((s2 (remove #\b s))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "acdad"))) (let ((s2 (remove #\b s :count 1))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "acdbad"))) (let ((s2 (remove #\b s :count 1 :from-end t))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "abcdad")))) nil) (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 delete-string.4 (do-special-strings (s "abcdbad" nil) (let ((s2 (delete #\b s))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "acdad")))) nil) (deftest delete-string.5 (do-special-strings (s "abcdbad" nil) (let ((s2 (delete #\b s :count 1))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "acdbad")))) nil) (deftest delete-string.6 (do-special-strings (s "abcdbad" nil) (let ((s2 (delete #\b s :count 1 :from-end t))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "abcdad")))) nil) (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) ;;; test & test-not together is harmless (defharmless remove-list.test-and-test-not.1 (remove 'a '(a b c) :test #'eql :test-not #'eql)) (defharmless remove-list.test-and-test-not.2 (remove 'a '(a b c) :test-not #'eql :test #'eql)) (defharmless remove-vector.test-and-test-not.1 (remove 'a #(a b c) :test #'eql :test-not #'eql)) (defharmless remove-vector.test-and-test-not.2 (remove 'a #(a b c) :test-not #'eql :test #'eql)) (defharmless remove-bit-string.test-and-test-not.1 (remove 0 #*0001100100 :test #'eql :test-not #'eql)) (defharmless remove-bit-string.test-and-test-not.2 (remove 0 #*0001100100 :test-not #'eql :test #'eql)) (defharmless remove-string.test-and-test-not.1 (remove #\0 "0001100100" :test #'eql :test-not #'eql)) (defharmless remove-string.test-and-test-not.2 (remove #\0 "0001100100" :test-not #'eql :test #'eql)) (defharmless delete-list.test-and-test-not.1 (delete 'a (list 'a 'b 'c) :test #'eql :test-not #'eql)) (defharmless delete-list.test-and-test-not.2 (delete 'a (list 'a 'b 'c) :test-not #'eql :test #'eql)) (defharmless delete-vector.test-and-test-not.1 (delete 'a (vector 'a 'b 'c) :test #'eql :test-not #'eql)) (defharmless delete-vector.test-and-test-not.2 (delete 'a (vector 'a 'b 'c) :test-not #'eql :test #'eql)) (defharmless delete-bit-string.test-and-test-not.1 (delete 0 (copy-seq #*0001100100) :test #'eql :test-not #'eql)) (defharmless delete-bit-string.test-and-test-not.2 (delete 0 (copy-seq #*0001100100) :test-not #'eql :test #'eql)) (defharmless delete-string.test-and-test-not.1 (delete #\0 (copy-seq "0001100100") :test #'eql :test-not #'eql)) (defharmless delete-string.test-and-test-not.2 (delete #\0 (copy-seq "0001100100") :test-not #'eql :test #'eql)) ;;; Const fold tests (def-fold-test remove.fold.1 (remove 'c '(a b c d e))) (def-fold-test remove.fold.2 (remove 'c #(a b c d e))) (def-fold-test remove.fold.3 (remove 1 #*0011011001)) (def-fold-test remove.fold.4 (remove #\c "abcde")) (def-fold-test remove-if.fold.1 (remove-if 'null '(a b nil d e))) (def-fold-test remove-if.fold.2 (remove-if #'null #(a b nil d e))) (def-fold-test remove-if.fold.3 (remove-if 'plusp #*0011011001)) (def-fold-test remove-if.fold.4 (remove-if 'digit-char-p "ab0de")) (def-fold-test remove-if-not.fold.1 (remove-if-not #'identity '(a b nil d e))) (def-fold-test remove-if-not.fold.2 (remove-if-not 'identity #(a b nil d e))) (def-fold-test remove-if-not.fold.3 (remove-if-not #'zerop #*0011011001)) (def-fold-test remove-if-not.fold.4 (remove-if-not #'alpha-char-p "ab-de")) ;;; 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 (signals-error (remove) program-error) t) (deftest remove.error.2 (signals-error (remove 'a) program-error) t) (deftest remove.error.3 (signals-error (remove 'a nil :key) program-error) t) (deftest remove.error.4 (signals-error (remove 'a nil 'bad t) program-error) t) (deftest remove.error.4a (signals-error (remove 'a nil nil t) program-error) t) (deftest remove.error.5 (signals-error (remove 'a nil 'bad t :allow-other-keys nil) program-error) t) (deftest remove.error.6 (signals-error (remove 'a nil 1 2) program-error) t) (deftest remove.error.7 (signals-error (remove 'a (list 'a 'b 'c) :test #'identity) program-error) t) (deftest remove.error.8 (signals-error (remove 'a (list 'a 'b 'c) :test-not #'identity) program-error) t) (deftest remove.error.9 (signals-error (remove 'a (list 'a 'b 'c) :key #'cons) program-error) t) (deftest remove.error.10 (signals-error (remove 'a (list 'a 'b 'c) :key #'car) type-error) t) (deftest remove.error.11 (check-type-error #'(lambda (x) (remove 'a x)) #'sequencep) nil) ;;; (deftest delete.error.1 (signals-error (delete) program-error) t) (deftest delete.error.2 (signals-error (delete 'a) program-error) t) (deftest delete.error.3 (signals-error (delete 'a nil :key) program-error) t) (deftest delete.error.4 (signals-error (delete 'a nil 'bad t) program-error) t) (deftest delete.error.5 (signals-error (delete 'a nil 'bad t :allow-other-keys nil) program-error) t) (deftest delete.error.6 (signals-error (delete 'a nil 1 2) program-error) t) (deftest delete.error.7 (signals-error (delete 'a (list 'a 'b 'c) :test #'identity) program-error) t) (deftest delete.error.8 (signals-error (delete 'a (list 'a 'b 'c) :test-not #'identity) program-error) t) (deftest delete.error.9 (signals-error (delete 'a (list 'a 'b 'c) :key #'cons) program-error) t) (deftest delete.error.10 (signals-error (delete 'a (list 'a 'b 'c) :key #'car) type-error) t) (deftest delete.error.11 (check-type-error #'(lambda (x) (delete 'a x)) #'sequencep) nil) ;;; More specialized string tests (deftest remove-if-string.1 (do-special-strings (s "ab1c23def4" nil) (let ((s2 (remove-if #'alpha-char-p s))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "1234")) (assert (string= s "ab1c23def4")))) nil) (deftest remove-if-string.2 (do-special-strings (s "ab1c23def4" nil) (let ((s2 (remove-if #'alpha-char-p s :count 3))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "123def4")) (assert (string= s "ab1c23def4")))) nil) (deftest remove-if-string.3 (do-special-strings (s "ab1c23def4" nil) (let ((s2 (remove-if #'alpha-char-p s :count 3 :from-end t))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "ab1c234")) (assert (string= s "ab1c23def4")))) nil) (deftest remove-if-not-string.1 (do-special-strings (s "ab1c23def4" nil) (let ((s2 (remove-if-not #'digit-char-p s))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "1234")) (assert (string= s "ab1c23def4")))) nil) (deftest remove-if-not-string.2 (do-special-strings (s "ab1c23def4" nil) (let ((s2 (remove-if-not #'digit-char-p s :count 3))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "123def4")) (assert (string= s "ab1c23def4")))) nil) (deftest remove-if-not-string.3 (do-special-strings (s "ab1c23def4" nil) (let ((s2 (remove-if-not #'digit-char-p s :count 3 :from-end t))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "ab1c234")) (assert (string= s "ab1c23def4")))) nil) (deftest delete-if-string.1 (do-special-strings (s "ab1c23def4" nil) (let ((s2 (delete-if #'alpha-char-p s))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "1234")))) nil) (deftest delete-if-string.2 (do-special-strings (s "ab1c23def4" nil) (let ((s2 (delete-if #'alpha-char-p s :count 3))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "123def4")))) nil) (deftest delete-if-string.3 (do-special-strings (s "ab1c23def4" nil) (let ((s2 (delete-if #'alpha-char-p s :count 3 :from-end t))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "ab1c234")))) nil) (deftest delete-if-not-string.1 (do-special-strings (s "ab1c23def4" nil) (let ((s2 (delete-if-not #'digit-char-p s))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "1234")))) nil) (deftest delete-if-not-string.2 (do-special-strings (s "ab1c23def4" nil) (let ((s2 (delete-if-not #'digit-char-p s :count 3))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "123def4")))) nil) (deftest delete-if-not-string.3 (do-special-strings (s "ab1c23def4" nil) (let ((s2 (delete-if-not #'digit-char-p s :count 3 :from-end t))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "ab1c234")))) nil) gcl27-2.7.0/ansi-tests/remprop.lsp000066400000000000000000000033371454061450500167460ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jul 12 18:25:53 2004 ;;;; Contains: Tests for REMPROP (in-package :cl-test) (deftest remprop.1 (let ((sym (gensym))) (values (symbol-plist sym) (multiple-value-list (remprop sym :foo)) (symbol-plist sym))) nil (nil) nil) (deftest remprop.2 (let ((sym (gensym))) (values (symbol-plist sym) (copy-list (setf (symbol-plist sym) '(:foo 0))) (multiple-value-list (notnot-mv (remprop sym :foo))) (symbol-plist sym))) nil (:foo 0) (t) nil) (deftest remprop.3 (let ((sym (gensym))) (values (symbol-plist sym) (copy-list (setf (symbol-plist sym) (list :bar 1 :foo 0 :baz 2))) (multiple-value-list (notnot-mv (remprop sym :foo))) (copy-list (symbol-plist sym)) (multiple-value-list (notnot-mv (remprop sym :foo))) (symbol-plist sym))) nil (:bar 1 :foo 0 :baz 2) (t) (:bar 1 :baz 2) (nil) (:bar 1 :baz 2)) (deftest remprop.4 (let ((sym (gensym))) (values (symbol-plist sym) (copy-list (setf (symbol-plist sym) (list :bar 1 :foo 0 :baz 2 :foo 3))) (multiple-value-list (notnot-mv (remprop sym :foo))) (copy-list (symbol-plist sym)) (multiple-value-list (notnot-mv (remprop sym :foo))) (symbol-plist sym))) nil (:bar 1 :foo 0 :baz 2 :foo 3) (t) (:bar 1 :baz 2 :foo 3) (t) (:bar 1 :baz 2)) ;;; Error tests (deftest remprop.error.1 (signals-error (remprop) program-error) t) (deftest remprop.error.2 (signals-error (remprop (gensym)) program-error) t) (deftest remprop.error.3 (signals-error (remprop (gensym) nil nil) program-error) t) (deftest remprop.error.4 (check-type-error #'(lambda (x) (remprop x nil)) #'symbolp) nil) gcl27-2.7.0/ansi-tests/rename-file.lsp000066400000000000000000000151601454061450500174430ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jan 8 06:22:53 2004 ;;;; Contains: Tests for RENAME-FILE (in-package :cl-test) (deftest rename-file.1 (let ((pn1 #p"file-to-be-renamed.txt") (pn2 #p"file-that-was-renamed.txt")) (delete-all-versions pn1) (delete-all-versions pn2) (with-open-file (s pn1 :direction :output) (format s "Whatever~%")) (let ((results (multiple-value-list (rename-file pn1 pn2)))) (destructuring-bind (defaulted-new-name old-truename new-truename) results (values (=t (length results) 3) (probe-file pn1) (notnot (probe-file pn2)) (list (notnot (pathnamep defaulted-new-name)) (notnot (pathnamep old-truename)) (notnot (pathnamep new-truename)) (typep old-truename 'logical-pathname) (typep new-truename 'logical-pathname)) (notnot (probe-file defaulted-new-name)) (probe-file old-truename) (notnot (probe-file new-truename)))))) t nil t (t t t nil nil) t nil t) (deftest rename-file.2 (let ((pn1 "file-to-be-renamed.txt") (pn2 "file-that-was-renamed.txt")) (delete-all-versions pn1) (delete-all-versions pn2) (with-open-file (s pn1 :direction :output) (format s "Whatever~%")) (let ((results (multiple-value-list (rename-file pn1 pn2)))) (destructuring-bind (defaulted-new-name old-truename new-truename) results (values (=t (length results) 3) (probe-file pn1) (notnot (probe-file pn2)) (list (notnot (pathnamep defaulted-new-name)) (notnot (pathnamep old-truename)) (notnot (pathnamep new-truename)) (typep old-truename 'logical-pathname) (typep new-truename 'logical-pathname)) (notnot (probe-file defaulted-new-name)) (probe-file old-truename) (notnot (probe-file new-truename)))))) t nil t (t t t nil nil) t nil t) (deftest rename-file.3 (let* ((pn1 (make-pathname :name "file-to-be-renamed" :type "txt" :version :newest :defaults *default-pathname-defaults*)) (pn2 (make-pathname :name "file-that-was-renamed")) (pn3 (make-pathname :name "file-that-was-renamed" :defaults pn1))) (delete-all-versions pn1) (delete-all-versions pn3) (with-open-file (s pn1 :direction :output) (format s "Whatever~%")) (let ((results (multiple-value-list (rename-file pn1 pn2)))) (destructuring-bind (defaulted-new-name old-truename new-truename) results (values (equalpt (pathname-type pn1) (pathname-type defaulted-new-name)) (=t (length results) 3) (probe-file pn1) (notnot (probe-file pn3)) (list (notnot (pathnamep defaulted-new-name)) (notnot (pathnamep old-truename)) (notnot (pathnamep new-truename)) (typep old-truename 'logical-pathname) (typep new-truename 'logical-pathname)) (notnot (probe-file defaulted-new-name)) (probe-file old-truename) (notnot (probe-file new-truename)))))) t t nil t (t t t nil nil) t nil t) (deftest rename-file.4 (let ((pn1 "file-to-be-renamed.txt") (pn2 "file-that-was-renamed.txt")) (delete-all-versions pn1) (delete-all-versions pn2) (let ((s (open pn1 :direction :output))) (format s "Whatever~%") (close s) (let ((results (multiple-value-list (rename-file s pn2)))) (destructuring-bind (defaulted-new-name old-truename new-truename) results (values (=t (length results) 3) (probe-file pn1) (notnot (probe-file pn2)) (list (notnot (pathnamep defaulted-new-name)) (notnot (pathnamep old-truename)) (notnot (pathnamep new-truename)) (typep old-truename 'logical-pathname) (typep new-truename 'logical-pathname)) (notnot (probe-file defaulted-new-name)) (probe-file old-truename) (notnot (probe-file new-truename))))))) t nil t (t t t nil nil) t nil t) (deftest rename-file.5 (let ((pn1 "CLTEST:FILE-TO-BE-RENAMED.TXT") (pn2 "CLTEST:FILE-THAT-WAS-RENAMED.TXT")) (delete-all-versions pn1) (delete-all-versions pn2) (assert (typep (pathname pn1) 'logical-pathname)) (assert (typep (pathname pn2) 'logical-pathname)) (with-open-file (s pn1 :direction :output) (format s "Whatever~%")) (let ((results (multiple-value-list (rename-file pn1 pn2)))) (destructuring-bind (defaulted-new-name old-truename new-truename) results (values (=t (length results) 3) (probe-file pn1) (notnot (probe-file pn2)) (list (notnot (pathnamep defaulted-new-name)) (notnot (pathnamep old-truename)) (notnot (pathnamep new-truename)) (typep old-truename 'logical-pathname) (typep new-truename 'logical-pathname)) (notnot (probe-file defaulted-new-name)) (probe-file old-truename) (notnot (probe-file new-truename)) (notnot (typep defaulted-new-name 'logical-pathname)) )))) t nil t (t t t nil nil) t nil t t) ;;; Specialized string tests (deftest rename-file.6 (do-special-strings (s "file-to-be-renamed.txt" nil) (let ((pn1 s) (pn2 "file-that-was-renamed.txt")) (delete-all-versions pn1) (delete-all-versions pn2) (with-open-file (s pn1 :direction :output) (format s "Whatever~%")) (let ((results (multiple-value-list (rename-file pn1 pn2)))) (destructuring-bind (defaulted-new-name old-truename new-truename) results (assert (equal (list (=t (length results) 3) (probe-file pn1) (notnot (probe-file pn2)) (list (notnot (pathnamep defaulted-new-name)) (notnot (pathnamep old-truename)) (notnot (pathnamep new-truename)) (typep old-truename 'logical-pathname) (typep new-truename 'logical-pathname)) (notnot (probe-file defaulted-new-name)) (probe-file old-truename) (notnot (probe-file new-truename))) '(t nil t (t t t nil nil) t nil t))))))) nil) (deftest rename-file.7 (do-special-strings (s "file-that-was-renamed.txt" nil) (let ((pn1 "file-to-be-renamed.txt") (pn2 s)) (delete-all-versions pn1) (delete-all-versions pn2) (with-open-file (s pn1 :direction :output) (format s "Whatever~%")) (let ((results (multiple-value-list (rename-file pn1 pn2)))) (destructuring-bind (defaulted-new-name old-truename new-truename) results (assert (equal (list (=t (length results) 3) (probe-file pn1) (notnot (probe-file pn2)) (list (notnot (pathnamep defaulted-new-name)) (notnot (pathnamep old-truename)) (notnot (pathnamep new-truename)) (typep old-truename 'logical-pathname) (typep new-truename 'logical-pathname)) (notnot (probe-file defaulted-new-name)) (probe-file old-truename) (notnot (probe-file new-truename))) '(t nil t (t t t nil nil) t nil t))))))) nil) ;;; Error tests (deftest rename-file.error.1 (signals-error (rename-file) program-error) t) gcl27-2.7.0/ansi-tests/rename-package.lsp000066400000000000000000000153161454061450500201220ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:00:28 1998 ;;;; Contains: Tests of RENAME-PACKAGE (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.7 (block nil (let ((name1 (make-array '(5) :element-type 'base-char :initial-contents "TEST1")) (name2 (make-array '(5) :element-type 'base-char :initial-contents "TEST2"))) (safely-delete-package name1) (safely-delete-package name2) (let ((p (make-package name1))) (unless (packagep p) (return nil)) (let ((p2 (rename-package name1 name2))) (unless (packagep p2) (safely-delete-package p) (return p2)) (unless (and (eqt p p2) (equal (package-name p2) name2)) (safely-delete-package p) (safely-delete-package p2) (return nil)) (safely-delete-package p2) t)))) t) (deftest rename-package.8 (block nil (let ((name1 (make-array '(10) :element-type 'base-char :fill-pointer 5 :initial-contents "TEST1 ")) (name2 (make-array '(9) :element-type 'character :fill-pointer 5 :initial-contents "TEST2XXXX"))) (safely-delete-package name1) (safely-delete-package name2) (let ((p (make-package "TEST1"))) (unless (packagep p) (return nil)) (let ((p2 (rename-package name1 name2))) (unless (packagep p2) (safely-delete-package p) (return p2)) (unless (and (eqt p p2) (string= (package-name p2) "TEST2")) (safely-delete-package p) (safely-delete-package p2) (return nil)) (safely-delete-package p2) t)))) t) (deftest rename-package.9 (block nil (let ((name1 (make-array '(5) :element-type 'character :adjustable t :initial-contents "TEST1")) (name2 (make-array '(5) :element-type 'base-char :adjustable t :initial-contents "TEST2"))) (safely-delete-package name1) (safely-delete-package name2) (let ((p (make-package "TEST1"))) (unless (packagep p) (return nil)) (let ((p2 (rename-package name1 name2))) (unless (packagep p2) (safely-delete-package p) (return p2)) (unless (and (eqt p p2) (string= (package-name p2) "TEST2")) (safely-delete-package p) (safely-delete-package p2) (return nil)) (safely-delete-package p2) t)))) t) (deftest rename-package.error.1 (signals-error (rename-package) program-error) t) (deftest rename-package.error.2 (signals-error (rename-package "CL") program-error) t) (deftest rename-package.error.3 (signals-error (rename-package "A" "XXXXX" NIL NIL) program-error) t) gcl27-2.7.0/ansi-tests/replace.lsp000066400000000000000000000413731454061450500166770ustar00rootroot00000000000000;-*- 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") (deftest replace-string.22 (do-special-strings (s "abcdefg" nil) (assert (eq s (replace s "XYZ"))) (assert (string= s "XYZdefg"))) nil) (deftest replace-string.23 (do-special-strings (s "abcdefg" nil) (assert (eq s (replace s "XYZ" :start1 1))) (assert (string= s "aXYZefg"))) nil) (deftest replace-string.24 (do-special-strings (s "abcdefg" nil) (assert (eq s (replace s "XYZ" :start1 1 :end2 2))) (assert (string= s "aXYdefg"))) nil) (deftest replace-string.25 (do-special-strings (s "abcdefg" nil) (assert (eq s (replace s "XYZ" :end1 2))) (assert (string= s "XYcdefg"))) nil) (deftest replace-string.26 (do-special-strings (s "abcdefg" nil) (assert (eq s (replace s "XYZ" :start2 1))) (assert (string= s "YZcdefg"))) nil) ;;; 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 (signals-error (replace) program-error) t) (deftest replace.error.2 (signals-error (replace nil) program-error) t) (deftest replace.error.3 (signals-error (replace nil nil :start) program-error) t) (deftest replace.error.4 (signals-error (replace nil nil 'bad t) program-error) t) (deftest replace.error.5 (signals-error (replace nil nil :allow-other-keys nil 'bad t) program-error) t) (deftest replace.error.6 (signals-error (replace nil nil 1 2) program-error) t) gcl27-2.7.0/ansi-tests/rest.lsp000066400000000000000000000007221454061450500162320ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:49:14 2003 ;;;; Contains: Tests of REST (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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 (signals-error (rest) program-error) t) (deftest rest.error.2 (signals-error (rest nil nil) program-error) t) gcl27-2.7.0/ansi-tests/restart-bind.lsp000066400000000000000000000114601454061450500176540ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Mar 21 22:28:53 2003 ;;;; Contains: Tests for RESTART-BIND (in-package :cl-test) (deftest restart-bind.1 (restart-bind () nil) nil) (deftest restart-bind.2 (restart-bind () (values))) (deftest restart-bind.3 (restart-bind () (values 'a 'b 'c 'd 'e 'f)) a b c d e f) (deftest restart-bind.4 (block nil (restart-bind () (return 'good) 'bad)) good) (deftest restart-bind.5 (block done (tagbody (restart-bind () (go 10) (return-from done 'bad)) 10 (return-from done 'good))) good) (deftest restart-bind.6 (restart-bind ()) nil) (deftest restart-bind.7 (block done (restart-bind ((foo #'(lambda () (return-from done 'good)))) (invoke-restart 'foo) 'bad)) good) (deftest restart-bind.8 (block done (restart-bind ((foo #'(lambda () (return-from done 'good)))) (let ((restart (find-restart 'foo))) (and (typep restart 'restart) (invoke-restart restart))) 'bad)) good) (deftest restart-bind.9 (restart-bind ((foo #'(lambda (a b c) (list c a b)))) (invoke-restart 'foo 1 2 3)) (3 1 2)) (deftest restart-bind.10 (flet ((%f () (invoke-restart 'foo 'x 'y 'z))) (restart-bind ((foo #'(lambda (a b c) (list c a b)))) (%f))) (z x y)) (deftest restart-bind.11 (restart-bind ((foo #'(lambda () 'bad))) (restart-bind ((foo #'(lambda () 'good))) (invoke-restart 'foo))) good) (deftest restart-bind.12 (let ((*x* 'bad)) (declare (special *x*)) (restart-bind ((foo #'(lambda () (declare (special *x*)) *x*))) (let ((*x* 'good)) (declare (special *x*)) (invoke-restart 'foo)))) good) (deftest restart-bind.13 (restart-bind ((foo #'(lambda () 'bad))) (flet ((%f () (invoke-restart 'foo))) (restart-bind ((foo #'(lambda () 'good))) (%f)))) good) (deftest restart-bind.14 (let ((x 10) (y nil)) (restart-bind ((foo #'(lambda () (when (> x 0) (push 'a y) (decf x) (invoke-restart 'foo)) y))) (invoke-restart 'foo))) (a a a a a a a a a a)) (deftest restart-bind.15 (block done (let ((i 0)) (restart-bind ((foo (progn (incf i) #'(lambda () (return-from done i))))) (invoke-restart 'foo) 'bad))) 1) (deftest restart-bind.16 (let ((i 0)) (values (with-output-to-string (s) (restart-bind ((foo #'(lambda () nil) :report-function (progn (incf i) #'(lambda (s) (format s "A report"))))) (let ((*print-escape* nil)) (format s "~A" (find-restart 'foo))))) i)) "A report" 1) (deftest restart-bind.17 (restart-bind ((foo #'(lambda () 'good)) (foo #'(lambda () 'bad))) (invoke-restart 'foo)) good) (deftest restart-bind.18 (restart-bind ((foo #'(lambda () 'good)) (bar #'(lambda () 'bad))) (invoke-restart 'foo)) good) (deftest restart-bind.19 (restart-bind ((foo #'(lambda () 'bad)) (bar #'(lambda () 'good))) (invoke-restart 'bar)) good) ;;; Using the :test-function to associate a restart with a condition ;;; This test is disabled until I figure out how to fix ;;; it. See sbcl-devel mailing list, Oct 2005 #| (deftest restart-bind.20 (let ((c (make-condition 'error))) (restart-bind ((foo #'(lambda () 'bad) :test-function #'(lambda (c1) (not (eq c c1)))) (foo #'(lambda () 'good) :test-function #'(lambda (c2) (or (null c2) (eq c c2))))) (invoke-restart (find-restart 'foo c)))) good) |# (deftest restart-bind.21 (let ((c (make-condition 'error))) (restart-bind ((foo #'(lambda () 'bad) :test-function #'(lambda (c1) nil)) (foo #'(lambda () 'good) :test-function #'(lambda (c2) t))) (invoke-restart (find-restart 'foo c)))) good) (deftest restart-bind.22 (let ((c (make-condition 'error)) (i 0)) (values (restart-bind ((foo #'(lambda () 'good) :test-function (progn (incf i) #'(lambda (c2) t)))) (invoke-restart (find-restart 'foo c))) i)) good 1) ;;; Error tests (deftest restart-bind.error.1 (signals-error (restart-bind ((foo #'(lambda () t))) (invoke-restart 'foo 'a)) program-error) t) (deftest restart-bind.error.2 (signals-error (restart-bind ((foo #'(lambda (x) x))) (invoke-restart 'foo)) program-error) t) (deftest restart-bind.error.3 (signals-error (restart-bind ((foo #'identity)) (invoke-restart 'foo)) program-error) t) (deftest restart-bind.23 (restart-bind ((foo #'(lambda () 'good))) (invoke-restart-interactively 'foo)) good) (deftest restart-bind.24 (let ((i 0)) (values (restart-bind ((foo #'(lambda (x y z) (list z y x)) :interactive-function (progn (incf i) #'(lambda () (list 'a 'b 'c))))) (invoke-restart-interactively 'foo)) i)) (c b a) 1) gcl27-2.7.0/ansi-tests/restart-case.lsp000066400000000000000000000156351454061450500176630ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 22 06:58:03 2003 ;;;; Contains: Tests for RESTART-CASE (in-package :cl-test) (deftest restart-case.1 (restart-case (values))) (deftest restart-case.2 (restart-case 1) 1) (deftest restart-case.3 (restart-case (values 'a 'b 'c 'd 'e 'f)) a b c d e f) (deftest restart-case.4 (restart-case (progn (invoke-restart 'foo) 'bad) (foo () 'good)) good) (deftest restart-case.5 (restart-case (progn (invoke-restart 'foo) 'bad) (foo ())) nil) (deftest restart-case.6 (restart-case (progn (invoke-restart 'foo) 'bad) (bar () 'bad2) (foo () 'good) (foo () 'bad3)) good) (deftest restart-case.7 (restart-case (invoke-restart 'foo 'a 'b 'c 'd) (foo (w x y z) (list z y x w))) (d c b a)) (deftest restart-case.8 (restart-case (invoke-restart 'foo :a 1 :b 2) (foo (&key a b c d) (list a b c d))) (1 2 nil nil)) (deftest restart-case.9 (restart-case (invoke-restart 'foo 1 2 3 4) (foo (&rest args) (reverse args))) (4 3 2 1)) (deftest restart-case.10 (restart-case (invoke-restart 'foo 1 2 3) (foo (a b &optional c d) (list a b c d))) (1 2 3 nil)) (deftest restart-case.11 (restart-case (invoke-restart 'foo 1 2) (foo (x y) (declare (type fixnum x y)) (+ x y))) 3) (deftest restart-case.12 (restart-case (restart-case (invoke-restart 'foo 1) (foo (x) (invoke-restart 'foo (1+ x)))) (foo (y) (+ 4 y))) 6) (deftest restart-case.13 (let ((i 10)) (values (restart-case (progn (invoke-restart 'foo) 'bad) (foo () (incf i 100) 'good)) i)) good 110) (deftest restart-case.14 (restart-case (invoke-restart 'foo 1 2) (foo (x y) (declare (type fixnum x)) (declare (type fixnum y)) (+ x y))) 3) (deftest restart-case.15 (restart-case (invoke-restart 'foo 1 2) (foo (x y) (declare (ignore x y)) (declare (type fixnum x)) (declare (type fixnum y)))) nil) (deftest restart-case.16 (restart-case (invoke-restart 'foo) (foo () (values)))) (deftest restart-case.17 (restart-case (invoke-restart 'foo) (foo () (values 'a 'b 'c 'd 'e 'f))) a b c d e f) (deftest restart-case.18 (restart-case (invoke-restart 'foo) (foo () :test (lambda (c) (declare (ignore c)) t) 'good)) good) (deftest restart-case.19 (restart-case (invoke-restart 'foo) (foo () :test (lambda (c) (declare (ignore c)) nil) 'bad) (foo () 'good)) good) (deftest restart-case.20 (with-output-to-string (s) (restart-case (let ((restart (find-restart 'foo)) (*print-escape* nil)) (format s "~A" restart)) (foo () :report "A report"))) "A report") (deftest restart-case.21 (with-output-to-string (s) (flet ((%f (s2) (format s2 "A report"))) (restart-case (let ((restart (find-restart 'foo)) (*print-escape* nil)) (format s "~A" restart)) (foo () :report %f)))) "A report") (deftest restart-case.22 (with-output-to-string (s) (restart-case (let ((restart (find-restart 'foo)) (*print-escape* nil)) (format s "~A" restart)) (foo () :report (lambda (s2) (format s2 "A report"))))) "A report") ;;; Special cases when restart-case associates the restarts with ;;; a condition (deftest restart-case.23 (handler-bind ((error #'(lambda (c) (declare (ignore c)) (invoke-restart 'foo)))) (restart-case (error "Boo!") (foo () 'good))) good) (deftest restart-case.24 (handler-bind ((error #'(lambda (c) (invoke-restart (find-restart 'foo c))))) (restart-case (error "Boo!") (foo () 'good))) good) ;;; Test that the inner restart-case has associated its restart with ;;; the condition to be raised by the error form. (deftest restart-case.25 (handler-bind ((error #'(lambda (c2) (invoke-restart (find-restart 'foo c2))))) (handler-bind ((error #'(lambda (c) (declare (ignore c)) (error "Blah")))) (restart-case (restart-case (error "Boo!") (foo () 'bad)) (foo () 'good)))) good) (deftest restart-case.26 (handler-bind ((error #'(lambda (c2) (invoke-restart (find-restart 'foo c2))))) (handler-bind ((simple-condition #'(lambda (c) (declare (ignore c)) (error "Blah")))) (restart-case (restart-case (signal "Boo!") (foo () 'bad)) (foo () 'good)))) good) (deftest restart-case.27 (handler-bind ((error #'(lambda (c2) (invoke-restart (find-restart 'foo c2))))) (handler-bind ((error #'(lambda (c) (declare (ignore c)) (error "Blah")))) (restart-case (restart-case (cerror "" "") (foo () 'bad)) (foo () 'good)))) good) (deftest restart-case.28 (handler-bind ((error #'(lambda (c2) (invoke-restart (find-restart 'foo c2))))) (handler-bind ((warning #'(lambda (c) (declare (ignore c)) (error "Blah")))) (restart-case (restart-case (warn "Boo!") (foo () 'bad)) (foo () 'good)))) good) (deftest restart-case.29 (macrolet ((%m (&rest args) (cons 'error args))) (handler-bind ((error #'(lambda (c2) (invoke-restart (find-restart 'foo c2))))) (handler-bind ((error #'(lambda (c) (declare (ignore c)) (error "Blah")))) (restart-case (restart-case (%m "Boo!") (foo () 'bad)) (foo () 'good))))) good) (deftest restart-case.30 (symbol-macrolet ((%s (error "Boo!"))) (handler-bind ((error #'(lambda (c2) (invoke-restart (find-restart 'foo c2))))) (handler-bind ((error #'(lambda (c) (declare (ignore c)) (error "Blah")))) (restart-case (restart-case %s (foo () 'bad)) (foo () 'good))))) good) (deftest restart-case.31 (macrolet ((%m2 (&rest args) (cons 'error args))) (macrolet ((%m (&rest args &environment env) (macroexpand (cons '%m2 args) env))) (handler-bind ((error #'(lambda (c2) (invoke-restart (find-restart 'foo c2))))) (handler-bind ((error #'(lambda (c) (declare (ignore c)) (error "Blah")))) (restart-case (restart-case (%m "Boo!") (foo () 'bad)) (foo () 'good)))))) good) (deftest restart-case.32 (restart-case (invoke-restart-interactively 'foo) (foo () 'good)) good) (deftest restart-case.33 (restart-case (invoke-restart-interactively 'foo) (foo (w x y z) :interactive (lambda () (list 'a 'b 'c 'd)) (list x w z y))) (b a d c)) (deftest restart-case.34 (flet ((%f () (list 'a 'b 'c 'd))) (restart-case (invoke-restart-interactively 'foo) (foo (w x y z) :interactive %f (list x w z y)))) (b a d c)) (deftest restart-case.35 (restart-case (loop for i from 1 to 4 for r in (compute-restarts) collect (restart-name r)) (foo () t) (bar () t) (foo () 'a) (nil () :report (lambda (s) (format s "Anonymous restart")) 10)) (foo bar foo nil)) (deftest restart-case.36 (let ((x :bad)) (declare (special x)) (let ((x :good)) (restart-case (invoke-restart 'foo) (foo (&aux (y x)) (declare (special x)) y)))) :good)gcl27-2.7.0/ansi-tests/return-from.lsp000066400000000000000000000010251454061450500175320ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Feb 24 20:22:23 2004 ;;;; Contains: Tests of RETURN-FROM (in-package :cl-test) ;;; RETURN-FROM is tested extensively in other files (deftest return-from.1 (block xyz (return-from xyz) :bad) nil) (deftest return-from.2 (block nil (return-from nil :good) :bad) :good) ;;; Macros are expanded in the appropriate environment (deftest return-from.3 (macrolet ((%m (z) z)) (block foo (return-from foo (expand-in-current-env (%m :good))))) :good) gcl27-2.7.0/ansi-tests/return.lsp000066400000000000000000000015501454061450500165740ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 16:00:32 2003 ;;;; Contains: Tests of RETURN (in-package :cl-test) ;;; RETURN is tested extensively in other files (deftest return.error.1 (signals-error (funcall (macro-function 'return)) program-error) t) (deftest return.error.2 (signals-error (funcall (macro-function 'return) '(return nil)) program-error) t) (deftest return.error.3 (signals-error (funcall (macro-function 'return) '(return nil) nil nil) program-error) t) ;;; (deftest return.1 (block nil (return) :bad) nil) (deftest return.2 (block nil (return :good) :bad) :good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest return.3 (macrolet ((%m (z) z)) (block nil (return (expand-in-current-env (%m :good))) :bad)) :good) gcl27-2.7.0/ansi-tests/revappend.lsp000066400000000000000000000025541454061450500172460ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:37:43 2003 ;;;; Contains: Tests of REVAPPEND (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) (def-fold-test revappend.fold.1 (revappend '(x) nil)) (def-fold-test revappend.fold.2 (revappend '(x y z) nil)) ;;; Error tests (deftest revappend.error.1 (signals-error (revappend) program-error) t) (deftest revappend.error.2 (signals-error (revappend nil) program-error) t) (deftest revappend.error.3 (signals-error (revappend nil nil nil) program-error) t) (deftest revappend.error.4 (signals-error (revappend '(a . b) '(z)) type-error) t) gcl27-2.7.0/ansi-tests/reverse.lsp000066400000000000000000000107241454061450500167330ustar00rootroot00000000000000;-*- 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-vector.3 (let ((x (make-array 0 :fill-pointer t :adjustable t))) (reverse x)) #()) (deftest reverse-vector.4 (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-vector.5 (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)) ;;; Other unusual vectors (deftest reverse-vector.6 (do-special-integer-vectors (v #(1 1 0 1 1 0) nil) (let ((nv (reverse v))) (assert (typep nv 'simple-array)) (assert (not (eql v nv))) (assert (equalp nv #(0 1 1 0 1 1))) (assert (equalp v #(1 1 0 1 1 0))))) nil) (deftest reverse-vector.7 (do-special-integer-vectors (v #(-1 -1 0 -1 -1 0) nil) (let ((nv (reverse v))) (assert (typep nv 'simple-array)) (assert (not (eql v nv))) (assert (equalp nv #(0 -1 -1 0 -1 -1))) (assert (equalp v #(-1 -1 0 -1 -1 0))))) nil) (deftest reverse-vector.8 (let ((len 10)) (loop for etype in '(short-float single-float double-float long-float rational) for vals = (loop for i from 1 to len collect (coerce i etype)) for vec = (make-array len :element-type etype :initial-contents vals) for nvec = (reverse vec) unless (and (eql (length nvec) len) (typep nvec 'simple-array) (not (eql vec nvec)) (every #'eql (reverse vals) nvec) (every #'eql vals vec)) collect (list etype vals vec nvec))) nil) (deftest reverse-vector.9 (let ((len 10)) (loop for cetype in '(short-float single-float double-float long-float rational integer) for etype = `(complex ,cetype) for vals = (loop for i from 1 to len collect (complex (coerce i cetype) (coerce (- i) cetype))) for vec = (make-array len :element-type etype :initial-contents vals) for nvec = (reverse vec) unless (and (eql (length nvec) len) (typep nvec 'simple-array) (not (eql vec nvec)) (every #'eql (reverse vals) nvec) (every #'eql vals vec)) collect (list etype vals vec nvec))) nil) ;;; Bit vectors (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) ;;; Strings (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") ;;; Specialized string tests (deftest reverse-string.5 (do-special-strings (s (copy-seq "12345") nil) (let ((s2 (reverse s))) (assert (typep s2 'simple-array)) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= "12345" s)) (assert (string= "54321" s2)))) nil) ;;; Order, number of times of evaluation (deftest reverse.order.1 (let ((i 0)) (values (reverse (progn (incf i) (list 'a 'b 'c 'd))) i)) (d c b a) 1) ;;; Constant folding tests (def-fold-test reverse.fold.1 (reverse '(a b c))) (def-fold-test reverse.fold.2 (reverse #(a b c))) (def-fold-test reverse.fold.3 (reverse #*00111101011011)) (def-fold-test reverse.fold.4 (reverse "abcdefgh")) ;;; Error cases (deftest reverse.error.1 (check-type-error #'reverse #'sequencep) nil) (deftest reverse.error.6 (signals-error (reverse) program-error) t) (deftest reverse.error.7 (signals-error (reverse nil nil) program-error) t) (deftest reverse.error.8 (signals-error (locally (reverse 'a) t) type-error) t) gcl27-2.7.0/ansi-tests/roman-numerals.lsp000066400000000000000000001261001454061450500202140ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jul 29 08:44:15 2004 ;;;; Contains: The roman numbers from 1 to 3999 (in-package :cl-test) (defparameter *roman-numerals* '("I" "II" "III" "IV" "V" "VI" "VII" "VIII" "IX" "X" "XI" "XII" "XIII" "XIV" "XV" "XVI" "XVII" "XVIII" "XIX" "XX" "XXI" "XXII" "XXIII" "XXIV" "XXV" "XXVI" "XXVII" "XXVIII" "XXIX" "XXX" "XXXI" "XXXII" "XXXIII" "XXXIV" "XXXV" "XXXVI" "XXXVII" "XXXVIII" "XXXIX" "XL" "XLI" "XLII" "XLIII" "XLIV" "XLV" "XLVI" "XLVII" "XLVIII" "XLIX" "L" "LI" "LII" "LIII" "LIV" "LV" "LVI" "LVII" "LVIII" "LIX" "LX" "LXI" "LXII" "LXIII" "LXIV" "LXV" "LXVI" "LXVII" "LXVIII" "LXIX" "LXX" "LXXI" "LXXII" "LXXIII" "LXXIV" "LXXV" "LXXVI" "LXXVII" "LXXVIII" "LXXIX" "LXXX" "LXXXI" "LXXXII" "LXXXIII" "LXXXIV" "LXXXV" "LXXXVI" "LXXXVII" "LXXXVIII" "LXXXIX" "XC" "XCI" "XCII" "XCIII" "XCIV" "XCV" "XCVI" "XCVII" "XCVIII" "XCIX" "C" "CI" "CII" "CIII" "CIV" "CV" "CVI" "CVII" "CVIII" "CIX" "CX" "CXI" "CXII" "CXIII" "CXIV" "CXV" "CXVI" "CXVII" "CXVIII" "CXIX" "CXX" "CXXI" "CXXII" "CXXIII" "CXXIV" "CXXV" "CXXVI" "CXXVII" "CXXVIII" "CXXIX" "CXXX" "CXXXI" "CXXXII" "CXXXIII" "CXXXIV" "CXXXV" "CXXXVI" "CXXXVII" "CXXXVIII" "CXXXIX" "CXL" "CXLI" "CXLII" "CXLIII" "CXLIV" "CXLV" "CXLVI" "CXLVII" "CXLVIII" "CXLIX" "CL" "CLI" "CLII" "CLIII" "CLIV" "CLV" "CLVI" "CLVII" "CLVIII" "CLIX" "CLX" "CLXI" "CLXII" "CLXIII" "CLXIV" "CLXV" "CLXVI" "CLXVII" "CLXVIII" "CLXIX" "CLXX" "CLXXI" "CLXXII" "CLXXIII" "CLXXIV" "CLXXV" "CLXXVI" "CLXXVII" "CLXXVIII" "CLXXIX" "CLXXX" "CLXXXI" "CLXXXII" "CLXXXIII" "CLXXXIV" "CLXXXV" "CLXXXVI" "CLXXXVII" "CLXXXVIII" "CLXXXIX" "CXC" "CXCI" "CXCII" "CXCIII" "CXCIV" "CXCV" "CXCVI" "CXCVII" "CXCVIII" "CXCIX" "CC" "CCI" "CCII" "CCIII" "CCIV" "CCV" "CCVI" "CCVII" "CCVIII" "CCIX" "CCX" "CCXI" "CCXII" "CCXIII" "CCXIV" "CCXV" "CCXVI" "CCXVII" "CCXVIII" "CCXIX" "CCXX" "CCXXI" "CCXXII" "CCXXIII" "CCXXIV" "CCXXV" "CCXXVI" "CCXXVII" "CCXXVIII" "CCXXIX" "CCXXX" "CCXXXI" "CCXXXII" "CCXXXIII" "CCXXXIV" "CCXXXV" "CCXXXVI" "CCXXXVII" "CCXXXVIII" "CCXXXIX" "CCXL" "CCXLI" "CCXLII" "CCXLIII" "CCXLIV" "CCXLV" "CCXLVI" "CCXLVII" "CCXLVIII" "CCXLIX" "CCL" "CCLI" "CCLII" "CCLIII" "CCLIV" "CCLV" "CCLVI" "CCLVII" "CCLVIII" "CCLIX" "CCLX" "CCLXI" "CCLXII" "CCLXIII" "CCLXIV" "CCLXV" "CCLXVI" "CCLXVII" "CCLXVIII" "CCLXIX" "CCLXX" "CCLXXI" "CCLXXII" "CCLXXIII" "CCLXXIV" "CCLXXV" "CCLXXVI" "CCLXXVII" "CCLXXVIII" "CCLXXIX" "CCLXXX" "CCLXXXI" "CCLXXXII" "CCLXXXIII" "CCLXXXIV" "CCLXXXV" "CCLXXXVI" "CCLXXXVII" "CCLXXXVIII" "CCLXXXIX" "CCXC" "CCXCI" "CCXCII" "CCXCIII" "CCXCIV" "CCXCV" "CCXCVI" "CCXCVII" "CCXCVIII" "CCXCIX" "CCC" "CCCI" "CCCII" "CCCIII" "CCCIV" "CCCV" "CCCVI" "CCCVII" "CCCVIII" "CCCIX" "CCCX" "CCCXI" "CCCXII" "CCCXIII" "CCCXIV" "CCCXV" "CCCXVI" "CCCXVII" "CCCXVIII" "CCCXIX" "CCCXX" "CCCXXI" "CCCXXII" "CCCXXIII" "CCCXXIV" "CCCXXV" "CCCXXVI" "CCCXXVII" "CCCXXVIII" "CCCXXIX" "CCCXXX" "CCCXXXI" "CCCXXXII" "CCCXXXIII" "CCCXXXIV" "CCCXXXV" "CCCXXXVI" "CCCXXXVII" "CCCXXXVIII" "CCCXXXIX" "CCCXL" "CCCXLI" "CCCXLII" "CCCXLIII" "CCCXLIV" "CCCXLV" "CCCXLVI" "CCCXLVII" "CCCXLVIII" "CCCXLIX" "CCCL" "CCCLI" "CCCLII" "CCCLIII" "CCCLIV" "CCCLV" "CCCLVI" "CCCLVII" "CCCLVIII" "CCCLIX" "CCCLX" "CCCLXI" "CCCLXII" "CCCLXIII" "CCCLXIV" "CCCLXV" "CCCLXVI" "CCCLXVII" "CCCLXVIII" "CCCLXIX" "CCCLXX" "CCCLXXI" "CCCLXXII" "CCCLXXIII" "CCCLXXIV" "CCCLXXV" "CCCLXXVI" "CCCLXXVII" "CCCLXXVIII" "CCCLXXIX" "CCCLXXX" "CCCLXXXI" "CCCLXXXII" "CCCLXXXIII" "CCCLXXXIV" "CCCLXXXV" "CCCLXXXVI" "CCCLXXXVII" "CCCLXXXVIII" "CCCLXXXIX" "CCCXC" "CCCXCI" "CCCXCII" "CCCXCIII" "CCCXCIV" "CCCXCV" "CCCXCVI" "CCCXCVII" "CCCXCVIII" "CCCXCIX" "CD" "CDI" "CDII" "CDIII" "CDIV" "CDV" "CDVI" "CDVII" "CDVIII" "CDIX" "CDX" "CDXI" "CDXII" "CDXIII" "CDXIV" "CDXV" "CDXVI" "CDXVII" "CDXVIII" "CDXIX" "CDXX" "CDXXI" "CDXXII" "CDXXIII" "CDXXIV" "CDXXV" "CDXXVI" "CDXXVII" "CDXXVIII" "CDXXIX" "CDXXX" "CDXXXI" "CDXXXII" "CDXXXIII" "CDXXXIV" "CDXXXV" "CDXXXVI" "CDXXXVII" "CDXXXVIII" "CDXXXIX" "CDXL" "CDXLI" "CDXLII" "CDXLIII" "CDXLIV" "CDXLV" "CDXLVI" "CDXLVII" "CDXLVIII" "CDXLIX" "CDL" "CDLI" "CDLII" "CDLIII" "CDLIV" "CDLV" "CDLVI" "CDLVII" "CDLVIII" "CDLIX" "CDLX" "CDLXI" "CDLXII" "CDLXIII" "CDLXIV" "CDLXV" "CDLXVI" "CDLXVII" "CDLXVIII" "CDLXIX" "CDLXX" "CDLXXI" "CDLXXII" "CDLXXIII" "CDLXXIV" "CDLXXV" "CDLXXVI" "CDLXXVII" "CDLXXVIII" "CDLXXIX" "CDLXXX" "CDLXXXI" "CDLXXXII" "CDLXXXIII" "CDLXXXIV" "CDLXXXV" "CDLXXXVI" "CDLXXXVII" "CDLXXXVIII" "CDLXXXIX" "CDXC" "CDXCI" "CDXCII" "CDXCIII" "CDXCIV" "CDXCV" "CDXCVI" "CDXCVII" "CDXCVIII" "CDXCIX" "D" "DI" "DII" "DIII" "DIV" "DV" "DVI" "DVII" "DVIII" "DIX" "DX" "DXI" "DXII" "DXIII" "DXIV" "DXV" "DXVI" "DXVII" "DXVIII" "DXIX" "DXX" "DXXI" "DXXII" "DXXIII" "DXXIV" "DXXV" "DXXVI" "DXXVII" "DXXVIII" "DXXIX" "DXXX" "DXXXI" "DXXXII" "DXXXIII" "DXXXIV" "DXXXV" "DXXXVI" "DXXXVII" "DXXXVIII" "DXXXIX" "DXL" "DXLI" "DXLII" "DXLIII" "DXLIV" "DXLV" "DXLVI" "DXLVII" "DXLVIII" "DXLIX" "DL" "DLI" "DLII" "DLIII" "DLIV" "DLV" "DLVI" "DLVII" "DLVIII" "DLIX" "DLX" "DLXI" "DLXII" "DLXIII" "DLXIV" "DLXV" "DLXVI" "DLXVII" "DLXVIII" "DLXIX" "DLXX" "DLXXI" "DLXXII" "DLXXIII" "DLXXIV" "DLXXV" "DLXXVI" "DLXXVII" "DLXXVIII" "DLXXIX" "DLXXX" "DLXXXI" "DLXXXII" "DLXXXIII" "DLXXXIV" "DLXXXV" "DLXXXVI" "DLXXXVII" "DLXXXVIII" "DLXXXIX" "DXC" "DXCI" "DXCII" "DXCIII" "DXCIV" "DXCV" "DXCVI" "DXCVII" "DXCVIII" "DXCIX" "DC" "DCI" "DCII" "DCIII" "DCIV" "DCV" "DCVI" "DCVII" "DCVIII" "DCIX" "DCX" "DCXI" "DCXII" "DCXIII" "DCXIV" "DCXV" "DCXVI" "DCXVII" "DCXVIII" "DCXIX" "DCXX" "DCXXI" "DCXXII" "DCXXIII" "DCXXIV" "DCXXV" "DCXXVI" "DCXXVII" "DCXXVIII" "DCXXIX" "DCXXX" "DCXXXI" "DCXXXII" "DCXXXIII" "DCXXXIV" "DCXXXV" "DCXXXVI" "DCXXXVII" "DCXXXVIII" "DCXXXIX" "DCXL" "DCXLI" "DCXLII" "DCXLIII" "DCXLIV" "DCXLV" "DCXLVI" "DCXLVII" "DCXLVIII" "DCXLIX" "DCL" "DCLI" "DCLII" "DCLIII" "DCLIV" "DCLV" "DCLVI" "DCLVII" "DCLVIII" "DCLIX" "DCLX" "DCLXI" "DCLXII" "DCLXIII" "DCLXIV" "DCLXV" "DCLXVI" "DCLXVII" "DCLXVIII" "DCLXIX" "DCLXX" "DCLXXI" "DCLXXII" "DCLXXIII" "DCLXXIV" "DCLXXV" "DCLXXVI" "DCLXXVII" "DCLXXVIII" "DCLXXIX" "DCLXXX" "DCLXXXI" "DCLXXXII" "DCLXXXIII" "DCLXXXIV" "DCLXXXV" "DCLXXXVI" "DCLXXXVII" "DCLXXXVIII" "DCLXXXIX" "DCXC" "DCXCI" "DCXCII" "DCXCIII" "DCXCIV" "DCXCV" "DCXCVI" "DCXCVII" "DCXCVIII" "DCXCIX" "DCC" "DCCI" "DCCII" "DCCIII" "DCCIV" "DCCV" "DCCVI" "DCCVII" "DCCVIII" "DCCIX" "DCCX" "DCCXI" "DCCXII" "DCCXIII" "DCCXIV" "DCCXV" "DCCXVI" "DCCXVII" "DCCXVIII" "DCCXIX" "DCCXX" "DCCXXI" "DCCXXII" "DCCXXIII" "DCCXXIV" "DCCXXV" "DCCXXVI" "DCCXXVII" "DCCXXVIII" "DCCXXIX" "DCCXXX" "DCCXXXI" "DCCXXXII" "DCCXXXIII" "DCCXXXIV" "DCCXXXV" "DCCXXXVI" "DCCXXXVII" "DCCXXXVIII" "DCCXXXIX" "DCCXL" "DCCXLI" "DCCXLII" "DCCXLIII" "DCCXLIV" "DCCXLV" "DCCXLVI" "DCCXLVII" "DCCXLVIII" "DCCXLIX" "DCCL" "DCCLI" "DCCLII" "DCCLIII" "DCCLIV" "DCCLV" "DCCLVI" "DCCLVII" "DCCLVIII" "DCCLIX" "DCCLX" "DCCLXI" "DCCLXII" "DCCLXIII" "DCCLXIV" "DCCLXV" "DCCLXVI" "DCCLXVII" "DCCLXVIII" "DCCLXIX" "DCCLXX" "DCCLXXI" "DCCLXXII" "DCCLXXIII" "DCCLXXIV" "DCCLXXV" "DCCLXXVI" "DCCLXXVII" "DCCLXXVIII" "DCCLXXIX" "DCCLXXX" "DCCLXXXI" "DCCLXXXII" "DCCLXXXIII" "DCCLXXXIV" "DCCLXXXV" "DCCLXXXVI" "DCCLXXXVII" "DCCLXXXVIII" "DCCLXXXIX" "DCCXC" "DCCXCI" "DCCXCII" "DCCXCIII" "DCCXCIV" "DCCXCV" "DCCXCVI" "DCCXCVII" "DCCXCVIII" "DCCXCIX" "DCCC" "DCCCI" "DCCCII" "DCCCIII" "DCCCIV" "DCCCV" "DCCCVI" "DCCCVII" "DCCCVIII" "DCCCIX" "DCCCX" "DCCCXI" "DCCCXII" "DCCCXIII" "DCCCXIV" "DCCCXV" "DCCCXVI" "DCCCXVII" "DCCCXVIII" "DCCCXIX" "DCCCXX" "DCCCXXI" "DCCCXXII" "DCCCXXIII" "DCCCXXIV" "DCCCXXV" "DCCCXXVI" "DCCCXXVII" "DCCCXXVIII" "DCCCXXIX" "DCCCXXX" "DCCCXXXI" "DCCCXXXII" "DCCCXXXIII" "DCCCXXXIV" "DCCCXXXV" "DCCCXXXVI" "DCCCXXXVII" "DCCCXXXVIII" "DCCCXXXIX" "DCCCXL" "DCCCXLI" "DCCCXLII" "DCCCXLIII" "DCCCXLIV" "DCCCXLV" "DCCCXLVI" "DCCCXLVII" "DCCCXLVIII" "DCCCXLIX" "DCCCL" "DCCCLI" "DCCCLII" "DCCCLIII" "DCCCLIV" "DCCCLV" "DCCCLVI" "DCCCLVII" "DCCCLVIII" "DCCCLIX" "DCCCLX" "DCCCLXI" "DCCCLXII" "DCCCLXIII" "DCCCLXIV" "DCCCLXV" "DCCCLXVI" "DCCCLXVII" "DCCCLXVIII" "DCCCLXIX" "DCCCLXX" "DCCCLXXI" "DCCCLXXII" "DCCCLXXIII" "DCCCLXXIV" "DCCCLXXV" "DCCCLXXVI" "DCCCLXXVII" "DCCCLXXVIII" "DCCCLXXIX" "DCCCLXXX" "DCCCLXXXI" "DCCCLXXXII" "DCCCLXXXIII" "DCCCLXXXIV" "DCCCLXXXV" "DCCCLXXXVI" "DCCCLXXXVII" "DCCCLXXXVIII" "DCCCLXXXIX" "DCCCXC" "DCCCXCI" "DCCCXCII" "DCCCXCIII" "DCCCXCIV" "DCCCXCV" "DCCCXCVI" "DCCCXCVII" "DCCCXCVIII" "DCCCXCIX" "CM" "CMI" "CMII" "CMIII" "CMIV" "CMV" "CMVI" "CMVII" "CMVIII" "CMIX" "CMX" "CMXI" "CMXII" "CMXIII" "CMXIV" "CMXV" "CMXVI" "CMXVII" "CMXVIII" "CMXIX" "CMXX" "CMXXI" "CMXXII" "CMXXIII" "CMXXIV" "CMXXV" "CMXXVI" "CMXXVII" "CMXXVIII" "CMXXIX" "CMXXX" "CMXXXI" "CMXXXII" "CMXXXIII" "CMXXXIV" "CMXXXV" "CMXXXVI" "CMXXXVII" "CMXXXVIII" "CMXXXIX" "CMXL" "CMXLI" "CMXLII" "CMXLIII" "CMXLIV" "CMXLV" "CMXLVI" "CMXLVII" "CMXLVIII" "CMXLIX" "CML" "CMLI" "CMLII" "CMLIII" "CMLIV" "CMLV" "CMLVI" "CMLVII" "CMLVIII" "CMLIX" "CMLX" "CMLXI" "CMLXII" "CMLXIII" "CMLXIV" "CMLXV" "CMLXVI" "CMLXVII" "CMLXVIII" "CMLXIX" "CMLXX" "CMLXXI" "CMLXXII" "CMLXXIII" "CMLXXIV" "CMLXXV" "CMLXXVI" "CMLXXVII" "CMLXXVIII" "CMLXXIX" "CMLXXX" "CMLXXXI" "CMLXXXII" "CMLXXXIII" "CMLXXXIV" "CMLXXXV" "CMLXXXVI" "CMLXXXVII" "CMLXXXVIII" "CMLXXXIX" "CMXC" "CMXCI" "CMXCII" "CMXCIII" "CMXCIV" "CMXCV" "CMXCVI" "CMXCVII" "CMXCVIII" "CMXCIX" "M" "MI" "MII" "MIII" "MIV" "MV" "MVI" "MVII" "MVIII" "MIX" "MX" "MXI" "MXII" "MXIII" "MXIV" "MXV" "MXVI" "MXVII" "MXVIII" "MXIX" "MXX" "MXXI" "MXXII" "MXXIII" "MXXIV" "MXXV" "MXXVI" "MXXVII" "MXXVIII" "MXXIX" "MXXX" "MXXXI" "MXXXII" "MXXXIII" "MXXXIV" "MXXXV" "MXXXVI" "MXXXVII" "MXXXVIII" "MXXXIX" "MXL" "MXLI" "MXLII" "MXLIII" "MXLIV" "MXLV" "MXLVI" "MXLVII" "MXLVIII" "MXLIX" "ML" "MLI" "MLII" "MLIII" "MLIV" "MLV" "MLVI" "MLVII" "MLVIII" "MLIX" "MLX" "MLXI" "MLXII" "MLXIII" "MLXIV" "MLXV" "MLXVI" "MLXVII" "MLXVIII" "MLXIX" "MLXX" "MLXXI" "MLXXII" "MLXXIII" "MLXXIV" "MLXXV" "MLXXVI" "MLXXVII" "MLXXVIII" "MLXXIX" "MLXXX" "MLXXXI" "MLXXXII" "MLXXXIII" "MLXXXIV" "MLXXXV" "MLXXXVI" "MLXXXVII" "MLXXXVIII" "MLXXXIX" "MXC" "MXCI" "MXCII" "MXCIII" "MXCIV" "MXCV" "MXCVI" "MXCVII" "MXCVIII" "MXCIX" "MC" "MCI" "MCII" "MCIII" "MCIV" "MCV" "MCVI" "MCVII" "MCVIII" "MCIX" "MCX" "MCXI" "MCXII" "MCXIII" "MCXIV" "MCXV" "MCXVI" "MCXVII" "MCXVIII" "MCXIX" "MCXX" "MCXXI" "MCXXII" "MCXXIII" "MCXXIV" "MCXXV" "MCXXVI" "MCXXVII" "MCXXVIII" "MCXXIX" "MCXXX" "MCXXXI" "MCXXXII" "MCXXXIII" "MCXXXIV" "MCXXXV" "MCXXXVI" "MCXXXVII" "MCXXXVIII" "MCXXXIX" "MCXL" "MCXLI" "MCXLII" "MCXLIII" "MCXLIV" "MCXLV" "MCXLVI" "MCXLVII" "MCXLVIII" "MCXLIX" "MCL" "MCLI" "MCLII" "MCLIII" "MCLIV" "MCLV" "MCLVI" "MCLVII" "MCLVIII" "MCLIX" "MCLX" "MCLXI" "MCLXII" "MCLXIII" "MCLXIV" "MCLXV" "MCLXVI" "MCLXVII" "MCLXVIII" "MCLXIX" "MCLXX" "MCLXXI" "MCLXXII" "MCLXXIII" "MCLXXIV" "MCLXXV" "MCLXXVI" "MCLXXVII" "MCLXXVIII" "MCLXXIX" "MCLXXX" "MCLXXXI" "MCLXXXII" "MCLXXXIII" "MCLXXXIV" "MCLXXXV" "MCLXXXVI" "MCLXXXVII" "MCLXXXVIII" "MCLXXXIX" "MCXC" "MCXCI" "MCXCII" "MCXCIII" "MCXCIV" "MCXCV" "MCXCVI" "MCXCVII" "MCXCVIII" "MCXCIX" "MCC" "MCCI" "MCCII" "MCCIII" "MCCIV" "MCCV" "MCCVI" "MCCVII" "MCCVIII" "MCCIX" "MCCX" "MCCXI" "MCCXII" "MCCXIII" "MCCXIV" "MCCXV" "MCCXVI" "MCCXVII" "MCCXVIII" "MCCXIX" "MCCXX" "MCCXXI" "MCCXXII" "MCCXXIII" "MCCXXIV" "MCCXXV" "MCCXXVI" "MCCXXVII" "MCCXXVIII" "MCCXXIX" "MCCXXX" "MCCXXXI" "MCCXXXII" "MCCXXXIII" "MCCXXXIV" "MCCXXXV" "MCCXXXVI" "MCCXXXVII" "MCCXXXVIII" "MCCXXXIX" "MCCXL" "MCCXLI" "MCCXLII" "MCCXLIII" "MCCXLIV" "MCCXLV" "MCCXLVI" "MCCXLVII" "MCCXLVIII" "MCCXLIX" "MCCL" "MCCLI" "MCCLII" "MCCLIII" "MCCLIV" "MCCLV" "MCCLVI" "MCCLVII" "MCCLVIII" "MCCLIX" "MCCLX" "MCCLXI" "MCCLXII" "MCCLXIII" "MCCLXIV" "MCCLXV" "MCCLXVI" "MCCLXVII" "MCCLXVIII" "MCCLXIX" "MCCLXX" "MCCLXXI" "MCCLXXII" "MCCLXXIII" "MCCLXXIV" "MCCLXXV" "MCCLXXVI" "MCCLXXVII" "MCCLXXVIII" "MCCLXXIX" "MCCLXXX" "MCCLXXXI" "MCCLXXXII" "MCCLXXXIII" "MCCLXXXIV" "MCCLXXXV" "MCCLXXXVI" "MCCLXXXVII" "MCCLXXXVIII" "MCCLXXXIX" "MCCXC" "MCCXCI" "MCCXCII" "MCCXCIII" "MCCXCIV" "MCCXCV" "MCCXCVI" "MCCXCVII" "MCCXCVIII" "MCCXCIX" "MCCC" "MCCCI" "MCCCII" "MCCCIII" "MCCCIV" "MCCCV" "MCCCVI" "MCCCVII" "MCCCVIII" "MCCCIX" "MCCCX" "MCCCXI" "MCCCXII" "MCCCXIII" "MCCCXIV" "MCCCXV" "MCCCXVI" "MCCCXVII" "MCCCXVIII" "MCCCXIX" "MCCCXX" "MCCCXXI" "MCCCXXII" "MCCCXXIII" "MCCCXXIV" "MCCCXXV" "MCCCXXVI" "MCCCXXVII" "MCCCXXVIII" "MCCCXXIX" "MCCCXXX" "MCCCXXXI" "MCCCXXXII" "MCCCXXXIII" "MCCCXXXIV" "MCCCXXXV" "MCCCXXXVI" "MCCCXXXVII" "MCCCXXXVIII" "MCCCXXXIX" "MCCCXL" "MCCCXLI" "MCCCXLII" "MCCCXLIII" "MCCCXLIV" "MCCCXLV" "MCCCXLVI" "MCCCXLVII" "MCCCXLVIII" "MCCCXLIX" "MCCCL" "MCCCLI" "MCCCLII" "MCCCLIII" "MCCCLIV" "MCCCLV" "MCCCLVI" "MCCCLVII" "MCCCLVIII" "MCCCLIX" "MCCCLX" "MCCCLXI" "MCCCLXII" "MCCCLXIII" "MCCCLXIV" "MCCCLXV" "MCCCLXVI" "MCCCLXVII" "MCCCLXVIII" "MCCCLXIX" "MCCCLXX" "MCCCLXXI" "MCCCLXXII" "MCCCLXXIII" "MCCCLXXIV" "MCCCLXXV" "MCCCLXXVI" "MCCCLXXVII" "MCCCLXXVIII" "MCCCLXXIX" "MCCCLXXX" "MCCCLXXXI" "MCCCLXXXII" "MCCCLXXXIII" "MCCCLXXXIV" "MCCCLXXXV" "MCCCLXXXVI" "MCCCLXXXVII" "MCCCLXXXVIII" "MCCCLXXXIX" "MCCCXC" "MCCCXCI" "MCCCXCII" "MCCCXCIII" "MCCCXCIV" "MCCCXCV" "MCCCXCVI" "MCCCXCVII" "MCCCXCVIII" "MCCCXCIX" "MCD" "MCDI" "MCDII" "MCDIII" "MCDIV" "MCDV" "MCDVI" "MCDVII" "MCDVIII" "MCDIX" "MCDX" "MCDXI" "MCDXII" "MCDXIII" "MCDXIV" "MCDXV" "MCDXVI" "MCDXVII" "MCDXVIII" "MCDXIX" "MCDXX" "MCDXXI" "MCDXXII" "MCDXXIII" "MCDXXIV" "MCDXXV" "MCDXXVI" "MCDXXVII" "MCDXXVIII" "MCDXXIX" "MCDXXX" "MCDXXXI" "MCDXXXII" "MCDXXXIII" "MCDXXXIV" "MCDXXXV" "MCDXXXVI" "MCDXXXVII" "MCDXXXVIII" "MCDXXXIX" "MCDXL" "MCDXLI" "MCDXLII" "MCDXLIII" "MCDXLIV" "MCDXLV" "MCDXLVI" "MCDXLVII" "MCDXLVIII" "MCDXLIX" "MCDL" "MCDLI" "MCDLII" "MCDLIII" "MCDLIV" "MCDLV" "MCDLVI" "MCDLVII" "MCDLVIII" "MCDLIX" "MCDLX" "MCDLXI" "MCDLXII" "MCDLXIII" "MCDLXIV" "MCDLXV" "MCDLXVI" "MCDLXVII" "MCDLXVIII" "MCDLXIX" "MCDLXX" "MCDLXXI" "MCDLXXII" "MCDLXXIII" "MCDLXXIV" "MCDLXXV" "MCDLXXVI" "MCDLXXVII" "MCDLXXVIII" "MCDLXXIX" "MCDLXXX" "MCDLXXXI" "MCDLXXXII" "MCDLXXXIII" "MCDLXXXIV" "MCDLXXXV" "MCDLXXXVI" "MCDLXXXVII" "MCDLXXXVIII" "MCDLXXXIX" "MCDXC" "MCDXCI" "MCDXCII" "MCDXCIII" "MCDXCIV" "MCDXCV" "MCDXCVI" "MCDXCVII" "MCDXCVIII" "MCDXCIX" "MD" "MDI" "MDII" "MDIII" "MDIV" "MDV" "MDVI" "MDVII" "MDVIII" "MDIX" "MDX" "MDXI" "MDXII" "MDXIII" "MDXIV" "MDXV" "MDXVI" "MDXVII" "MDXVIII" "MDXIX" "MDXX" "MDXXI" "MDXXII" "MDXXIII" "MDXXIV" "MDXXV" "MDXXVI" "MDXXVII" "MDXXVIII" "MDXXIX" "MDXXX" "MDXXXI" "MDXXXII" "MDXXXIII" "MDXXXIV" "MDXXXV" "MDXXXVI" "MDXXXVII" "MDXXXVIII" "MDXXXIX" "MDXL" "MDXLI" "MDXLII" "MDXLIII" "MDXLIV" "MDXLV" "MDXLVI" "MDXLVII" "MDXLVIII" "MDXLIX" "MDL" "MDLI" "MDLII" "MDLIII" "MDLIV" "MDLV" "MDLVI" "MDLVII" "MDLVIII" "MDLIX" "MDLX" "MDLXI" "MDLXII" "MDLXIII" "MDLXIV" "MDLXV" "MDLXVI" "MDLXVII" "MDLXVIII" "MDLXIX" "MDLXX" "MDLXXI" "MDLXXII" "MDLXXIII" "MDLXXIV" "MDLXXV" "MDLXXVI" "MDLXXVII" "MDLXXVIII" "MDLXXIX" "MDLXXX" "MDLXXXI" "MDLXXXII" "MDLXXXIII" "MDLXXXIV" "MDLXXXV" "MDLXXXVI" "MDLXXXVII" "MDLXXXVIII" "MDLXXXIX" "MDXC" "MDXCI" "MDXCII" "MDXCIII" "MDXCIV" "MDXCV" "MDXCVI" "MDXCVII" "MDXCVIII" "MDXCIX" "MDC" "MDCI" "MDCII" "MDCIII" "MDCIV" "MDCV" "MDCVI" "MDCVII" "MDCVIII" "MDCIX" "MDCX" "MDCXI" "MDCXII" "MDCXIII" "MDCXIV" "MDCXV" "MDCXVI" "MDCXVII" "MDCXVIII" "MDCXIX" "MDCXX" "MDCXXI" "MDCXXII" "MDCXXIII" "MDCXXIV" "MDCXXV" "MDCXXVI" "MDCXXVII" "MDCXXVIII" "MDCXXIX" "MDCXXX" "MDCXXXI" "MDCXXXII" "MDCXXXIII" "MDCXXXIV" "MDCXXXV" "MDCXXXVI" "MDCXXXVII" "MDCXXXVIII" "MDCXXXIX" "MDCXL" "MDCXLI" "MDCXLII" "MDCXLIII" "MDCXLIV" "MDCXLV" "MDCXLVI" "MDCXLVII" "MDCXLVIII" "MDCXLIX" "MDCL" "MDCLI" "MDCLII" "MDCLIII" "MDCLIV" "MDCLV" "MDCLVI" "MDCLVII" "MDCLVIII" "MDCLIX" "MDCLX" "MDCLXI" "MDCLXII" "MDCLXIII" "MDCLXIV" "MDCLXV" "MDCLXVI" "MDCLXVII" "MDCLXVIII" "MDCLXIX" "MDCLXX" "MDCLXXI" "MDCLXXII" "MDCLXXIII" "MDCLXXIV" "MDCLXXV" "MDCLXXVI" "MDCLXXVII" "MDCLXXVIII" "MDCLXXIX" "MDCLXXX" "MDCLXXXI" "MDCLXXXII" "MDCLXXXIII" "MDCLXXXIV" "MDCLXXXV" "MDCLXXXVI" "MDCLXXXVII" "MDCLXXXVIII" "MDCLXXXIX" "MDCXC" "MDCXCI" "MDCXCII" "MDCXCIII" "MDCXCIV" "MDCXCV" "MDCXCVI" "MDCXCVII" "MDCXCVIII" "MDCXCIX" "MDCC" "MDCCI" "MDCCII" "MDCCIII" "MDCCIV" "MDCCV" "MDCCVI" "MDCCVII" "MDCCVIII" "MDCCIX" "MDCCX" "MDCCXI" "MDCCXII" "MDCCXIII" "MDCCXIV" "MDCCXV" "MDCCXVI" "MDCCXVII" "MDCCXVIII" "MDCCXIX" "MDCCXX" "MDCCXXI" "MDCCXXII" "MDCCXXIII" "MDCCXXIV" "MDCCXXV" "MDCCXXVI" "MDCCXXVII" "MDCCXXVIII" "MDCCXXIX" "MDCCXXX" "MDCCXXXI" "MDCCXXXII" "MDCCXXXIII" "MDCCXXXIV" "MDCCXXXV" "MDCCXXXVI" "MDCCXXXVII" "MDCCXXXVIII" "MDCCXXXIX" "MDCCXL" "MDCCXLI" "MDCCXLII" "MDCCXLIII" "MDCCXLIV" "MDCCXLV" "MDCCXLVI" "MDCCXLVII" "MDCCXLVIII" "MDCCXLIX" "MDCCL" "MDCCLI" "MDCCLII" "MDCCLIII" "MDCCLIV" "MDCCLV" "MDCCLVI" "MDCCLVII" "MDCCLVIII" "MDCCLIX" "MDCCLX" "MDCCLXI" "MDCCLXII" "MDCCLXIII" "MDCCLXIV" "MDCCLXV" "MDCCLXVI" "MDCCLXVII" "MDCCLXVIII" "MDCCLXIX" "MDCCLXX" "MDCCLXXI" "MDCCLXXII" "MDCCLXXIII" "MDCCLXXIV" "MDCCLXXV" "MDCCLXXVI" "MDCCLXXVII" "MDCCLXXVIII" "MDCCLXXIX" "MDCCLXXX" "MDCCLXXXI" "MDCCLXXXII" "MDCCLXXXIII" "MDCCLXXXIV" "MDCCLXXXV" "MDCCLXXXVI" "MDCCLXXXVII" "MDCCLXXXVIII" "MDCCLXXXIX" "MDCCXC" "MDCCXCI" "MDCCXCII" "MDCCXCIII" "MDCCXCIV" "MDCCXCV" "MDCCXCVI" "MDCCXCVII" "MDCCXCVIII" "MDCCXCIX" "MDCCC" "MDCCCI" "MDCCCII" "MDCCCIII" "MDCCCIV" "MDCCCV" "MDCCCVI" "MDCCCVII" "MDCCCVIII" "MDCCCIX" "MDCCCX" "MDCCCXI" "MDCCCXII" "MDCCCXIII" "MDCCCXIV" "MDCCCXV" "MDCCCXVI" "MDCCCXVII" "MDCCCXVIII" "MDCCCXIX" "MDCCCXX" "MDCCCXXI" "MDCCCXXII" "MDCCCXXIII" "MDCCCXXIV" "MDCCCXXV" "MDCCCXXVI" "MDCCCXXVII" "MDCCCXXVIII" "MDCCCXXIX" "MDCCCXXX" "MDCCCXXXI" "MDCCCXXXII" "MDCCCXXXIII" "MDCCCXXXIV" "MDCCCXXXV" "MDCCCXXXVI" "MDCCCXXXVII" "MDCCCXXXVIII" "MDCCCXXXIX" "MDCCCXL" "MDCCCXLI" "MDCCCXLII" "MDCCCXLIII" "MDCCCXLIV" "MDCCCXLV" "MDCCCXLVI" "MDCCCXLVII" "MDCCCXLVIII" "MDCCCXLIX" "MDCCCL" "MDCCCLI" "MDCCCLII" "MDCCCLIII" "MDCCCLIV" "MDCCCLV" "MDCCCLVI" "MDCCCLVII" "MDCCCLVIII" "MDCCCLIX" "MDCCCLX" "MDCCCLXI" "MDCCCLXII" "MDCCCLXIII" "MDCCCLXIV" "MDCCCLXV" "MDCCCLXVI" "MDCCCLXVII" "MDCCCLXVIII" "MDCCCLXIX" "MDCCCLXX" "MDCCCLXXI" "MDCCCLXXII" "MDCCCLXXIII" "MDCCCLXXIV" "MDCCCLXXV" "MDCCCLXXVI" "MDCCCLXXVII" "MDCCCLXXVIII" "MDCCCLXXIX" "MDCCCLXXX" "MDCCCLXXXI" "MDCCCLXXXII" "MDCCCLXXXIII" "MDCCCLXXXIV" "MDCCCLXXXV" "MDCCCLXXXVI" "MDCCCLXXXVII" "MDCCCLXXXVIII" "MDCCCLXXXIX" "MDCCCXC" "MDCCCXCI" "MDCCCXCII" "MDCCCXCIII" "MDCCCXCIV" "MDCCCXCV" "MDCCCXCVI" "MDCCCXCVII" "MDCCCXCVIII" "MDCCCXCIX" "MCM" "MCMI" "MCMII" "MCMIII" "MCMIV" "MCMV" "MCMVI" "MCMVII" "MCMVIII" "MCMIX" "MCMX" "MCMXI" "MCMXII" "MCMXIII" "MCMXIV" "MCMXV" "MCMXVI" "MCMXVII" "MCMXVIII" "MCMXIX" "MCMXX" "MCMXXI" "MCMXXII" "MCMXXIII" "MCMXXIV" "MCMXXV" "MCMXXVI" "MCMXXVII" "MCMXXVIII" "MCMXXIX" "MCMXXX" "MCMXXXI" "MCMXXXII" "MCMXXXIII" "MCMXXXIV" "MCMXXXV" "MCMXXXVI" "MCMXXXVII" "MCMXXXVIII" "MCMXXXIX" "MCMXL" "MCMXLI" "MCMXLII" "MCMXLIII" "MCMXLIV" "MCMXLV" "MCMXLVI" "MCMXLVII" "MCMXLVIII" "MCMXLIX" "MCML" "MCMLI" "MCMLII" "MCMLIII" "MCMLIV" "MCMLV" "MCMLVI" "MCMLVII" "MCMLVIII" "MCMLIX" "MCMLX" "MCMLXI" "MCMLXII" "MCMLXIII" "MCMLXIV" "MCMLXV" "MCMLXVI" "MCMLXVII" "MCMLXVIII" "MCMLXIX" "MCMLXX" "MCMLXXI" "MCMLXXII" "MCMLXXIII" "MCMLXXIV" "MCMLXXV" "MCMLXXVI" "MCMLXXVII" "MCMLXXVIII" "MCMLXXIX" "MCMLXXX" "MCMLXXXI" "MCMLXXXII" "MCMLXXXIII" "MCMLXXXIV" "MCMLXXXV" "MCMLXXXVI" "MCMLXXXVII" "MCMLXXXVIII" "MCMLXXXIX" "MCMXC" "MCMXCI" "MCMXCII" "MCMXCIII" "MCMXCIV" "MCMXCV" "MCMXCVI" "MCMXCVII" "MCMXCVIII" "MCMXCIX" "MM" "MMI" "MMII" "MMIII" "MMIV" "MMV" "MMVI" "MMVII" "MMVIII" "MMIX" "MMX" "MMXI" "MMXII" "MMXIII" "MMXIV" "MMXV" "MMXVI" "MMXVII" "MMXVIII" "MMXIX" "MMXX" "MMXXI" "MMXXII" "MMXXIII" "MMXXIV" "MMXXV" "MMXXVI" "MMXXVII" "MMXXVIII" "MMXXIX" "MMXXX" "MMXXXI" "MMXXXII" "MMXXXIII" "MMXXXIV" "MMXXXV" "MMXXXVI" "MMXXXVII" "MMXXXVIII" "MMXXXIX" "MMXL" "MMXLI" "MMXLII" "MMXLIII" "MMXLIV" "MMXLV" "MMXLVI" "MMXLVII" "MMXLVIII" "MMXLIX" "MML" "MMLI" "MMLII" "MMLIII" "MMLIV" "MMLV" "MMLVI" "MMLVII" "MMLVIII" "MMLIX" "MMLX" "MMLXI" "MMLXII" "MMLXIII" "MMLXIV" "MMLXV" "MMLXVI" "MMLXVII" "MMLXVIII" "MMLXIX" "MMLXX" "MMLXXI" "MMLXXII" "MMLXXIII" "MMLXXIV" "MMLXXV" "MMLXXVI" "MMLXXVII" "MMLXXVIII" "MMLXXIX" "MMLXXX" "MMLXXXI" "MMLXXXII" "MMLXXXIII" "MMLXXXIV" "MMLXXXV" "MMLXXXVI" "MMLXXXVII" "MMLXXXVIII" "MMLXXXIX" "MMXC" "MMXCI" "MMXCII" "MMXCIII" "MMXCIV" "MMXCV" "MMXCVI" "MMXCVII" "MMXCVIII" "MMXCIX" "MMC" "MMCI" "MMCII" "MMCIII" "MMCIV" "MMCV" "MMCVI" "MMCVII" "MMCVIII" "MMCIX" "MMCX" "MMCXI" "MMCXII" "MMCXIII" "MMCXIV" "MMCXV" "MMCXVI" "MMCXVII" "MMCXVIII" "MMCXIX" "MMCXX" "MMCXXI" "MMCXXII" "MMCXXIII" "MMCXXIV" "MMCXXV" "MMCXXVI" "MMCXXVII" "MMCXXVIII" "MMCXXIX" "MMCXXX" "MMCXXXI" "MMCXXXII" "MMCXXXIII" "MMCXXXIV" "MMCXXXV" "MMCXXXVI" "MMCXXXVII" "MMCXXXVIII" "MMCXXXIX" "MMCXL" "MMCXLI" "MMCXLII" "MMCXLIII" "MMCXLIV" "MMCXLV" "MMCXLVI" "MMCXLVII" "MMCXLVIII" "MMCXLIX" "MMCL" "MMCLI" "MMCLII" "MMCLIII" "MMCLIV" "MMCLV" "MMCLVI" "MMCLVII" "MMCLVIII" "MMCLIX" "MMCLX" "MMCLXI" "MMCLXII" "MMCLXIII" "MMCLXIV" "MMCLXV" "MMCLXVI" "MMCLXVII" "MMCLXVIII" "MMCLXIX" "MMCLXX" "MMCLXXI" "MMCLXXII" "MMCLXXIII" "MMCLXXIV" "MMCLXXV" "MMCLXXVI" "MMCLXXVII" "MMCLXXVIII" "MMCLXXIX" "MMCLXXX" "MMCLXXXI" "MMCLXXXII" "MMCLXXXIII" "MMCLXXXIV" "MMCLXXXV" "MMCLXXXVI" "MMCLXXXVII" "MMCLXXXVIII" "MMCLXXXIX" "MMCXC" "MMCXCI" "MMCXCII" "MMCXCIII" "MMCXCIV" "MMCXCV" "MMCXCVI" "MMCXCVII" "MMCXCVIII" "MMCXCIX" "MMCC" "MMCCI" "MMCCII" "MMCCIII" "MMCCIV" "MMCCV" "MMCCVI" "MMCCVII" "MMCCVIII" "MMCCIX" "MMCCX" "MMCCXI" "MMCCXII" "MMCCXIII" "MMCCXIV" "MMCCXV" "MMCCXVI" "MMCCXVII" "MMCCXVIII" "MMCCXIX" "MMCCXX" "MMCCXXI" "MMCCXXII" "MMCCXXIII" "MMCCXXIV" "MMCCXXV" "MMCCXXVI" "MMCCXXVII" "MMCCXXVIII" "MMCCXXIX" "MMCCXXX" "MMCCXXXI" "MMCCXXXII" "MMCCXXXIII" "MMCCXXXIV" "MMCCXXXV" "MMCCXXXVI" "MMCCXXXVII" "MMCCXXXVIII" "MMCCXXXIX" "MMCCXL" "MMCCXLI" "MMCCXLII" "MMCCXLIII" "MMCCXLIV" "MMCCXLV" "MMCCXLVI" "MMCCXLVII" "MMCCXLVIII" "MMCCXLIX" "MMCCL" "MMCCLI" "MMCCLII" "MMCCLIII" "MMCCLIV" "MMCCLV" "MMCCLVI" "MMCCLVII" "MMCCLVIII" "MMCCLIX" "MMCCLX" "MMCCLXI" "MMCCLXII" "MMCCLXIII" "MMCCLXIV" "MMCCLXV" "MMCCLXVI" "MMCCLXVII" "MMCCLXVIII" "MMCCLXIX" "MMCCLXX" "MMCCLXXI" "MMCCLXXII" "MMCCLXXIII" "MMCCLXXIV" "MMCCLXXV" "MMCCLXXVI" "MMCCLXXVII" "MMCCLXXVIII" "MMCCLXXIX" "MMCCLXXX" "MMCCLXXXI" "MMCCLXXXII" "MMCCLXXXIII" "MMCCLXXXIV" "MMCCLXXXV" "MMCCLXXXVI" "MMCCLXXXVII" "MMCCLXXXVIII" "MMCCLXXXIX" "MMCCXC" "MMCCXCI" "MMCCXCII" "MMCCXCIII" "MMCCXCIV" "MMCCXCV" "MMCCXCVI" "MMCCXCVII" "MMCCXCVIII" "MMCCXCIX" "MMCCC" "MMCCCI" "MMCCCII" "MMCCCIII" "MMCCCIV" "MMCCCV" "MMCCCVI" "MMCCCVII" "MMCCCVIII" "MMCCCIX" "MMCCCX" "MMCCCXI" "MMCCCXII" "MMCCCXIII" "MMCCCXIV" "MMCCCXV" "MMCCCXVI" "MMCCCXVII" "MMCCCXVIII" "MMCCCXIX" "MMCCCXX" "MMCCCXXI" "MMCCCXXII" "MMCCCXXIII" "MMCCCXXIV" "MMCCCXXV" "MMCCCXXVI" "MMCCCXXVII" "MMCCCXXVIII" "MMCCCXXIX" "MMCCCXXX" "MMCCCXXXI" "MMCCCXXXII" "MMCCCXXXIII" "MMCCCXXXIV" "MMCCCXXXV" "MMCCCXXXVI" "MMCCCXXXVII" "MMCCCXXXVIII" "MMCCCXXXIX" "MMCCCXL" "MMCCCXLI" "MMCCCXLII" "MMCCCXLIII" "MMCCCXLIV" "MMCCCXLV" "MMCCCXLVI" "MMCCCXLVII" "MMCCCXLVIII" "MMCCCXLIX" "MMCCCL" "MMCCCLI" "MMCCCLII" "MMCCCLIII" "MMCCCLIV" "MMCCCLV" "MMCCCLVI" "MMCCCLVII" "MMCCCLVIII" "MMCCCLIX" "MMCCCLX" "MMCCCLXI" "MMCCCLXII" "MMCCCLXIII" "MMCCCLXIV" "MMCCCLXV" "MMCCCLXVI" "MMCCCLXVII" "MMCCCLXVIII" "MMCCCLXIX" "MMCCCLXX" "MMCCCLXXI" "MMCCCLXXII" "MMCCCLXXIII" "MMCCCLXXIV" "MMCCCLXXV" "MMCCCLXXVI" "MMCCCLXXVII" "MMCCCLXXVIII" "MMCCCLXXIX" "MMCCCLXXX" "MMCCCLXXXI" "MMCCCLXXXII" "MMCCCLXXXIII" "MMCCCLXXXIV" "MMCCCLXXXV" "MMCCCLXXXVI" "MMCCCLXXXVII" "MMCCCLXXXVIII" "MMCCCLXXXIX" "MMCCCXC" "MMCCCXCI" "MMCCCXCII" "MMCCCXCIII" "MMCCCXCIV" "MMCCCXCV" "MMCCCXCVI" "MMCCCXCVII" "MMCCCXCVIII" "MMCCCXCIX" "MMCD" "MMCDI" "MMCDII" "MMCDIII" "MMCDIV" "MMCDV" "MMCDVI" "MMCDVII" "MMCDVIII" "MMCDIX" "MMCDX" "MMCDXI" "MMCDXII" "MMCDXIII" "MMCDXIV" "MMCDXV" "MMCDXVI" "MMCDXVII" "MMCDXVIII" "MMCDXIX" "MMCDXX" "MMCDXXI" "MMCDXXII" "MMCDXXIII" "MMCDXXIV" "MMCDXXV" "MMCDXXVI" "MMCDXXVII" "MMCDXXVIII" "MMCDXXIX" "MMCDXXX" "MMCDXXXI" "MMCDXXXII" "MMCDXXXIII" "MMCDXXXIV" "MMCDXXXV" "MMCDXXXVI" "MMCDXXXVII" "MMCDXXXVIII" "MMCDXXXIX" "MMCDXL" "MMCDXLI" "MMCDXLII" "MMCDXLIII" "MMCDXLIV" "MMCDXLV" "MMCDXLVI" "MMCDXLVII" "MMCDXLVIII" "MMCDXLIX" "MMCDL" "MMCDLI" "MMCDLII" "MMCDLIII" "MMCDLIV" "MMCDLV" "MMCDLVI" "MMCDLVII" "MMCDLVIII" "MMCDLIX" "MMCDLX" "MMCDLXI" "MMCDLXII" "MMCDLXIII" "MMCDLXIV" "MMCDLXV" "MMCDLXVI" "MMCDLXVII" "MMCDLXVIII" "MMCDLXIX" "MMCDLXX" "MMCDLXXI" "MMCDLXXII" "MMCDLXXIII" "MMCDLXXIV" "MMCDLXXV" "MMCDLXXVI" "MMCDLXXVII" "MMCDLXXVIII" "MMCDLXXIX" "MMCDLXXX" "MMCDLXXXI" "MMCDLXXXII" "MMCDLXXXIII" "MMCDLXXXIV" "MMCDLXXXV" "MMCDLXXXVI" "MMCDLXXXVII" "MMCDLXXXVIII" "MMCDLXXXIX" "MMCDXC" "MMCDXCI" "MMCDXCII" "MMCDXCIII" "MMCDXCIV" "MMCDXCV" "MMCDXCVI" "MMCDXCVII" "MMCDXCVIII" "MMCDXCIX" "MMD" "MMDI" "MMDII" "MMDIII" "MMDIV" "MMDV" "MMDVI" "MMDVII" "MMDVIII" "MMDIX" "MMDX" "MMDXI" "MMDXII" "MMDXIII" "MMDXIV" "MMDXV" "MMDXVI" "MMDXVII" "MMDXVIII" "MMDXIX" "MMDXX" "MMDXXI" "MMDXXII" "MMDXXIII" "MMDXXIV" "MMDXXV" "MMDXXVI" "MMDXXVII" "MMDXXVIII" "MMDXXIX" "MMDXXX" "MMDXXXI" "MMDXXXII" "MMDXXXIII" "MMDXXXIV" "MMDXXXV" "MMDXXXVI" "MMDXXXVII" "MMDXXXVIII" "MMDXXXIX" "MMDXL" "MMDXLI" "MMDXLII" "MMDXLIII" "MMDXLIV" "MMDXLV" "MMDXLVI" "MMDXLVII" "MMDXLVIII" "MMDXLIX" "MMDL" "MMDLI" "MMDLII" "MMDLIII" "MMDLIV" "MMDLV" "MMDLVI" "MMDLVII" "MMDLVIII" "MMDLIX" "MMDLX" "MMDLXI" "MMDLXII" "MMDLXIII" "MMDLXIV" "MMDLXV" "MMDLXVI" "MMDLXVII" "MMDLXVIII" "MMDLXIX" "MMDLXX" "MMDLXXI" "MMDLXXII" "MMDLXXIII" "MMDLXXIV" "MMDLXXV" "MMDLXXVI" "MMDLXXVII" "MMDLXXVIII" "MMDLXXIX" "MMDLXXX" "MMDLXXXI" "MMDLXXXII" "MMDLXXXIII" "MMDLXXXIV" "MMDLXXXV" "MMDLXXXVI" "MMDLXXXVII" "MMDLXXXVIII" "MMDLXXXIX" "MMDXC" "MMDXCI" "MMDXCII" "MMDXCIII" "MMDXCIV" "MMDXCV" "MMDXCVI" "MMDXCVII" "MMDXCVIII" "MMDXCIX" "MMDC" "MMDCI" "MMDCII" "MMDCIII" "MMDCIV" "MMDCV" "MMDCVI" "MMDCVII" "MMDCVIII" "MMDCIX" "MMDCX" "MMDCXI" "MMDCXII" "MMDCXIII" "MMDCXIV" "MMDCXV" "MMDCXVI" "MMDCXVII" "MMDCXVIII" "MMDCXIX" "MMDCXX" "MMDCXXI" "MMDCXXII" "MMDCXXIII" "MMDCXXIV" "MMDCXXV" "MMDCXXVI" "MMDCXXVII" "MMDCXXVIII" "MMDCXXIX" "MMDCXXX" "MMDCXXXI" "MMDCXXXII" "MMDCXXXIII" "MMDCXXXIV" "MMDCXXXV" "MMDCXXXVI" "MMDCXXXVII" "MMDCXXXVIII" "MMDCXXXIX" "MMDCXL" "MMDCXLI" "MMDCXLII" "MMDCXLIII" "MMDCXLIV" "MMDCXLV" "MMDCXLVI" "MMDCXLVII" "MMDCXLVIII" "MMDCXLIX" "MMDCL" "MMDCLI" "MMDCLII" "MMDCLIII" "MMDCLIV" "MMDCLV" "MMDCLVI" "MMDCLVII" "MMDCLVIII" "MMDCLIX" "MMDCLX" "MMDCLXI" "MMDCLXII" "MMDCLXIII" "MMDCLXIV" "MMDCLXV" "MMDCLXVI" "MMDCLXVII" "MMDCLXVIII" "MMDCLXIX" "MMDCLXX" "MMDCLXXI" "MMDCLXXII" "MMDCLXXIII" "MMDCLXXIV" "MMDCLXXV" "MMDCLXXVI" "MMDCLXXVII" "MMDCLXXVIII" "MMDCLXXIX" "MMDCLXXX" "MMDCLXXXI" "MMDCLXXXII" "MMDCLXXXIII" "MMDCLXXXIV" "MMDCLXXXV" "MMDCLXXXVI" "MMDCLXXXVII" "MMDCLXXXVIII" "MMDCLXXXIX" "MMDCXC" "MMDCXCI" "MMDCXCII" "MMDCXCIII" "MMDCXCIV" "MMDCXCV" "MMDCXCVI" "MMDCXCVII" "MMDCXCVIII" "MMDCXCIX" "MMDCC" "MMDCCI" "MMDCCII" "MMDCCIII" "MMDCCIV" "MMDCCV" "MMDCCVI" "MMDCCVII" "MMDCCVIII" "MMDCCIX" "MMDCCX" "MMDCCXI" "MMDCCXII" "MMDCCXIII" "MMDCCXIV" "MMDCCXV" "MMDCCXVI" "MMDCCXVII" "MMDCCXVIII" "MMDCCXIX" "MMDCCXX" "MMDCCXXI" "MMDCCXXII" "MMDCCXXIII" "MMDCCXXIV" "MMDCCXXV" "MMDCCXXVI" "MMDCCXXVII" "MMDCCXXVIII" "MMDCCXXIX" "MMDCCXXX" "MMDCCXXXI" "MMDCCXXXII" "MMDCCXXXIII" "MMDCCXXXIV" "MMDCCXXXV" "MMDCCXXXVI" "MMDCCXXXVII" "MMDCCXXXVIII" "MMDCCXXXIX" "MMDCCXL" "MMDCCXLI" "MMDCCXLII" "MMDCCXLIII" "MMDCCXLIV" "MMDCCXLV" "MMDCCXLVI" "MMDCCXLVII" "MMDCCXLVIII" "MMDCCXLIX" "MMDCCL" "MMDCCLI" "MMDCCLII" "MMDCCLIII" "MMDCCLIV" "MMDCCLV" "MMDCCLVI" "MMDCCLVII" "MMDCCLVIII" "MMDCCLIX" "MMDCCLX" "MMDCCLXI" "MMDCCLXII" "MMDCCLXIII" "MMDCCLXIV" "MMDCCLXV" "MMDCCLXVI" "MMDCCLXVII" "MMDCCLXVIII" "MMDCCLXIX" "MMDCCLXX" "MMDCCLXXI" "MMDCCLXXII" "MMDCCLXXIII" "MMDCCLXXIV" "MMDCCLXXV" "MMDCCLXXVI" "MMDCCLXXVII" "MMDCCLXXVIII" "MMDCCLXXIX" "MMDCCLXXX" "MMDCCLXXXI" "MMDCCLXXXII" "MMDCCLXXXIII" "MMDCCLXXXIV" "MMDCCLXXXV" "MMDCCLXXXVI" "MMDCCLXXXVII" "MMDCCLXXXVIII" "MMDCCLXXXIX" "MMDCCXC" "MMDCCXCI" "MMDCCXCII" "MMDCCXCIII" "MMDCCXCIV" "MMDCCXCV" "MMDCCXCVI" "MMDCCXCVII" "MMDCCXCVIII" "MMDCCXCIX" "MMDCCC" "MMDCCCI" "MMDCCCII" "MMDCCCIII" "MMDCCCIV" "MMDCCCV" "MMDCCCVI" "MMDCCCVII" "MMDCCCVIII" "MMDCCCIX" "MMDCCCX" "MMDCCCXI" "MMDCCCXII" "MMDCCCXIII" "MMDCCCXIV" "MMDCCCXV" "MMDCCCXVI" "MMDCCCXVII" "MMDCCCXVIII" "MMDCCCXIX" "MMDCCCXX" "MMDCCCXXI" "MMDCCCXXII" "MMDCCCXXIII" "MMDCCCXXIV" "MMDCCCXXV" "MMDCCCXXVI" "MMDCCCXXVII" "MMDCCCXXVIII" "MMDCCCXXIX" "MMDCCCXXX" "MMDCCCXXXI" "MMDCCCXXXII" "MMDCCCXXXIII" "MMDCCCXXXIV" "MMDCCCXXXV" "MMDCCCXXXVI" "MMDCCCXXXVII" "MMDCCCXXXVIII" "MMDCCCXXXIX" "MMDCCCXL" "MMDCCCXLI" "MMDCCCXLII" "MMDCCCXLIII" "MMDCCCXLIV" "MMDCCCXLV" "MMDCCCXLVI" "MMDCCCXLVII" "MMDCCCXLVIII" "MMDCCCXLIX" "MMDCCCL" "MMDCCCLI" "MMDCCCLII" "MMDCCCLIII" "MMDCCCLIV" "MMDCCCLV" "MMDCCCLVI" "MMDCCCLVII" "MMDCCCLVIII" "MMDCCCLIX" "MMDCCCLX" "MMDCCCLXI" "MMDCCCLXII" "MMDCCCLXIII" "MMDCCCLXIV" "MMDCCCLXV" "MMDCCCLXVI" "MMDCCCLXVII" "MMDCCCLXVIII" "MMDCCCLXIX" "MMDCCCLXX" "MMDCCCLXXI" "MMDCCCLXXII" "MMDCCCLXXIII" "MMDCCCLXXIV" "MMDCCCLXXV" "MMDCCCLXXVI" "MMDCCCLXXVII" "MMDCCCLXXVIII" "MMDCCCLXXIX" "MMDCCCLXXX" "MMDCCCLXXXI" "MMDCCCLXXXII" "MMDCCCLXXXIII" "MMDCCCLXXXIV" "MMDCCCLXXXV" "MMDCCCLXXXVI" "MMDCCCLXXXVII" "MMDCCCLXXXVIII" "MMDCCCLXXXIX" "MMDCCCXC" "MMDCCCXCI" "MMDCCCXCII" "MMDCCCXCIII" "MMDCCCXCIV" "MMDCCCXCV" "MMDCCCXCVI" "MMDCCCXCVII" "MMDCCCXCVIII" "MMDCCCXCIX" "MMCM" "MMCMI" "MMCMII" "MMCMIII" "MMCMIV" "MMCMV" "MMCMVI" "MMCMVII" "MMCMVIII" "MMCMIX" "MMCMX" "MMCMXI" "MMCMXII" "MMCMXIII" "MMCMXIV" "MMCMXV" "MMCMXVI" "MMCMXVII" "MMCMXVIII" "MMCMXIX" "MMCMXX" "MMCMXXI" "MMCMXXII" "MMCMXXIII" "MMCMXXIV" "MMCMXXV" "MMCMXXVI" "MMCMXXVII" "MMCMXXVIII" "MMCMXXIX" "MMCMXXX" "MMCMXXXI" "MMCMXXXII" "MMCMXXXIII" "MMCMXXXIV" "MMCMXXXV" "MMCMXXXVI" "MMCMXXXVII" "MMCMXXXVIII" "MMCMXXXIX" "MMCMXL" "MMCMXLI" "MMCMXLII" "MMCMXLIII" "MMCMXLIV" "MMCMXLV" "MMCMXLVI" "MMCMXLVII" "MMCMXLVIII" "MMCMXLIX" "MMCML" "MMCMLI" "MMCMLII" "MMCMLIII" "MMCMLIV" "MMCMLV" "MMCMLVI" "MMCMLVII" "MMCMLVIII" "MMCMLIX" "MMCMLX" "MMCMLXI" "MMCMLXII" "MMCMLXIII" "MMCMLXIV" "MMCMLXV" "MMCMLXVI" "MMCMLXVII" "MMCMLXVIII" "MMCMLXIX" "MMCMLXX" "MMCMLXXI" "MMCMLXXII" "MMCMLXXIII" "MMCMLXXIV" "MMCMLXXV" "MMCMLXXVI" "MMCMLXXVII" "MMCMLXXVIII" "MMCMLXXIX" "MMCMLXXX" "MMCMLXXXI" "MMCMLXXXII" "MMCMLXXXIII" "MMCMLXXXIV" "MMCMLXXXV" "MMCMLXXXVI" "MMCMLXXXVII" "MMCMLXXXVIII" "MMCMLXXXIX" "MMCMXC" "MMCMXCI" "MMCMXCII" "MMCMXCIII" "MMCMXCIV" "MMCMXCV" "MMCMXCVI" "MMCMXCVII" "MMCMXCVIII" "MMCMXCIX" "MMM" "MMMI" "MMMII" "MMMIII" "MMMIV" "MMMV" "MMMVI" "MMMVII" "MMMVIII" "MMMIX" "MMMX" "MMMXI" "MMMXII" "MMMXIII" "MMMXIV" "MMMXV" "MMMXVI" "MMMXVII" "MMMXVIII" "MMMXIX" "MMMXX" "MMMXXI" "MMMXXII" "MMMXXIII" "MMMXXIV" "MMMXXV" "MMMXXVI" "MMMXXVII" "MMMXXVIII" "MMMXXIX" "MMMXXX" "MMMXXXI" "MMMXXXII" "MMMXXXIII" "MMMXXXIV" "MMMXXXV" "MMMXXXVI" "MMMXXXVII" "MMMXXXVIII" "MMMXXXIX" "MMMXL" "MMMXLI" "MMMXLII" "MMMXLIII" "MMMXLIV" "MMMXLV" "MMMXLVI" "MMMXLVII" "MMMXLVIII" "MMMXLIX" "MMML" "MMMLI" "MMMLII" "MMMLIII" "MMMLIV" "MMMLV" "MMMLVI" "MMMLVII" "MMMLVIII" "MMMLIX" "MMMLX" "MMMLXI" "MMMLXII" "MMMLXIII" "MMMLXIV" "MMMLXV" "MMMLXVI" "MMMLXVII" "MMMLXVIII" "MMMLXIX" "MMMLXX" "MMMLXXI" "MMMLXXII" "MMMLXXIII" "MMMLXXIV" "MMMLXXV" "MMMLXXVI" "MMMLXXVII" "MMMLXXVIII" "MMMLXXIX" "MMMLXXX" "MMMLXXXI" "MMMLXXXII" "MMMLXXXIII" "MMMLXXXIV" "MMMLXXXV" "MMMLXXXVI" "MMMLXXXVII" "MMMLXXXVIII" "MMMLXXXIX" "MMMXC" "MMMXCI" "MMMXCII" "MMMXCIII" "MMMXCIV" "MMMXCV" "MMMXCVI" "MMMXCVII" "MMMXCVIII" "MMMXCIX" "MMMC" "MMMCI" "MMMCII" "MMMCIII" "MMMCIV" "MMMCV" "MMMCVI" "MMMCVII" "MMMCVIII" "MMMCIX" "MMMCX" "MMMCXI" "MMMCXII" "MMMCXIII" "MMMCXIV" "MMMCXV" "MMMCXVI" "MMMCXVII" "MMMCXVIII" "MMMCXIX" "MMMCXX" "MMMCXXI" "MMMCXXII" "MMMCXXIII" "MMMCXXIV" "MMMCXXV" "MMMCXXVI" "MMMCXXVII" "MMMCXXVIII" "MMMCXXIX" "MMMCXXX" "MMMCXXXI" "MMMCXXXII" "MMMCXXXIII" "MMMCXXXIV" "MMMCXXXV" "MMMCXXXVI" "MMMCXXXVII" "MMMCXXXVIII" "MMMCXXXIX" "MMMCXL" "MMMCXLI" "MMMCXLII" "MMMCXLIII" "MMMCXLIV" "MMMCXLV" "MMMCXLVI" "MMMCXLVII" "MMMCXLVIII" "MMMCXLIX" "MMMCL" "MMMCLI" "MMMCLII" "MMMCLIII" "MMMCLIV" "MMMCLV" "MMMCLVI" "MMMCLVII" "MMMCLVIII" "MMMCLIX" "MMMCLX" "MMMCLXI" "MMMCLXII" "MMMCLXIII" "MMMCLXIV" "MMMCLXV" "MMMCLXVI" "MMMCLXVII" "MMMCLXVIII" "MMMCLXIX" "MMMCLXX" "MMMCLXXI" "MMMCLXXII" "MMMCLXXIII" "MMMCLXXIV" "MMMCLXXV" "MMMCLXXVI" "MMMCLXXVII" "MMMCLXXVIII" "MMMCLXXIX" "MMMCLXXX" "MMMCLXXXI" "MMMCLXXXII" "MMMCLXXXIII" "MMMCLXXXIV" "MMMCLXXXV" "MMMCLXXXVI" "MMMCLXXXVII" "MMMCLXXXVIII" "MMMCLXXXIX" "MMMCXC" "MMMCXCI" "MMMCXCII" "MMMCXCIII" "MMMCXCIV" "MMMCXCV" "MMMCXCVI" "MMMCXCVII" "MMMCXCVIII" "MMMCXCIX" "MMMCC" "MMMCCI" "MMMCCII" "MMMCCIII" "MMMCCIV" "MMMCCV" "MMMCCVI" "MMMCCVII" "MMMCCVIII" "MMMCCIX" "MMMCCX" "MMMCCXI" "MMMCCXII" "MMMCCXIII" "MMMCCXIV" "MMMCCXV" "MMMCCXVI" "MMMCCXVII" "MMMCCXVIII" "MMMCCXIX" "MMMCCXX" "MMMCCXXI" "MMMCCXXII" "MMMCCXXIII" "MMMCCXXIV" "MMMCCXXV" "MMMCCXXVI" "MMMCCXXVII" "MMMCCXXVIII" "MMMCCXXIX" "MMMCCXXX" "MMMCCXXXI" "MMMCCXXXII" "MMMCCXXXIII" "MMMCCXXXIV" "MMMCCXXXV" "MMMCCXXXVI" "MMMCCXXXVII" "MMMCCXXXVIII" "MMMCCXXXIX" "MMMCCXL" "MMMCCXLI" "MMMCCXLII" "MMMCCXLIII" "MMMCCXLIV" "MMMCCXLV" "MMMCCXLVI" "MMMCCXLVII" "MMMCCXLVIII" "MMMCCXLIX" "MMMCCL" "MMMCCLI" "MMMCCLII" "MMMCCLIII" "MMMCCLIV" "MMMCCLV" "MMMCCLVI" "MMMCCLVII" "MMMCCLVIII" "MMMCCLIX" "MMMCCLX" "MMMCCLXI" "MMMCCLXII" "MMMCCLXIII" "MMMCCLXIV" "MMMCCLXV" "MMMCCLXVI" "MMMCCLXVII" "MMMCCLXVIII" "MMMCCLXIX" "MMMCCLXX" "MMMCCLXXI" "MMMCCLXXII" "MMMCCLXXIII" "MMMCCLXXIV" "MMMCCLXXV" "MMMCCLXXVI" "MMMCCLXXVII" "MMMCCLXXVIII" "MMMCCLXXIX" "MMMCCLXXX" "MMMCCLXXXI" "MMMCCLXXXII" "MMMCCLXXXIII" "MMMCCLXXXIV" "MMMCCLXXXV" "MMMCCLXXXVI" "MMMCCLXXXVII" "MMMCCLXXXVIII" "MMMCCLXXXIX" "MMMCCXC" "MMMCCXCI" "MMMCCXCII" "MMMCCXCIII" "MMMCCXCIV" "MMMCCXCV" "MMMCCXCVI" "MMMCCXCVII" "MMMCCXCVIII" "MMMCCXCIX" "MMMCCC" "MMMCCCI" "MMMCCCII" "MMMCCCIII" "MMMCCCIV" "MMMCCCV" "MMMCCCVI" "MMMCCCVII" "MMMCCCVIII" "MMMCCCIX" "MMMCCCX" "MMMCCCXI" "MMMCCCXII" "MMMCCCXIII" "MMMCCCXIV" "MMMCCCXV" "MMMCCCXVI" "MMMCCCXVII" "MMMCCCXVIII" "MMMCCCXIX" "MMMCCCXX" "MMMCCCXXI" "MMMCCCXXII" "MMMCCCXXIII" "MMMCCCXXIV" "MMMCCCXXV" "MMMCCCXXVI" "MMMCCCXXVII" "MMMCCCXXVIII" "MMMCCCXXIX" "MMMCCCXXX" "MMMCCCXXXI" "MMMCCCXXXII" "MMMCCCXXXIII" "MMMCCCXXXIV" "MMMCCCXXXV" "MMMCCCXXXVI" "MMMCCCXXXVII" "MMMCCCXXXVIII" "MMMCCCXXXIX" "MMMCCCXL" "MMMCCCXLI" "MMMCCCXLII" "MMMCCCXLIII" "MMMCCCXLIV" "MMMCCCXLV" "MMMCCCXLVI" "MMMCCCXLVII" "MMMCCCXLVIII" "MMMCCCXLIX" "MMMCCCL" "MMMCCCLI" "MMMCCCLII" "MMMCCCLIII" "MMMCCCLIV" "MMMCCCLV" "MMMCCCLVI" "MMMCCCLVII" "MMMCCCLVIII" "MMMCCCLIX" "MMMCCCLX" "MMMCCCLXI" "MMMCCCLXII" "MMMCCCLXIII" "MMMCCCLXIV" "MMMCCCLXV" "MMMCCCLXVI" "MMMCCCLXVII" "MMMCCCLXVIII" "MMMCCCLXIX" "MMMCCCLXX" "MMMCCCLXXI" "MMMCCCLXXII" "MMMCCCLXXIII" "MMMCCCLXXIV" "MMMCCCLXXV" "MMMCCCLXXVI" "MMMCCCLXXVII" "MMMCCCLXXVIII" "MMMCCCLXXIX" "MMMCCCLXXX" "MMMCCCLXXXI" "MMMCCCLXXXII" "MMMCCCLXXXIII" "MMMCCCLXXXIV" "MMMCCCLXXXV" "MMMCCCLXXXVI" "MMMCCCLXXXVII" "MMMCCCLXXXVIII" "MMMCCCLXXXIX" "MMMCCCXC" "MMMCCCXCI" "MMMCCCXCII" "MMMCCCXCIII" "MMMCCCXCIV" "MMMCCCXCV" "MMMCCCXCVI" "MMMCCCXCVII" "MMMCCCXCVIII" "MMMCCCXCIX" "MMMCD" "MMMCDI" "MMMCDII" "MMMCDIII" "MMMCDIV" "MMMCDV" "MMMCDVI" "MMMCDVII" "MMMCDVIII" "MMMCDIX" "MMMCDX" "MMMCDXI" "MMMCDXII" "MMMCDXIII" "MMMCDXIV" "MMMCDXV" "MMMCDXVI" "MMMCDXVII" "MMMCDXVIII" "MMMCDXIX" "MMMCDXX" "MMMCDXXI" "MMMCDXXII" "MMMCDXXIII" "MMMCDXXIV" "MMMCDXXV" "MMMCDXXVI" "MMMCDXXVII" "MMMCDXXVIII" "MMMCDXXIX" "MMMCDXXX" "MMMCDXXXI" "MMMCDXXXII" "MMMCDXXXIII" "MMMCDXXXIV" "MMMCDXXXV" "MMMCDXXXVI" "MMMCDXXXVII" "MMMCDXXXVIII" "MMMCDXXXIX" "MMMCDXL" "MMMCDXLI" "MMMCDXLII" "MMMCDXLIII" "MMMCDXLIV" "MMMCDXLV" "MMMCDXLVI" "MMMCDXLVII" "MMMCDXLVIII" "MMMCDXLIX" "MMMCDL" "MMMCDLI" "MMMCDLII" "MMMCDLIII" "MMMCDLIV" "MMMCDLV" "MMMCDLVI" "MMMCDLVII" "MMMCDLVIII" "MMMCDLIX" "MMMCDLX" "MMMCDLXI" "MMMCDLXII" "MMMCDLXIII" "MMMCDLXIV" "MMMCDLXV" "MMMCDLXVI" "MMMCDLXVII" "MMMCDLXVIII" "MMMCDLXIX" "MMMCDLXX" "MMMCDLXXI" "MMMCDLXXII" "MMMCDLXXIII" "MMMCDLXXIV" "MMMCDLXXV" "MMMCDLXXVI" "MMMCDLXXVII" "MMMCDLXXVIII" "MMMCDLXXIX" "MMMCDLXXX" "MMMCDLXXXI" "MMMCDLXXXII" "MMMCDLXXXIII" "MMMCDLXXXIV" "MMMCDLXXXV" "MMMCDLXXXVI" "MMMCDLXXXVII" "MMMCDLXXXVIII" "MMMCDLXXXIX" "MMMCDXC" "MMMCDXCI" "MMMCDXCII" "MMMCDXCIII" "MMMCDXCIV" "MMMCDXCV" "MMMCDXCVI" "MMMCDXCVII" "MMMCDXCVIII" "MMMCDXCIX" "MMMD" "MMMDI" "MMMDII" "MMMDIII" "MMMDIV" "MMMDV" "MMMDVI" "MMMDVII" "MMMDVIII" "MMMDIX" "MMMDX" "MMMDXI" "MMMDXII" "MMMDXIII" "MMMDXIV" "MMMDXV" "MMMDXVI" "MMMDXVII" "MMMDXVIII" "MMMDXIX" "MMMDXX" "MMMDXXI" "MMMDXXII" "MMMDXXIII" "MMMDXXIV" "MMMDXXV" "MMMDXXVI" "MMMDXXVII" "MMMDXXVIII" "MMMDXXIX" "MMMDXXX" "MMMDXXXI" "MMMDXXXII" "MMMDXXXIII" "MMMDXXXIV" "MMMDXXXV" "MMMDXXXVI" "MMMDXXXVII" "MMMDXXXVIII" "MMMDXXXIX" "MMMDXL" "MMMDXLI" "MMMDXLII" "MMMDXLIII" "MMMDXLIV" "MMMDXLV" "MMMDXLVI" "MMMDXLVII" "MMMDXLVIII" "MMMDXLIX" "MMMDL" "MMMDLI" "MMMDLII" "MMMDLIII" "MMMDLIV" "MMMDLV" "MMMDLVI" "MMMDLVII" "MMMDLVIII" "MMMDLIX" "MMMDLX" "MMMDLXI" "MMMDLXII" "MMMDLXIII" "MMMDLXIV" "MMMDLXV" "MMMDLXVI" "MMMDLXVII" "MMMDLXVIII" "MMMDLXIX" "MMMDLXX" "MMMDLXXI" "MMMDLXXII" "MMMDLXXIII" "MMMDLXXIV" "MMMDLXXV" "MMMDLXXVI" "MMMDLXXVII" "MMMDLXXVIII" "MMMDLXXIX" "MMMDLXXX" "MMMDLXXXI" "MMMDLXXXII" "MMMDLXXXIII" "MMMDLXXXIV" "MMMDLXXXV" "MMMDLXXXVI" "MMMDLXXXVII" "MMMDLXXXVIII" "MMMDLXXXIX" "MMMDXC" "MMMDXCI" "MMMDXCII" "MMMDXCIII" "MMMDXCIV" "MMMDXCV" "MMMDXCVI" "MMMDXCVII" "MMMDXCVIII" "MMMDXCIX" "MMMDC" "MMMDCI" "MMMDCII" "MMMDCIII" "MMMDCIV" "MMMDCV" "MMMDCVI" "MMMDCVII" "MMMDCVIII" "MMMDCIX" "MMMDCX" "MMMDCXI" "MMMDCXII" "MMMDCXIII" "MMMDCXIV" "MMMDCXV" "MMMDCXVI" "MMMDCXVII" "MMMDCXVIII" "MMMDCXIX" "MMMDCXX" "MMMDCXXI" "MMMDCXXII" "MMMDCXXIII" "MMMDCXXIV" "MMMDCXXV" "MMMDCXXVI" "MMMDCXXVII" "MMMDCXXVIII" "MMMDCXXIX" "MMMDCXXX" "MMMDCXXXI" "MMMDCXXXII" "MMMDCXXXIII" "MMMDCXXXIV" "MMMDCXXXV" "MMMDCXXXVI" "MMMDCXXXVII" "MMMDCXXXVIII" "MMMDCXXXIX" "MMMDCXL" "MMMDCXLI" "MMMDCXLII" "MMMDCXLIII" "MMMDCXLIV" "MMMDCXLV" "MMMDCXLVI" "MMMDCXLVII" "MMMDCXLVIII" "MMMDCXLIX" "MMMDCL" "MMMDCLI" "MMMDCLII" "MMMDCLIII" "MMMDCLIV" "MMMDCLV" "MMMDCLVI" "MMMDCLVII" "MMMDCLVIII" "MMMDCLIX" "MMMDCLX" "MMMDCLXI" "MMMDCLXII" "MMMDCLXIII" "MMMDCLXIV" "MMMDCLXV" "MMMDCLXVI" "MMMDCLXVII" "MMMDCLXVIII" "MMMDCLXIX" "MMMDCLXX" "MMMDCLXXI" "MMMDCLXXII" "MMMDCLXXIII" "MMMDCLXXIV" "MMMDCLXXV" "MMMDCLXXVI" "MMMDCLXXVII" "MMMDCLXXVIII" "MMMDCLXXIX" "MMMDCLXXX" "MMMDCLXXXI" "MMMDCLXXXII" "MMMDCLXXXIII" "MMMDCLXXXIV" "MMMDCLXXXV" "MMMDCLXXXVI" "MMMDCLXXXVII" "MMMDCLXXXVIII" "MMMDCLXXXIX" "MMMDCXC" "MMMDCXCI" "MMMDCXCII" "MMMDCXCIII" "MMMDCXCIV" "MMMDCXCV" "MMMDCXCVI" "MMMDCXCVII" "MMMDCXCVIII" "MMMDCXCIX" "MMMDCC" "MMMDCCI" "MMMDCCII" "MMMDCCIII" "MMMDCCIV" "MMMDCCV" "MMMDCCVI" "MMMDCCVII" "MMMDCCVIII" "MMMDCCIX" "MMMDCCX" "MMMDCCXI" "MMMDCCXII" "MMMDCCXIII" "MMMDCCXIV" "MMMDCCXV" "MMMDCCXVI" "MMMDCCXVII" "MMMDCCXVIII" "MMMDCCXIX" "MMMDCCXX" "MMMDCCXXI" "MMMDCCXXII" "MMMDCCXXIII" "MMMDCCXXIV" "MMMDCCXXV" "MMMDCCXXVI" "MMMDCCXXVII" "MMMDCCXXVIII" "MMMDCCXXIX" "MMMDCCXXX" "MMMDCCXXXI" "MMMDCCXXXII" "MMMDCCXXXIII" "MMMDCCXXXIV" "MMMDCCXXXV" "MMMDCCXXXVI" "MMMDCCXXXVII" "MMMDCCXXXVIII" "MMMDCCXXXIX" "MMMDCCXL" "MMMDCCXLI" "MMMDCCXLII" "MMMDCCXLIII" "MMMDCCXLIV" "MMMDCCXLV" "MMMDCCXLVI" "MMMDCCXLVII" "MMMDCCXLVIII" "MMMDCCXLIX" "MMMDCCL" "MMMDCCLI" "MMMDCCLII" "MMMDCCLIII" "MMMDCCLIV" "MMMDCCLV" "MMMDCCLVI" "MMMDCCLVII" "MMMDCCLVIII" "MMMDCCLIX" "MMMDCCLX" "MMMDCCLXI" "MMMDCCLXII" "MMMDCCLXIII" "MMMDCCLXIV" "MMMDCCLXV" "MMMDCCLXVI" "MMMDCCLXVII" "MMMDCCLXVIII" "MMMDCCLXIX" "MMMDCCLXX" "MMMDCCLXXI" "MMMDCCLXXII" "MMMDCCLXXIII" "MMMDCCLXXIV" "MMMDCCLXXV" "MMMDCCLXXVI" "MMMDCCLXXVII" "MMMDCCLXXVIII" "MMMDCCLXXIX" "MMMDCCLXXX" "MMMDCCLXXXI" "MMMDCCLXXXII" "MMMDCCLXXXIII" "MMMDCCLXXXIV" "MMMDCCLXXXV" "MMMDCCLXXXVI" "MMMDCCLXXXVII" "MMMDCCLXXXVIII" "MMMDCCLXXXIX" "MMMDCCXC" "MMMDCCXCI" "MMMDCCXCII" "MMMDCCXCIII" "MMMDCCXCIV" "MMMDCCXCV" "MMMDCCXCVI" "MMMDCCXCVII" "MMMDCCXCVIII" "MMMDCCXCIX" "MMMDCCC" "MMMDCCCI" "MMMDCCCII" "MMMDCCCIII" "MMMDCCCIV" "MMMDCCCV" "MMMDCCCVI" "MMMDCCCVII" "MMMDCCCVIII" "MMMDCCCIX" "MMMDCCCX" "MMMDCCCXI" "MMMDCCCXII" "MMMDCCCXIII" "MMMDCCCXIV" "MMMDCCCXV" "MMMDCCCXVI" "MMMDCCCXVII" "MMMDCCCXVIII" "MMMDCCCXIX" "MMMDCCCXX" "MMMDCCCXXI" "MMMDCCCXXII" "MMMDCCCXXIII" "MMMDCCCXXIV" "MMMDCCCXXV" "MMMDCCCXXVI" "MMMDCCCXXVII" "MMMDCCCXXVIII" "MMMDCCCXXIX" "MMMDCCCXXX" "MMMDCCCXXXI" "MMMDCCCXXXII" "MMMDCCCXXXIII" "MMMDCCCXXXIV" "MMMDCCCXXXV" "MMMDCCCXXXVI" "MMMDCCCXXXVII" "MMMDCCCXXXVIII" "MMMDCCCXXXIX" "MMMDCCCXL" "MMMDCCCXLI" "MMMDCCCXLII" "MMMDCCCXLIII" "MMMDCCCXLIV" "MMMDCCCXLV" "MMMDCCCXLVI" "MMMDCCCXLVII" "MMMDCCCXLVIII" "MMMDCCCXLIX" "MMMDCCCL" "MMMDCCCLI" "MMMDCCCLII" "MMMDCCCLIII" "MMMDCCCLIV" "MMMDCCCLV" "MMMDCCCLVI" "MMMDCCCLVII" "MMMDCCCLVIII" "MMMDCCCLIX" "MMMDCCCLX" "MMMDCCCLXI" "MMMDCCCLXII" "MMMDCCCLXIII" "MMMDCCCLXIV" "MMMDCCCLXV" "MMMDCCCLXVI" "MMMDCCCLXVII" "MMMDCCCLXVIII" "MMMDCCCLXIX" "MMMDCCCLXX" "MMMDCCCLXXI" "MMMDCCCLXXII" "MMMDCCCLXXIII" "MMMDCCCLXXIV" "MMMDCCCLXXV" "MMMDCCCLXXVI" "MMMDCCCLXXVII" "MMMDCCCLXXVIII" "MMMDCCCLXXIX" "MMMDCCCLXXX" "MMMDCCCLXXXI" "MMMDCCCLXXXII" "MMMDCCCLXXXIII" "MMMDCCCLXXXIV" "MMMDCCCLXXXV" "MMMDCCCLXXXVI" "MMMDCCCLXXXVII" "MMMDCCCLXXXVIII" "MMMDCCCLXXXIX" "MMMDCCCXC" "MMMDCCCXCI" "MMMDCCCXCII" "MMMDCCCXCIII" "MMMDCCCXCIV" "MMMDCCCXCV" "MMMDCCCXCVI" "MMMDCCCXCVII" "MMMDCCCXCVIII" "MMMDCCCXCIX" "MMMCM" "MMMCMI" "MMMCMII" "MMMCMIII" "MMMCMIV" "MMMCMV" "MMMCMVI" "MMMCMVII" "MMMCMVIII" "MMMCMIX" "MMMCMX" "MMMCMXI" "MMMCMXII" "MMMCMXIII" "MMMCMXIV" "MMMCMXV" "MMMCMXVI" "MMMCMXVII" "MMMCMXVIII" "MMMCMXIX" "MMMCMXX" "MMMCMXXI" "MMMCMXXII" "MMMCMXXIII" "MMMCMXXIV" "MMMCMXXV" "MMMCMXXVI" "MMMCMXXVII" "MMMCMXXVIII" "MMMCMXXIX" "MMMCMXXX" "MMMCMXXXI" "MMMCMXXXII" "MMMCMXXXIII" "MMMCMXXXIV" "MMMCMXXXV" "MMMCMXXXVI" "MMMCMXXXVII" "MMMCMXXXVIII" "MMMCMXXXIX" "MMMCMXL" "MMMCMXLI" "MMMCMXLII" "MMMCMXLIII" "MMMCMXLIV" "MMMCMXLV" "MMMCMXLVI" "MMMCMXLVII" "MMMCMXLVIII" "MMMCMXLIX" "MMMCML" "MMMCMLI" "MMMCMLII" "MMMCMLIII" "MMMCMLIV" "MMMCMLV" "MMMCMLVI" "MMMCMLVII" "MMMCMLVIII" "MMMCMLIX" "MMMCMLX" "MMMCMLXI" "MMMCMLXII" "MMMCMLXIII" "MMMCMLXIV" "MMMCMLXV" "MMMCMLXVI" "MMMCMLXVII" "MMMCMLXVIII" "MMMCMLXIX" "MMMCMLXX" "MMMCMLXXI" "MMMCMLXXII" "MMMCMLXXIII" "MMMCMLXXIV" "MMMCMLXXV" "MMMCMLXXVI" "MMMCMLXXVII" "MMMCMLXXVIII" "MMMCMLXXIX" "MMMCMLXXX" "MMMCMLXXXI" "MMMCMLXXXII" "MMMCMLXXXIII" "MMMCMLXXXIV" "MMMCMLXXXV" "MMMCMLXXXVI" "MMMCMLXXXVII" "MMMCMLXXXVIII" "MMMCMLXXXIX" "MMMCMXC" "MMMCMXCI" "MMMCMXCII" "MMMCMXCIII" "MMMCMXCIV" "MMMCMXCV" "MMMCMXCVI" "MMMCMXCVII" "MMMCMXCVIII" "MMMCMXCIX")) gcl27-2.7.0/ansi-tests/room.lsp000066400000000000000000000014531454061450500162330ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Dec 12 09:20:47 2004 ;;;; Contains: Tests of ROOM (in-package :cl-test) (deftest room.1 (let ((s (with-output-to-string (*standard-output*) (room)))) (not (zerop (length s)))) t) (deftest room.2 (let ((s (with-output-to-string (*standard-output*) (room nil)))) (not (zerop (length s)))) t) (deftest room.3 (let ((s (with-output-to-string (*standard-output*) (room :default)))) (not (zerop (length s)))) t) (deftest room.4 (let ((s (with-output-to-string (*standard-output*) (room t)))) (not (zerop (length s)))) t) ;;; Error tests (deftest room.errpr.1 (signals-error (with-output-to-string (*standard-output*) (room nil nil)) program-error) t) gcl27-2.7.0/ansi-tests/rotatef.lsp000066400000000000000000000171521454061450500167260ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 15:44:38 2003 ;;;; Contains: Tests for ROTATEF (in-package :cl-test) (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 rotatef.1 (let ((x (vector 0 1 2))) (values (rotatef (aref x (aref x 0)) (aref x (aref x 1)) (aref x (aref x 2))) x)) nil #(1 2 0)) (deftest rotatef.2 (let ((x (vector 0 1 2 3 4 5 6 7 8 9))) (values (rotatef (aref x (aref x 0)) (aref x (aref x 1)) (aref x (aref x 2)) (aref x (aref x 3)) (aref x (aref x 4)) (aref x (aref x 5)) (aref x (aref x 6)) (aref x (aref x 7)) (aref x (aref x 8)) (aref x (aref x 9))) x)) nil #(1 2 3 4 5 6 7 8 9 0)) (deftest rotatef.3 (rotatef) nil) (deftest rotatef.4 (let ((x 10)) (values x (rotatef x) x)) 10 nil 10) (deftest rotatef.5 (let ((x 'a) (y 'b)) (values x y (rotatef x y) x y)) a b nil b a) ;;; ROTATEF is a good testbed for finding conflicts in setf expansions ;;; These tests apply rotatef to various accessors (deftest rotatef.6 (let* ((x (list 'a 'b)) (y (list 'c 'd)) (z 'e)) (rotatef (car x) (car y) z) (values x y z)) (c b) (e d) a) (deftest rotatef.7 (let* ((x (list 'a 'b)) (y (list 'c 'd)) (z 'e)) (rotatef (first x) (first y) z) (values x y z)) (c b) (e d) a) (deftest rotatef.8 (let* ((x (list 'a 'b)) (y (list 'c 'd)) (z '(e))) (rotatef (cdr x) (cdr y) z) (values x y z)) (a d) (c e) (b)) (deftest rotatef.9 (let* ((x (list 'a 'b)) (y (list 'c 'd)) (z '(e))) (rotatef (rest x) (rest y) z) (values x y z)) (a d) (c e) (b)) (deftest rotatef.10 (let* ((x (list 'a 'b)) (y (list 'c 'd)) (z 'e)) (rotatef (cadr x) (cadr y) z) (values x y z)) (a d) (c e) b) (deftest rotatef.11 (let* ((x (list 'a 'b)) (y (list 'c 'd)) (z 'e)) (rotatef (second x) (second y) z) (values x y z)) (a d) (c e) b) (deftest rotatef.12 (let* ((x (list 'a 'b 'c)) (y (list 'd 'e 'f)) (z (list 'g))) (rotatef (cddr x) (cddr y) z) (values x y z)) (a b f) (d e g) (c)) (deftest rotatef.13 (let* ((x (list (list 'a))) (y (list (list 'c))) (z 'e)) (rotatef (caar x) (caar y) z) (values x y z)) ((c)) ((e)) a) (deftest rotatef.14 (let* ((x (list (list 'a 'b))) (y (list (list 'c 'd))) (z (list 'e))) (rotatef (cdar x) (cdar y) z) (values x y z)) ((a d)) ((c e)) (b)) ;;; TODO: c*r accessors with > 2 a/d ;;; TODO: third,...,tenth (deftest rotatef.15 (let* ((x (vector 'a 'b)) (y (vector 'c 'd)) (z 'e)) (rotatef (aref x 0) (aref y 0) z) (values x y z)) #(c b) #(e d) a) (deftest rotatef.16 (let* ((x (vector 'a 'b)) (y (vector 'c 'd)) (z 'e)) (rotatef (svref x 0) (svref y 0) z) (values x y z)) #(c b) #(e d) a) (deftest rotatef.17 (let* ((x (copy-seq #*11000)) (y (copy-seq #*11100)) (z 1)) (rotatef (bit x 1) (bit y 3) z) (values x y z)) #*10000 #*11110 1) (deftest rotatef.18 (let* ((x (copy-seq "abcde")) (y (copy-seq "fghij")) (z #\X)) (rotatef (char x 1) (char y 2) z) (values x y z)) "ahcde" "fgXij" #\b) (deftest rotatef.21 (let* ((x (copy-seq #*11000)) (y (copy-seq #*11100)) (z 1)) (rotatef (bit x 1) (bit y 3) z) (values x y z)) #*10000 #*11110 1) (deftest rotatef.22 (let* ((x (copy-seq "abcde")) (y (copy-seq "fghij")) (z #\X)) (rotatef (char x 1) (char y 2) z) (values x y z)) "ahcde" "fgXij" #\b) (deftest rotatef.23 (let* ((x (copy-seq '(a b c d e))) (y (copy-seq '(f g h i j))) (z 'k)) (rotatef (elt x 1) (elt y 2) z) (values x y z)) (a h c d e) (f g k i j) b) (deftest rotatef.24 (let ((x #b01010101) (y #b1111) (z 0)) (rotatef (ldb (byte 4 2) x) (ldb (byte 4 1) y) z) (values x y z)) #b01011101 1 #b0101) (deftest rotatef.25 (let* ((f1 (gensym)) (f2 (gensym)) (fn1 (constantly :foo)) (fn2 (constantly :bar)) (fn3 (constantly :zzz))) (setf (fdefinition f1) fn1 (fdefinition f2) fn2) (rotatef (fdefinition f1) (fdefinition f2) fn3) (values (funcall f1) (funcall f2) (funcall fn3))) :bar :zzz :foo) (deftest rotatef.26 (let* ((a1 (make-array '(10) :fill-pointer 5)) (a2 (make-array '(20) :fill-pointer 7)) (z 3)) (rotatef (fill-pointer a1) (fill-pointer a2) z) (values (fill-pointer a1) (fill-pointer a2) z)) 7 3 5) (deftest rotatef.27 (let* ((x (list 'a 'b 'c 'd)) (y (list 'd 'e 'f 'g)) (n1 1) (n2 2) (z 'h)) (rotatef (nth n1 x) (nth n2 y) z) (values x y z)) (a f c d) (d e h g) b) (deftest rotatef.28 (let* ((f1 (gensym)) (f2 (gensym)) (fn1 (constantly :foo)) (fn2 (constantly :bar)) (fn3 (constantly :zzz))) (setf (symbol-function f1) fn1 (symbol-function f2) fn2) (rotatef (symbol-function f1) (symbol-function f2) fn3) (values (funcall f1) (funcall f2) (funcall fn3))) :bar :zzz :foo) (deftest rotatef.29 (let* ((s1 (gensym)) (s2 (gensym)) (z 1)) (setf (symbol-value s1) :foo (symbol-value s2) :bar) (rotatef (symbol-value s1) (symbol-value s2) z) (values (symbol-value s1) (symbol-value s2) z)) :bar 1 :foo) (deftest rotatef.30 (let* ((s1 (gensym)) (s2 (gensym)) (v1 (list :foo 1)) (v2 (list :bar 2)) (z nil)) (setf (symbol-plist s1) v1 (symbol-plist s2) v2) (rotatef (symbol-plist s1) (symbol-plist s2) z) (values (symbol-plist s1) (symbol-plist s2) z)) (:bar 2) nil (:foo 1)) (deftest rotatef.31 (let* ((x (list 'a 'b 'c 'd 'e)) (y (list 'f 'g 'h 'i 'j)) (p1 1) (p2 2) (len 3) (z '(10 11 12))) (rotatef (subseq x p1 (+ p1 len)) (subseq y p2 (+ p2 len)) z) (values x y z)) (a h i j e) (f g 10 11 12) (b c d)) (deftest rotatef.32 (let* ((x (gensym)) (y (gensym)) (k1 :foo) (k2 :bar) (v1 1) (v2 2) (z 17)) (setf (get x k1) v1 (get y k2) v2) (rotatef (get x k1) (get y k2) z) (values (symbol-plist x) (symbol-plist y) z)) (:foo 2) (:bar 17) 1) (deftest rotatef.33 (let* ((x nil) (y nil) (k1 :foo) (k2 :bar) (v1 1) (v2 2) (z 21)) (setf (getf x k1) v1 (getf y k2) v2) (rotatef (getf x k1) (getf y k2) z) (values x y z)) (:foo 2) (:bar 21) 1) (deftest rotatef.34 (let* ((ht1 (make-hash-table)) (ht2 (make-hash-table)) (k1 :foo) (v1 1) (k2 :bar) (v2 2) (z 3)) (setf (gethash k1 ht1) v1 (gethash k2 ht2) v2) (rotatef z (gethash k1 ht1) (gethash k2 ht2)) (values z (gethash k1 ht1) (gethash k2 ht2))) 1 2 3) (deftest rotatef.35 (let ((n1 (gensym)) (n2 (gensym)) (n3 (gensym)) (n4 (gensym))) (eval `(defclass ,n1 () ())) (eval `(defclass ,n2 () ())) (setf (find-class n3) (find-class n1) (find-class n4) (find-class n2)) (rotatef (find-class n3) (find-class n4)) (values (eqlt (find-class n1) (find-class n4)) (eqlt (find-class n2) (find-class n3)))) t t) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest rotatef.36 (macrolet ((%m (z) z)) (let ((x 1) (y 2)) (rotatef (expand-in-current-env (%m x)) y) (values x y))) 2 1) (deftest rotatef.37 (macrolet ((%m (z) z)) (let ((x 1) (y 2)) (rotatef x (expand-in-current-env (%m y))) (values x y))) 2 1) ;;; TODO: macro-function, mask-field, row-major-aref, ;;; logical-pathname-translations, readtable-case gcl27-2.7.0/ansi-tests/round-aux.lsp000066400000000000000000000054751454061450500172110ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Aug 21 14:21:07 2003 ;;;; Contains: Aux. functions for testing ROUND (in-package :cl-test) (defun round.1-fn () (loop for n = (- (random 2000000000) 1000000000) for d = (1+ (random 10000)) for vals = (multiple-value-list (round n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (= n n2) (integerp r) (<= (- (/ d 2)) r (/ d 2))) unless (or (not (= (abs r) (/ d 2))) (evenp q)) collect (list n d q r n2))) (defun round.2-fn () (loop for num = (random 1000000000) for denom = (1+ (random 1000)) for n = (/ num denom) for d = (1+ (random 10000)) for vals = (multiple-value-list (round n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (<= (- (/ d 2)) r (/ d 2)) (or (not (= (abs r) (/ d 2))) (evenp q)) (= n n2)) collect (list n d q r n2))) (defun round.3-fn (width) (loop for n = (- (random width) (/ width 2)) for vals = (multiple-value-list (round n)) for (q r) = vals for n2 = (+ q r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (= n n2) (<= -1/2 r 1/2) (or (not (= (abs r) 1/2)) (evenp q)) ) collect (list n q r n2))) (defun round.7-fn () (loop for numerator = (- (random 10000000000) 5000000000) for denominator = (1+ (random 100000)) for n = (/ numerator denominator) for vals = (multiple-value-list (round n)) for (q r) = vals for n2 = (+ q r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (rationalp r) (= n n2) (<= -1/2 r 1/2) (or (not (= (abs r) 1/2)) (evenp q)) ) collect (list n q r n2))) (defun round.8-fn () (loop for num1 = (- (random 10000000000) 5000000000) for den1 = (1+ (random 100000)) for n = (/ num1 den1) for num2 = (- (1+ (random 1000000))) for den2 = (1+ (random 1000000)) for d = (/ num2 den2) for vals = (multiple-value-list (round n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (rationalp r) (<= (/ d 2) r (- (/ d 2))) (or (not (= (abs r) (- (/ d 2)))) (evenp q)) (= n n2)) collect (list n q d r n2))) (defun round.9-fn () (loop for num1 = (- (random 1000000000000000) 500000000000000) for den1 = (1+ (random 10000000000)) for n = (/ num1 den1) for num2 = (- (1+ (random 1000000000))) for den2 = (1+ (random 10000000)) for d = (/ num2 den2) for vals = (multiple-value-list (round n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (rationalp r) (<= (/ d 2) r (- (/ d 2))) (or (not (= (abs r) (- (/ d 2)))) (evenp q)) (= n n2)) collect (list n q d r n2))) gcl27-2.7.0/ansi-tests/round.lsp000066400000000000000000000070751454061450500164140ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Aug 21 13:39:56 2003 ;;;; Contains: Tests of ROUND (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "round-aux.lsp") (deftest round.error.1 (signals-error (round) program-error) t) (deftest round.error.2 (signals-error (round 1.0 1 nil) program-error) t) ;;; (deftest round.1 (round.1-fn) nil) (deftest round.2 (round.2-fn) nil) (deftest round.3 (round.3-fn 2.0s4) nil) (deftest round.4 (round.3-fn 2.0f4) nil) (deftest round.5 (round.3-fn 2.0d4) nil) (deftest round.6 (round.3-fn 2.0l4) nil) (deftest round.7 (round.7-fn) nil) (deftest round.8 (round.8-fn) nil) (deftest round.9 (round.9-fn) nil) (deftest round.10 (loop for x in (remove-if #'zerop *reals*) for (q r) = (multiple-value-list (round x x)) unless (and (eql q 1) (zerop r) (if (rationalp x) (eql r 0) (eql r (float 0 x)))) collect x) nil) (deftest round.11 (loop for x in (remove-if #'zerop *reals*) for (q r) = (multiple-value-list (round (- x) x)) unless (and (eql q -1) (zerop r) (if (rationalp x) (eql r 0) (eql r (float 0 x)))) collect x) nil) (deftest round.12 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 0.5s0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (round x)) unless (and (eql q i) (eql r rrad)) collect (list i x q r))) nil) (deftest round.13 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 0.5s0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (round x)) unless (and (eql q i) (eql r (- rrad))) collect (list i x q r))) nil) (deftest round.14 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 0.5f0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (round x)) unless (and (eql q i) (eql r rrad)) collect (list i x q r))) nil) (deftest round.15 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 0.5f0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (round x)) unless (and (eql q i) (eql r (- rrad))) collect (list i x q r))) nil) (deftest round.16 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 0.5d0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (round x)) unless (and (eql q i) (eql r rrad)) collect (list i x q r))) nil) (deftest round.17 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 0.5d0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (round x)) unless (and (eql q i) (eql r (- rrad))) collect (list i x q r))) nil) (deftest round.18 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 0.5l0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (round x)) unless (and (eql q i) (eql r rrad)) collect (list i x q r))) nil) (deftest round.19 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 0.5l0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (round x)) unless (and (eql q i) (eql r (- rrad))) collect (list i x q r))) nil) (deftest round.20 (round 1/2) 0 1/2) (deftest round.21 (round 3/2) 2 -1/2) gcl27-2.7.0/ansi-tests/row-major-aref.lsp000066400000000000000000000052601454061450500201070ustar00rootroot00000000000000;-*- 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 (signals-error (row-major-aref) program-error) t) gcl27-2.7.0/ansi-tests/rplaca.lsp000066400000000000000000000017421454061450500165220ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:29:43 2003 ;;;; Contains: Tests of RPLACA (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) ;; rplaca on a non-cons is a type error (deftest rplaca.error.1 (check-type-error #'(lambda (x) (rplaca x 1)) #'consp) nil) (deftest rplaca.error.2 (signals-error (rplaca) program-error) t) (deftest rplaca.error.3 (signals-error (rplaca (cons 'a 'b)) program-error) t) (deftest rplaca.error.4 (signals-error (rplaca (cons 'a 'b) (cons 'c 'd) 'garbage) program-error) t) (deftest rplaca.error.6 (signals-error (locally (rplaca 'a 1) t) type-error) t) gcl27-2.7.0/ansi-tests/rplacd.lsp000066400000000000000000000017431454061450500165260ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:30:28 2003 ;;;; Contains: Tests of RPLACD (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) ;; rplacd on a non-cons is a type error (deftest rplacd.error.1 (check-type-error #'(lambda (x) (rplacd x 1)) #'consp) nil) (deftest rplacd.error.2 (signals-error (rplacd) program-error) t) (deftest rplacd.error.3 (signals-error (rplacd (cons 'a 'b)) program-error) t) (deftest rplacd.error.4 (signals-error (rplacd (cons 'a 'b) (cons 'c 'd) 'garbage) program-error) t) (deftest rplacd.error.6 (signals-error (locally (rplacd 'a 1) t) type-error) t) gcl27-2.7.0/ansi-tests/rt-acl.system000066400000000000000000000004771454061450500171740ustar00rootroot00000000000000;-*- 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")) gcl27-2.7.0/ansi-tests/rt-doc.txt000066400000000000000000000207731454061450500164760ustar00rootroot00000000000000 #|----------------------------------------------------------------------------| | 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. gcl27-2.7.0/ansi-tests/rt-package.lsp000066400000000000000000000025761454061450500173040ustar00rootroot00000000000000;-*- 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) #| (defpackage :regression-test (:use :cl) (:nicknames :rtest #-lispworks :rt) (:export #:*do-tests-when-defined* #:*compile-tests* #:*test* #:continue-testing #:deftest #:do-test #:do-tests #:get-test #:pending-tests #:rem-all-tests #:rem-test #:defnote #:my-aref #:*catch-errors* #:disable-note )) |# (let* ((name (symbol-name :regression-test)) (pkg (find-package name))) (unless pkg (setq pkg (make-package name :nicknames (mapcar #'symbol-name '(:rtest #-lispworks :rt)) :use '(#-wcl :cl #+wcl :lisp) ))) (let ((*package* pkg)) (export (mapcar #'intern (mapcar #'symbol-name '(#:*compile-tests* #:*do-tests-when-defined* #:*test* #:continue-testing #:deftest #:do-test #:do-tests #:do-extended-tests #:get-test #:pending-tests #:rem-all-tests #:rem-test #:defnote #:my-aref #:*catch-errors* #:*passed-tests* #:*failed-tests* #:disable-note)))))) ;; ) ;; (in-package :regression-test) gcl27-2.7.0/ansi-tests/rt-test.lsp000066400000000000000000000163401454061450500166620ustar00rootroot00000000000000;-*-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. (cl:defpackage :rt-tests (:use :cl :regression-test)) (in-package :rt-tests) ;; (require "RT") ;;(use-package :regression-test) (defmacro setup (&rest body) `(do-setup '(progn ., body))) (defmacro with-blank-tests (&body body) `(let ((regression-test::*entries* (list nil)) (regression-test::*entries-table* (make-hash-table :test #'equal)) (*test* nil) (regression-test::*in-test* nil)) (let ((regression-test::*entries-tail* regression-test::*entries*)) ,@body))) (defun do-setup (form) (with-blank-tests (let ((*do-tests-when-defined* 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 RT-TESTS::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 (RT-TESTS::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 RT-TESTS::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." " RT-TESTS::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." " RT-TESTS::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." " RT-TESTS::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." " RT-TESTS::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 :out s)))) () ("Doing 2 pending tests of 2 tests total." " RT-TESTS::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 :out s))) () ("Doing 2 pending tests of 2 tests total." " RT-TESTS::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)) gcl27-2.7.0/ansi-tests/rt.lsp000066400000000000000000000337341454061450500157130ustar00rootroot00000000000000;-*-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 was the December 19, 1990 version of the regression tester, but ;has since been modified. (in-package :regression-test) (declaim (ftype (function (t) t) get-entry expanded-eval do-entries)) (declaim (type list *entries*)) (declaim (ftype (function (t &rest t) t) report-error)) (declaim (ftype (function (t &optional t) t) do-entry)) (defvar *test* nil "Current test name") (defvar *do-tests-when-defined* nil) (defvar *entries* (list nil) "Test database. Has a leading dummy cell that does not contain an entry.") (defvar *entries-tail* *entries* "Tail of the *entries* list") (defvar *entries-table* (make-hash-table :test #'equal) "Map the names of entries to the cons cell in *entries* that precedes the one whose car is the entry.") (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 *expanded-eval* nil "When true, convert the tests into a form that is less likely to have compiler optimizations.") (defvar *optimization-settings* '((safety 3))) (defvar *failed-tests* nil "After DO-TESTS, becomes the list of names of tests that have failed") (defvar *passed-tests* nil "After DO-TESTS, becomes the list of names of tests that have passed") (defvar *expected-failures* nil "A list of test names that are expected to fail.") (defvar *notes* (make-hash-table :test 'equal) "A mapping from names of notes to note objects.") (defstruct (entry (:conc-name nil)) pend name props form vals) ;;; Note objects are used to attach information to tests. ;;; A typical use is to mark tests that depend on a particular ;;; part of a set of requirements, or a particular interpretation ;;; of the requirements. (defstruct note name contents disabled ;; When true, tests with this note are considered inactive ) ;; (defmacro vals (entry) `(cdddr ,entry)) (defmacro defn (entry) (let ((var (gensym))) `(let ((,var ,entry)) (list* (name ,var) (form ,var) (vals ,var))))) (defun entry-notes (entry) (let* ((props (props entry)) (notes (getf props :notes))) (if (listp notes) notes (list notes)))) (defun has-disabled-note (entry) (let ((notes (entry-notes entry))) (loop for n in notes for note = (if (note-p n) n (gethash n *notes*)) thereis (and note (note-disabled note))))) (defun has-note (entry note) (unless (note-p note) (let ((new-note (gethash note *notes*))) (setf note new-note))) (and note (not (not (member note (entry-notes entry)))))) (defun pending-tests () (loop for entry in (cdr *entries*) when (and (pend entry) (not (has-disabled-note entry))) collect (name entry))) (defun rem-all-tests () (setq *entries* (list nil)) (setq *entries-tail* *entries*) (clrhash *entries-table*) nil) (defun rem-test (&optional (name *test*)) (let ((pred (gethash name *entries-table*))) (when pred (if (null (cddr pred)) (setq *entries-tail* pred) (setf (gethash (name (caddr pred)) *entries-table*) pred)) (setf (cdr pred) (cddr pred)) (remhash name *entries-table*) name))) (defun get-test (&optional (name *test*)) (defn (get-entry name))) (defun get-entry (name) (let ((entry ;; (find name (the list (cdr *entries*)) ;; :key #'name :test #'equal) (cadr (gethash name *entries-table*)) )) (when (null entry) (report-error t "~%No test with name ~:@(~S~)." name)) entry)) (defmacro deftest (name &rest body) (let* ((p body) (properties (loop while (keywordp (first p)) unless (cadr p) do (error "Poorly formed deftest: ~A~%" (list* 'deftest name body)) append (list (pop p) (pop p)))) (form (pop p)) (vals p)) `(add-entry (make-entry :pend t :name ',name :props ',properties :form ',form :vals ',vals)))) (defun add-entry (entry) (setq entry (copy-entry entry)) (let* ((pred (gethash (name entry) *entries-table*))) (cond (pred (setf (cadr pred) entry) (report-error nil "Redefining test ~:@(~S~)" (name entry))) (t (setf (gethash (name entry) *entries-table*) *entries-tail*) (setf (cdr *entries-tail*) (cons entry nil)) (setf *entries-tail* (cdr *entries-tail*)) ))) (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))) nil) (defun do-test (&optional (name *test*) &rest key-args) (flet ((%parse-key-args (&key ((:catch-errors *catch-errors*) *catch-errors*) ((:compile *compile-tests*) *compile-tests*)) (do-entry (get-entry name)))) (apply #'%parse-key-args key-args))) (defun my-aref (a &rest args) (apply #'aref a args)) (defun my-row-major-aref (a index) (row-major-aref a index)) (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 ((eq x y) t) ((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 (my-aref x) (my-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 i from 0 below x-len for e1 = (my-aref x i) for e2 = (my-aref y i) always (equalp-with-case e1 e2)))))) ((and (typep x 'array) (typep y 'array) (not (equal (array-dimensions x) (array-dimensions y)))) nil) ((typep x 'array) (and (typep y 'array) (let ((size (array-total-size x))) (loop for i from 0 below size always (equalp-with-case (my-row-major-aref x i) (my-row-major-aref y i)))))) ((typep x 'pathname) (equal x y)) (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*)) (block aborted (setf r (flet ((%do () (handler-bind #-sbcl nil #+sbcl ((sb-ext:code-deletion-note #'(lambda (c) (if (has-note entry :do-not-muffle) nil (muffle-warning c))))) (cond (*compile-tests* (multiple-value-list (funcall (compile nil `(lambda () (declare (optimize ,@*optimization-settings*)) ,(form entry)))))) (*expanded-eval* (multiple-value-list (expanded-eval (form entry)))) (t (multiple-value-list (eval (form entry)))))))) (if *catch-errors* (handler-bind (#-ecl (style-warning #'(lambda (c) (if (has-note entry :do-not-muffle-warnings) c (muffle-warning c)))) (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: ~ ~{~S~^~%~17t~}~%" *test* (form entry) (length (vals entry)) (vals entry)) (handler-case (let ((st (format nil "Actual value~P: ~ ~{~S~^~%~15t~}.~%" (length r) r))) (format s "~A" st)) (error () (format s "Actual value: #~%"))) (finish-output s))))) (when (not (pend entry)) *test*)) (defun expanded-eval (form) "Split off top level of a form and eval separately. This reduces the chance that compiler optimizations will fold away runtime computation." (if (not (consp form)) (eval form) (let ((op (car form))) (cond ((eq op 'let) (let* ((bindings (loop for b in (cadr form) collect (if (consp b) b (list b nil)))) (vars (mapcar #'car bindings)) (binding-forms (mapcar #'cadr bindings))) (apply (the function (eval `(lambda ,vars ,@(cddr form)))) (mapcar #'eval binding-forms)))) ((and (eq op 'let*) (cadr form)) (let* ((bindings (loop for b in (cadr form) collect (if (consp b) b (list b nil)))) (vars (mapcar #'car bindings)) (binding-forms (mapcar #'cadr bindings))) (funcall (the function (eval `(lambda (,(car vars) &aux ,@(cdr bindings)) ,@(cddr form)))) (eval (car binding-forms))))) ((eq op 'progn) (loop for e on (cdr form) do (if (null (cdr e)) (return (eval (car e))) (eval (car e))))) ((and (symbolp op) (fboundp op) (not (macro-function op)) (not (special-operator-p op))) (apply (symbol-function op) (mapcar #'eval (cdr form)))) (t (eval form)))))) (defun continue-testing () (if *in-test* (throw '*in-test* nil) (do-entries *standard-output*))) (defun do-tests (&key (out *standard-output*) ((:catch-errors *catch-errors*) *catch-errors*) ((:compile *compile-tests*) *compile-tests*)) (setq *failed-tests* nil *passed-tests* nil) (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 (the list (cdr *entries*)) :key #'pend) (length (cdr *entries*))) (finish-output s) (dolist (entry (cdr *entries*)) (when (and (pend entry) (not (has-disabled-note entry))) (let ((success? (do-entry entry s))) (if success? (push (name entry) *passed-tests*) (push (name entry) *failed-tests*)) (format s "~@[~<~%~:; ~:@(~S~)~>~]" success?)) (finish-output 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))) )) (finish-output s) (null pending)))) ;;; Note handling functions and macros (defmacro defnote (name contents &optional disabled) `(eval-when (:load-toplevel :execute) (let ((note (make-note :name ',name :contents ',contents :disabled ',disabled))) (setf (gethash (note-name note) *notes*) note) note))) (defun disable-note (n) (let ((note (if (note-p n) n (setf n (gethash n *notes*))))) (unless note (error "~A is not a note or note name." n)) (setf (note-disabled note) t) note)) (defun enable-note (n) (let ((note (if (note-p n) n (setf n (gethash n *notes*))))) (unless note (error "~A is not a note or note name." n)) (setf (note-disabled note) nil) note)) ;;; Extended random regression (defun do-extended-tests (&key (tests *passed-tests*) (count nil) ((:catch-errors *catch-errors*) *catch-errors*) ((:compile *compile-tests*) *compile-tests*)) "Execute randomly chosen tests from TESTS until one fails or until COUNT is an integer and that many tests have been executed." (let ((test-vector (coerce tests 'simple-vector))) (let ((n (length test-vector))) (when (= n 0) (error "Must provide at least one test.")) (loop for i from 0 for name = (svref test-vector (random n)) until (eql i count) do (print name) unless (do-test name) return (values name (1+ i)))))) gcl27-2.7.0/ansi-tests/rt.system000066400000000000000000000012501454061450500164250ustar00rootroot00000000000000;-*- 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")))) gcl27-2.7.0/ansi-tests/sbit.lsp000066400000000000000000000034061454061450500162200ustar00rootroot00000000000000;-*- 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 (signals-error (sbit) program-error) t) gcl27-2.7.0/ansi-tests/search-aux.lsp000066400000000000000000000057521454061450500173250ustar00rootroot00000000000000;-*- 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)))) (setq test (coerce test 'function)) (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 (the function 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))))) gcl27-2.7.0/ansi-tests/search-bitvector.lsp000066400000000000000000000122551454061450500205250ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 25 13:06:54 2002 ;;;; Contains: Tests for SEARCH on bit vectors (in-package :cl-test) (compile-and-load "search-aux.lsp") (deftest search-bitvector.1 (let ((target *searched-bitvector*) (pat #*0)) (loop for i from 0 to (1- (length target)) for tail = (subseq target i) always (let ((pos (search pat tail))) (search-check pat tail pos)))) t) (deftest search-bitvector.2 (let ((target *searched-bitvector*) (pat #*0)) (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) ;; Order of test, test-not (deftest search-bitvector.17 (let ((pat #*10) (target #*000011)) (search pat target :test #'<=)) 4) (deftest search-bitvector.18 (let ((pat #*10) (target #*000011)) (search pat target :test-not #'>)) 4) gcl27-2.7.0/ansi-tests/search-list.lsp000066400000000000000000000174051454061450500175010ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 24 07:22:10 2002 ;;;; Contains: Tests for SEARCH on lists (in-package :cl-test) (compile-and-load "search-aux.lsp") (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) ;; Order of test, test-not (deftest search-list.15 (let ((pat '(10)) (target '(1 4 6 10 15 20))) (search pat target :test #'<)) 4) (deftest search-list.16 (let ((pat '(10)) (target '(1 4 6 10 15 20))) (search pat target :test-not #'>=)) 4) (defharmless search.test-and-test-not.1 (search '(b c) '(a b c d) :test #'eql :test-not #'eql)) (defharmless search.test-and-test-not.2 (search '(b c) '(a b c d) :test-not #'eql :test #'eql)) (defharmless search.test-and-test-not.3 (search #(b c) #(a b c d) :test #'eql :test-not #'eql)) (defharmless search.test-and-test-not.4 (search #(b c) #(a b c d) :test-not #'eql :test #'eql)) (defharmless search.test-and-test-not.5 (search "bc" "abcd" :test #'eql :test-not #'eql)) (defharmless search.test-and-test-not.6 (search "bc" "abcd" :test-not #'eql :test #'eql)) (defharmless search.test-and-test-not.7 (search #*01 #*0011 :test #'eql :test-not #'eql)) (defharmless search.test-and-test-not.8 (search #*01 #*0011 :test-not #'eql :test #'eql)) ;;; 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 (signals-error (search) program-error) t) (deftest search.error.2 (signals-error (search "a") program-error) t) (deftest search.error.3 (signals-error (search "a" "a" :key) program-error) t) (deftest search.error.4 (signals-error (search "a" "a" 'bad t) program-error) t) (deftest search.error.5 (signals-error (search "a" "a" 'bad t :allow-other-keys nil) program-error) t) (deftest search.error.6 (signals-error (search "a" "a" 1 2) program-error) t) (deftest search.error.7 (signals-error (search "c" "abcde" :test #'identity) program-error) t) (deftest search.error.8 (signals-error (search "c" "abcde" :test-not #'identity) program-error) t) (deftest search.error.9 (signals-error (search "c" "abcde" :key #'cons) program-error) t) (deftest search.error.10 (signals-error (search "c" "abcde" :key #'car) type-error) t) ;;; 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)gcl27-2.7.0/ansi-tests/search-string.lsp000066400000000000000000000123251454061450500200300ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 25 13:06:54 2002 ;;;; Contains: Tests for SEARCH on strings (in-package :cl-test) (compile-and-load "search-aux.lsp") ;;; 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) ;; Order of test, test-not (deftest search-string.17 (let ((pat "m") (target '"adgmnpq")) (search pat target :test #'char<)) 4) (deftest search-string.18 (let ((pat "m") (target '"adgmnpq")) (search pat target :test-not #'char>=)) 4) ;;; Specialized strings (deftest search-string.19 (do-special-strings (s "a" nil) (assert (eql (search s "xyza123apqr") 3)) (assert (eql (search s "xyza1a3apqr" :start2 4) 5)) (assert (eql (search s "xyza123apqr" :from-end t) 7))) nil) (deftest search-string.20 (do-special-strings (s "xababcdefabc123ababc18" nil) (assert (eql (search "abc" s) 3)) (assert (eql (search "abc" s :start2 4) 9)) (assert (eql (search "abc" s :from-end t) 17))) nil) gcl27-2.7.0/ansi-tests/search-vector.lsp000066400000000000000000000122641454061450500200260ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 25 13:06:54 2002 ;;;; Contains: Tests for SEARCH on vectors (in-package :cl-test) (compile-and-load "search-aux.lsp") (deftest search-vector.1 (let ((target *searched-vector*) (pat #(a))) (loop for i from 0 to (1- (length target)) for tail = (subseq target i) 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) ;; Order of test, test-not (deftest search-vector.17 (let ((pat #(10)) (target #(1 4 6 10 15 20))) (search pat target :test #'<)) 4) (deftest search-vector.18 (let ((pat #(10)) (target #(1 4 6 10 15 20))) (search pat target :test-not #'>=)) 4)gcl27-2.7.0/ansi-tests/set-difference.lsp000066400000000000000000000167321454061450500201500ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:44:06 2003 ;;;; Contains: Tests of SET-DIFFERENCE (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) (defharmless set-difference.test-and-test-not.1 (set-difference (list 1 2 3 4) (list 1 7 3 8) :test #'eql :test-not #'eql)) (defharmless set-difference.test-and-test-not.2 (set-difference (list 1 2 3 4) (list 1 7 3 8) :test-not #'eql :test #'eql)) ;;; 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) (def-fold-test set-difference.fold.1 (set-difference '(a b c d e f g h) '(b w h x e y))) ;;; Error tests (deftest set-difference.error.1 (signals-error (set-difference) program-error) t) (deftest set-difference.error.2 (signals-error (set-difference nil) program-error) t) (deftest set-difference.error.3 (signals-error (set-difference nil nil :bad t) program-error) t) (deftest set-difference.error.4 (signals-error (set-difference nil nil :key) program-error) t) (deftest set-difference.error.5 (signals-error (set-difference nil nil 1 2) program-error) t) (deftest set-difference.error.6 (signals-error (set-difference nil nil :bad t :allow-other-keys nil) program-error) t) (deftest set-difference.error.7 (signals-error (set-difference (list 1 2) (list 3 4) :test #'identity) program-error) t) (deftest set-difference.error.8 (signals-error (set-difference (list 1 2) (list 3 4) :test-not #'identity) program-error) t) (deftest set-difference.error.9 (signals-error (set-difference (list 1 2) (list 3 4) :key #'cons) program-error) t) (deftest set-difference.error.10 (signals-error (set-difference (list 1 2) (list 3 4) :key #'car) type-error) t) (deftest set-difference.error.11 (signals-error (set-difference (list 1 2 3) (list* 4 5 6)) type-error) t) (deftest set-difference.error.12 (signals-error (set-difference (list* 1 2 3) (list 4 5 6)) type-error) t) (deftest set-difference.error.13 (check-type-error #'(lambda (x) (set-difference x '(a b c))) #'listp) nil) (deftest set-difference.error.14 (check-type-error #'(lambda (x) (set-difference '(a b c) x)) #'listp) nil) gcl27-2.7.0/ansi-tests/set-exclusive-or.lsp000066400000000000000000000216531454061450500205010ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:45:46 2003 ;;;; Contains: Tests of SET-EXCLUSIVE-OR (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) (defharmless set-exclusive-or.test-and-test-not.1 (set-exclusive-or (list 1 2 3 4) (list 1 7 3 8) :test #'eql :test-not #'eql)) (defharmless set-exclusive-or.test-and-test-not.2 (set-exclusive-or (list 1 2 3 4) (list 1 7 3 8) :test-not #'eql :test #'eql)) ;;; 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) (def-fold-test set-exclusive-or.fold.1 (set-exclusive-or '(a b c d e f) '(b x e y z c))) ;;; Error tests (deftest set-exclusive-or.error.1 (signals-error (set-exclusive-or) program-error) t) (deftest set-exclusive-or.error.2 (signals-error (set-exclusive-or nil) program-error) t) (deftest set-exclusive-or.error.3 (signals-error (set-exclusive-or nil nil :bad t) program-error) t) (deftest set-exclusive-or.error.4 (signals-error (set-exclusive-or nil nil :key) program-error) t) (deftest set-exclusive-or.error.5 (signals-error (set-exclusive-or nil nil 1 2) program-error) t) (deftest set-exclusive-or.error.6 (signals-error (set-exclusive-or nil nil :bad t :allow-other-keys nil) program-error) t) (deftest set-exclusive-or.error.7 (signals-error (set-exclusive-or (list 1 2) (list 3 4) :test #'identity) program-error) t) (deftest set-exclusive-or.error.8 (signals-error (set-exclusive-or (list 1 2) (list 3 4) :test-not #'identity) program-error) t) (deftest set-exclusive-or.error.9 (signals-error (set-exclusive-or (list 1 2) (list 3 4) :key #'cons) program-error) t) (deftest set-exclusive-or.error.10 (signals-error (set-exclusive-or (list 1 2) (list 3 4) :key #'car) type-error) t) (deftest set-exclusive-or.error.11 (signals-error (set-exclusive-or (list 1 2 3) (list* 4 5 6)) type-error) t) (deftest set-exclusive-or.error.12 (signals-error (set-exclusive-or (list* 1 2 3) (list 4 5 6)) type-error) t) (deftest set-exclusive-or.error.13 (check-type-error #'(lambda (x) (set-exclusive-or x '(a b c))) #'listp) nil) (deftest set-exclusive-or.error.14 (check-type-error #'(lambda (x) (set-exclusive-or '(a b c) x)) #'listp) nil) ;;; Randomized test (deftest random-set-exclusive-or (random-set-exclusive-or-test 10 100) nil) gcl27-2.7.0/ansi-tests/set-macro-character.lsp000066400000000000000000000034151454061450500211030ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 3 10:37:16 2005 ;;;; Contains: Tests of SET-MACRO-CHARACTER (in-package :cl-test) (def-syntax-test set-macro-character.1 (let ((*readtable* (copy-readtable)) (*package* (find-package :cl-test))) (let ((v1 (read-from-string "?!"))) (assert (eql v1 '?!)) (flet ((%f (stream char) (declare (ignore stream)) (assert (eql char #\?)) 17)) (let ((fn #'%f)) (assert (equal (multiple-value-list (set-macro-character #\? fn nil)) '(t))) (values (multiple-value-list (read-from-string "?!")) (multiple-value-list (read-from-string "!?"))))))) (17 1) (! 1)) (def-syntax-test set-macro-character.2 (let ((rt (copy-readtable)) (*package* (find-package :cl-test))) (let ((v1 (read-from-string "?!"))) (assert (eql v1 '?!)) (flet ((%f (stream char) (declare (ignore stream)) (assert (eql char #\?)) 17)) (let ((fn #'%f)) (assert (equal (multiple-value-list (set-macro-character #\? fn t rt)) '(t))) (let ((*readtable* rt)) (values (multiple-value-list (read-from-string "?!")) (multiple-value-list (read-from-string "!?")))))))) (17 1) (!? 2)) (defun set-macro-character.3-test-fn (stream char) (declare (ignore stream)) (assert (eql char #\?)) :foo) (def-syntax-test set-macro-character.3 (let ((*readtable* (copy-readtable)) (*package* (find-package :cl-test))) (let ((v1 (read-from-string "?!")) (fn 'set-macro-character.3-test-fn)) (assert (eql v1 '?!)) (assert (equal (multiple-value-list (set-macro-character #\? fn nil)) '(t))) (values (multiple-value-list (read-from-string "?!")) (multiple-value-list (read-from-string "!?"))))) (:foo 1) (! 1)) gcl27-2.7.0/ansi-tests/set-syntax-from-char.lsp000066400000000000000000000331541454061450500212550ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 29 06:37:18 2005 ;;;; Contains: Tests of SET-SYNTAX-FROM-CHAR (in-package :cl-test) (compile-and-load "reader-aux.lsp") (defmacro def-set-syntax-from-char-test (name form &body expected-values) `(deftest ,name (with-standard-io-syntax (let ((*readtable* (copy-readtable nil))) (setf (readtable-case *readtable*) :preserve) ,form)) ,@expected-values)) ;;; Test that constituent traits are not altered when a constituent character ;;; syntax type is set (defmacro def-set-syntax-from-char-trait-test (c test-form expected-value) (setq c (typecase c (character c) ((or string symbol) (name-char (string c))) (t nil))) (when c ;; (format t "~A ~A~%" c (char-name c)) `(def-set-syntax-from-char-test ,(intern (concatenate 'string "SET-SYNTAX-FROM-CHAR-TRAIT-X-" (or (char-name c) (string c))) :cl-test) (let ((c ,c)) (values (set-syntax-from-char c #\X) ,test-form)) t ,expected-value))) (defmacro def-set-syntax-from-char-alphabetic-trait-test (c) `(def-set-syntax-from-char-trait-test ,c (let* ((*package* (find-package "CL-TEST")) (sym (read-from-string (string c)))) (list (let ((sym2 (find-symbol (string c)))) (or (eqt sym sym2) (list sym sym2))) (or (equalt (symbol-name sym) (string c)) (list (symbol-name sym) (string c))))) (t t))) (loop for c across "\\|!\"#$%&'()*,;<=>?@[]^_`~{}+-/abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" do (eval `(def-set-syntax-from-char-alphabetic-trait-test ,c))) ;;; The invalid constituent character trait of invalid and whitespace characters ;;; is exposed when they are turned into constituent characters (defmacro def-set-syntax-from-char-invalid-trait-test (c) `(def-set-syntax-from-char-trait-test ,c (handler-case (let* ((*package* (find-package "CL-TEST")) (sym (read-from-string (concatenate 'string (string c) "Z")))) sym) (reader-error (c) (declare (ignore c)) :good)) :good)) (loop for name in '("Backspace" "Tab" "Newline" "Linefeed" "Page" "Return" "Space" "Rubout") do (eval `(def-set-syntax-from-char-invalid-trait-test ,name))) ;;; Turning characters into single escape characters (deftest set-syntax-from-char.single-escape.1 (loop for c across +standard-chars+ nconc (with-standard-io-syntax (let ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST"))) (let ((results (list (set-syntax-from-char c #\\) (read-from-string (concatenate 'string (list c #\Z)))))) (unless (equal results '(t |Z|)) (list (list c results))))))) nil) (deftest set-syntax-from-char.single-escape.2 (loop for c across +standard-chars+ unless (eql c #\") nconc (with-standard-io-syntax (let ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST"))) (let ((results (list (set-syntax-from-char c #\\) (read-from-string (concatenate 'string (list #\" c #\" #\")))))) (unless (equal results '(t "\"")) (list (list c results))))))) nil) (deftest set-syntax-from-char.multiple-escape (loop for c across +standard-chars+ nconc (with-standard-io-syntax (let ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST"))) (let ((results (list (set-syntax-from-char c #\|) (handler-case (read-from-string (concatenate 'string (list c #\Z c))) (error (c) c)) (handler-case (read-from-string (concatenate 'string (list c #\z #\|))) (error (c) c)) (handler-case (read-from-string (concatenate 'string (list #\| #\Z c))) (error (c) c))))) (unless (or (eql c #\Z) (eql c #\z) (equal results '(t |Z| |z| |Z|))) (list (list c results))))))) nil) (deftest set-syntax-from-char.semicolon (loop for c across +standard-chars+ nconc (with-standard-io-syntax (let ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST")) (expected (if (eql c #\0) '1 '0)) (c2 (if (eql c #\0) #\1 #\0))) (let ((results (list (set-syntax-from-char c #\;) (handler-case (read-from-string (concatenate 'string (list c2 c #\2))) (error (c) c)) (handler-case (read-from-string (concatenate 'string (list c2 c #\2 #\Newline #\3))) (error (c) c)) (handler-case (read-from-string (concatenate 'string (list c #\2 #\Newline c2))) (error (c) c))))) (unless (equal results (list t expected expected expected)) (list (list c results))))))) nil) (deftest set-syntax-from-char.left-paren (loop for c across +standard-chars+ unless (find c ")") nconc (with-standard-io-syntax (let ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST")) (expected (if (eql c #\0) '(1) '(0))) (c2 (if (eql c #\0) #\1 #\0))) (let ((results (list (set-syntax-from-char c #\() (handler-case (read-from-string (concatenate 'string (list c) ")")) (error (c) c)) (handler-case (read-from-string (concatenate 'string (list c c2) ")2" (list #\Newline #\3))) (error (c) c)) (handler-case (read-from-string (concatenate 'string (list c c2) ")")) (error (c) c))))) (unless (equal results (list t nil expected expected)) (list (list c results))))))) nil) (deftest set-syntax-from-char.right-paren (loop for c across +standard-chars+ nconc (with-standard-io-syntax (let ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST"))) (let ((results (list (set-syntax-from-char c #\)) (handler-case (read-from-string (string c) nil nil) (reader-error (c) :good) (error (c) c))))) (unless (equal results '(t :good)) (list (list c results))))))) nil) (deftest set-syntax-from-char.single-quote (loop for c across +standard-chars+ nconc (with-standard-io-syntax (let ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST")) (expected (if (eql c #\0) ''1 ''0)) (c2 (if (eql c #\0) #\1 #\0))) (let ((results (list (set-syntax-from-char c #\') (handler-case (read-from-string (concatenate 'string (list c c2))) (error (c) c)) (handler-case (read-from-string (concatenate 'string (list c c2) " 2")) (error (c) c)) (handler-case (read-from-string (concatenate 'string (list c c2) ")")) (error (c) c))))) (unless (equal results (list t expected expected expected)) (list (list c results))))))) nil) ;;; I do not test that setting syntax from #\" allows the character to be ;;; used as the terminator of a double quoted string. It is not clear that ;;; the standard implies this. (deftest set-syntax-from-char.double-quote (loop for c across +standard-chars+ nconc (with-standard-io-syntax (let ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST")) (expected (if (eql c #\0) "1" "0")) (c2 (if (eql c #\0) #\1 #\0))) (let ((results (list (set-syntax-from-char c #\") (handler-case (read-from-string (concatenate 'string (list c c2 c))) (error (c) c)) (handler-case (read-from-string (concatenate 'string (list c c2 c #\2))) (error (c) c)) (handler-case (read-from-string (concatenate 'string (list c c2 c) ")")) (error (c) c))))) (unless (equal results (list t expected expected expected)) (list (list c results))))))) nil) (deftest set-syntax-from-char.backquote (loop for c across +standard-chars+ unless (find c ",x") nconc (with-standard-io-syntax (let* ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST")) (c2 (if (eql c #\Space) #\Newline #\Space)) (results (list (set-syntax-from-char c #\`) (handler-case (eval `(let ((x 0)) ,(read-from-string (concatenate 'string (list c #\, #\x))))) (error (c) c)) (handler-case (eval `(let ((x 0)) ,(read-from-string (concatenate 'string (list c #\, #\x c2))))) (error (c) c)) (handler-case (eval `(let ((x 0)) ,(read-from-string (concatenate 'string (list c c2 #\, #\x c2))))) (error (c) c))))) (unless (equal results '(t 0 0 0)) (list (list c results)))))) nil) (deftest set-syntax-from-char.comma (loop for c across +standard-chars+ unless (find c "`x") nconc (with-standard-io-syntax (let* ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST")) (c2 (if (eql c #\Space) #\Newline #\Space)) (results (list (set-syntax-from-char c #\,) (handler-case (read-from-string (string c)) (reader-error (c) :good) (error (c) c)) (handler-case (eval `(let ((x 0)) ,(read-from-string (concatenate 'string "`" (list c) "x")))) (error (c) c))))) (unless (equal results '(t :good 0)) (list (list c results)))))) nil) ;;; Tests of set-syntax-from-char on #\# (deftest set-syntax-from-char.sharp.1 (loop for c across +standard-chars+ nconc (with-standard-io-syntax (let* ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST")) (results (list (set-syntax-from-char c #\#) (if (not (eql c #\Space)) (handler-case (read-from-string (concatenate 'string (list c #\Space))) (reader-error () :good) (error (c) c)) :good) (if (not (find c "'X")) (handler-case (read-from-string (concatenate 'string (list c) "'X")) (error (c) c)) '#'|X|) (if (not (find c "(X)")) (handler-case (read-from-string (concatenate 'string (list c) "(X)")) (error (c) c)) #(|X|)) (if (not (find c ")")) (handler-case (read-from-string (concatenate 'string (list c) ")")) (reader-error (c) :good) (error (c) c)) :good) (if (not (find c "*")) (handler-case (read-from-string (concatenate 'string (list c #\*))) (error (c) c)) #*) (if (not (find c ":|")) (handler-case (let ((sym (read-from-string (concatenate 'string (list c) ":||")))) (and (symbolp sym) (null (symbol-package sym)) (symbol-name sym))) (error (c) c)) "") (handler-case (read-from-string (concatenate 'string (list c #\<))) (reader-error (c) :good) (error (c) c)) (handler-case (read-from-string (concatenate 'string (list c #\\ #\X))) (error (c) c)) (if (not (find c "1")) (handler-case (read-from-string (concatenate 'string (list c) "|1111|#1")) (error (c) c)) 1) (if (not (find c "1")) (handler-case (read-from-string (concatenate 'string (list c) "|11#|111|#11|#1")) (error (c) c)) 1) ))) (unless (equalp results '(t :good #'|X| #(|X|) :good #* "" :good #\X 1 1)) (list (list c results)))))) nil) (deftest set-syntax-from-char.sharp.2 (loop for c across +standard-chars+ nconc (with-standard-io-syntax (let* ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST")) (results (list (set-syntax-from-char c #\#) (if (not (find c "+XC ")) (handler-case (let ((*features* (cons ':X *features*))) (read-from-string (concatenate 'string (list c) "+X C"))) (error (c) c)) 'c) (if (not (find c "-(OR)")) (handler-case (read-from-string (concatenate 'string (list c) "-(OR)R")) (error (c) c)) 'r) (if (not (find c ".1")) (handler-case (read-from-string (concatenate 'string (list c) ".1")) (error (c) c)) 1) (if (not (find c "01aA")) (handler-case (list (read-from-string (concatenate 'string (list c) "0a1")) (read-from-string (concatenate 'string (list c) "0A1"))) (error (c) c)) '(#0a1 #0a1)) (if (not (find c "01bB")) (handler-case (list (read-from-string (concatenate 'string (list c) "b101")) (read-from-string (concatenate 'string (list c) "B011"))) (error (c) c)) '(5 3)) (if (not (find c "cC()12 ")) (handler-case (list (read-from-string (concatenate 'string (list c) "c(1 2)")) (read-from-string (concatenate 'string (list c) "C(2 1)"))) (error (c) c)) '(#c(1 2) #c(2 1))) (if (not (find c "oO0127")) (handler-case (list (read-from-string (concatenate 'string (list c) "o172")) (read-from-string (concatenate 'string (list c) "O7721"))) (error (c) c)) '(#o172 #o7721)) (if (not (find c "pP\"")) (handler-case (list (read-from-string (concatenate 'string (list c) "p\"\"")) (read-from-string (concatenate 'string (list c) "P\"\""))) (error (c) c)) '(#p"" #p"")) (if (not (find c "rR0123")) (handler-case (list (read-from-string (concatenate 'string (list c) "3r210")) (read-from-string (concatenate 'string (list c) "3R1111"))) (error (c) c)) '(#3r210 #3r1111)) ;;; Add #s test here (if (not (find c "xX04dF")) (handler-case (list (read-from-string (concatenate 'string (list c) "x40Fd")) (read-from-string (concatenate 'string (list c) "XFd04"))) (error (c) c)) '(#x40fd #xfd04)) ))) (unless (equalp results '(t c r 1 (#0a1 #0a1) (5 3) (#c(1 2) #c(2 1)) (#o172 #o7721) (#p"" #p"") (#3r210 #3r1111) (#x40fd #xfd04))) (list (list c results))) ))) nil) gcl27-2.7.0/ansi-tests/set.lsp000066400000000000000000000024661454061450500160570ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jun 21 22:35:48 2003 ;;;; Contains: Tests of SET (in-package :cl-test) (deftest set.1 (let ((*var-used-in-set-tests* 'a) (var '*var-used-in-set-tests*)) (declare (special *var-used-in-set-tests*)) (values *var-used-in-set-tests* (set var 'b) *var-used-in-set-tests*)) a b b) (deftest set.2 (let ((*var-used-in-set-tests* 'a) (var '*var-used-in-set-tests*)) (declare (special *var-used-in-set-tests*)) (values (let ((*var-used-in-set-tests* 'c)) (list (set var 'b) *var-used-in-set-tests* (symbol-value var))) *var-used-in-set-tests*)) (b c b) b) (deftest set.error.1 (signals-error (set) program-error) t) (deftest set.error.2 (signals-error (let ((*var-used-in-set-tests* 'a)) (declare (special *var-used-in-set-tests*)) (set '*var-used-in-set-tests*)) program-error) t) (deftest set.error.3 (signals-error (let ((*var-used-in-set-tests* 'a)) (declare (special *var-used-in-set-tests*)) (set '*var-used-in-set-tests* nil nil)) program-error) t) (deftest set.error.4 (signals-error (let ((*var-used-in-set-tests* 'a) (*y* 'b)) (declare (special *var-used-in-set-tests*)) (set '*var-used-in-set-tests* nil '*y* nil)) program-error) t) gcl27-2.7.0/ansi-tests/shadow.lsp000066400000000000000000000170171454061450500165470ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:01:20 1998 ;;;; Contains: Tests of SHADOW (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" :use nil) (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" :use nil) (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" :use nil) (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 :use nil) (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 :use nil) (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 :use nil) (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 :use nil) (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)) ;;; Specialized string tests (deftest shadow.8 (prog1 (handler-case (progn (safely-delete-package :G) (make-package :G :use nil) (let* ((name (make-array '(1) :initial-contents "X" :element-type 'base-char)) (s1 (intern name :G))) (shadow name :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)) (deftest shadow.9 (prog1 (handler-case (progn (safely-delete-package :G) (make-package :G :use nil) (let* ((name (make-array '(3) :initial-contents "XYZ" :fill-pointer 1 :element-type 'character)) (s1 (intern name :G))) (shadow name :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)) (deftest shadow.10 (prog1 (handler-case (progn (safely-delete-package :G) (make-package :G :use nil) (let* ((name (make-array '(1) :initial-contents "X" :adjustable t :element-type 'base-char)) (s1 (intern name :G))) (shadow name :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)) (deftest shadow.error.1 (signals-error (shadow) program-error) t) (deftest shadow.error.2 (signals-error (shadow "X" "CL-USER" nil) program-error) t) gcl27-2.7.0/ansi-tests/shadowing-import.lsp000066400000000000000000000105011454061450500205440ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 29 07:42:18 2004 ;;;; Contains: Tests for SHADOWING-IMPORT (in-package :cl-test) (deftest shadowing-import.1 (let ((name1 "TEST1") (name2 "TEST2")) (safely-delete-package name1) (safely-delete-package name2) (prog1 (let* ((p1 (make-package name1 :use nil)) (p2 (make-package name2)) (s1 (intern "X" p1)) (s2 (intern "X" p2))) (list (eqt s1 s2) (eqt (find-symbol "X" p2) s2) (shadowing-import s1 p2) (equalt (package-shadowing-symbols p2) (list s1)) (eqt (find-symbol "X" p2) s1))) (safely-delete-package name1) (safely-delete-package name2))) (nil t t t t)) (deftest shadowing-import.2 (let ((name1 "TEST1") (name2 "TEST2")) (safely-delete-package name1) (safely-delete-package name2) (prog1 (let* ((p1 (make-package name1 :use nil)) (p2 (make-package name2)) (s1 (intern "X" p1))) (list (find-symbol "X" p2) (shadowing-import s1 p2) (equalt (package-shadowing-symbols p2) (list s1)) (eqt (find-symbol "X" p2) s1))) (safely-delete-package name1) (safely-delete-package name2))) (nil t t t)) (deftest shadowing-import.3 (let ((name1 "TEST1") (name2 "TEST2")) (safely-delete-package name1) (safely-delete-package name2) (prog1 (let* ((p1 (make-package name1 :use nil)) (p2 (make-package name2 :use nil)) (s1 (intern "X" p1)) (s2 (intern "X" p2))) (list (eqt s1 s2) (eqt (find-symbol "X" p2) s2) (let ((*package* p2)) (shadowing-import s1)) (equalt (package-shadowing-symbols p2) (list s1)) (eqt (find-symbol "X" p2) s1))) (safely-delete-package name1) (safely-delete-package name2))) (nil t t t t)) (deftest shadowing-import.4 (let ((name1 "TEST1") (name2 "TEST2") (name3 "TEST3")) (safely-delete-package name1) (safely-delete-package name2) (safely-delete-package name3) (prog1 (let* ((p1 (make-package name1 :use nil)) (p3 (make-package name2 :use nil)) (p2 (make-package name3 :use (list p3))) (s1 (intern "X" p1)) (s2 (intern "X" p3))) (export s2 p3) (list (eqt s1 s2) (eqt (find-symbol "X" p2) s2) (shadowing-import s1 p2) (equalt (package-shadowing-symbols p2) (list s1)) (eqt (find-symbol "X" p2) s1))) (safely-delete-package name1) (safely-delete-package name3) (safely-delete-package name2))) (nil t t t t)) ;;; Specialized sequence tests (defmacro def-shadowing-import-test (test-name name-form) `(deftest ,test-name (let ((name1 ,name-form)) (safely-delete-package name1) (prog1 (let* ((p1 (make-package name1 :use nil))) (list (find-symbol "T" p1) (shadowing-import t name1) (package-shadowing-symbols p1) (find-symbol "T" p1))) (safely-delete-package name1))) (nil t (t) t))) (def-shadowing-import-test shadowing-import.5 (make-array '(5) :initial-contents "TEST1" :element-type 'base-char)) (def-shadowing-import-test shadowing-import.6 (make-array '(7) :initial-contents "TEST1XX" :fill-pointer 7 :element-type 'character)) (def-shadowing-import-test shadowing-import.7 (make-array '(7) :initial-contents "TEST1XX" :fill-pointer 7 :element-type 'base-char)) (def-shadowing-import-test shadowing-import.8 (make-array '(5) :initial-contents "TEST1" :adjustable t :element-type 'base-char)) (def-shadowing-import-test shadowing-import.9 (make-array '(5) :initial-contents "TEST1" :adjustable t :element-type 'character)) (def-shadowing-import-test shadowing-import.10 (let* ((etype 'character) (name2 (make-array '(10) :initial-contents "ABTEST1CDE" :element-type etype))) (make-array '(5) :element-type etype :displaced-to name2 :displaced-index-offset 2))) (def-shadowing-import-test shadowing-import.11 (let* ((etype 'base-char) (name2 (make-array '(10) :initial-contents "ABTEST1CDE" :element-type etype))) (make-array '(5) :element-type etype :displaced-to name2 :displaced-index-offset 2))) ;;; Error tests (deftest shadowing-import.error.1 (signals-error (shadowing-import) program-error) t) (deftest shadowing-import.error.2 (signals-error (shadowing-import nil *package* nil) program-error) t) gcl27-2.7.0/ansi-tests/shared-initialize.lsp000066400000000000000000000436621454061450500206740ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Apr 29 04:09:06 2003 ;;;; Contains: Tests of SHARED-INITIALIZE (in-package :cl-test) (defclass shared-init-class-01 () ((a :initform 'x :initarg :a) (b :initform 'y :initarg :b) (c :initarg :c) d)) (deftest shared-initialize.1.1 (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) (values (map-slot-boundp* obj '(a b c d)) (eqt obj (shared-initialize obj nil :a 1 :b 3 :c 14)) (map-slot-boundp* obj '(a b c d)) (map-slot-value obj '(a b c)))) (nil nil nil nil) t (t t t nil) (1 3 14)) (deftest shared-initialize.1.2 (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) (values (map-slot-boundp* obj '(a b c d)) (eqt obj (shared-initialize obj nil)) (map-slot-boundp* obj '(a b c d)))) (nil nil nil nil) t (nil nil nil nil)) (deftest shared-initialize.1.3 (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) (values (map-slot-boundp* obj '(a b c d)) (eqt obj (shared-initialize obj nil :a 1 :a 2)) (map-slot-boundp* obj '(a b c d)) (slot-value obj 'a))) (nil nil nil nil) t (t nil nil nil) 1) (deftest shared-initialize.1.4 (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) (values (map-slot-boundp* obj '(a b c d)) (eqt obj (shared-initialize obj nil :a 1 :a 2 :allow-other-keys nil)) (map-slot-boundp* obj '(a b c d)) (slot-value obj 'a))) (nil nil nil nil) t (t nil nil nil) 1) (deftest shared-initialize.1.5 (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) (values (map-slot-boundp* obj '(a b c d)) (eqt obj (shared-initialize obj '(a) :a 1)) (map-slot-boundp* obj '(a b c d)) (slot-value obj 'a))) (nil nil nil nil) t (t nil nil nil) 1) (deftest shared-initialize.1.6 (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) (values (map-slot-boundp* obj '(a b c d)) (eqt obj (shared-initialize obj '(a))) (map-slot-boundp* obj '(a b c d)) (slot-value obj 'a))) (nil nil nil nil) t (t nil nil nil) x) (deftest shared-initialize.1.7 (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) (values (map-slot-boundp* obj '(a b c d)) (eqt obj (shared-initialize obj t)) (map-slot-boundp* obj '(a b c d)) (slot-value obj 'a) (slot-value obj 'b))) (nil nil nil nil) t (t t nil nil) x y) (deftest shared-initialize.1.8 (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) (values (map-slot-boundp* obj '(a b c d)) (eqt obj (shared-initialize obj t :b 10 :c 100)) (map-slot-boundp* obj '(a b c d)) (slot-value obj 'a) (slot-value obj 'b) (slot-value obj 'c))) (nil nil nil nil) t (t t t nil) x 10 100) (deftest shared-initialize.1.9 (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) (values (map-slot-boundp* obj '(a b c d)) (eqt obj (shared-initialize obj nil :a 1 :b 10 :c 100)) (eqt obj (shared-initialize obj nil :a 5 :b 37 :c 213)) (map-slot-boundp* obj '(a b c d)) (slot-value obj 'a) (slot-value obj 'b) (slot-value obj 'c))) (nil nil nil nil) t t (t t t nil) 5 37 213) (deftest shared-initialize.1.10 (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) (setf (slot-value obj 'a) 1000) (values (map-slot-boundp* obj '(a b c d)) (eqt obj (shared-initialize obj '(a))) (map-slot-boundp* obj '(a b c d)) (slot-value obj 'a))) (t nil nil nil) t (t nil nil nil) 1000) ;;; Initforms in the lexical environment of the defclass (declaim (special *shared-init-var-02-init* *shared-init-var-02-query*)) (declaim (type function *shared-init-var-02-init* *shared-init-var-02-query*)) (let ((ainit 0) (binit 0)) (flet ((%init (a b) (setf ainit a binit b)) (%query () (list ainit binit))) (setf *shared-init-var-02-init* #'%init *shared-init-var-02-query* #'%query) (defclass shared-init-class-02 () ((a :initform (incf ainit) :initarg :a) (b :initform (incf binit) :initarg :b) (c :initarg :c) (d)) (:default-initargs :c 100)))) (deftest shared-initialize.2.1 (progn (funcall *shared-init-var-02-init* 5 10) (let ((obj (allocate-instance (find-class 'shared-init-class-02)))) (values (funcall *shared-init-var-02-query*) (eqt obj (shared-initialize obj t)) (slot-value obj 'a) (slot-value obj 'b) (map-slot-boundp* obj '(a b c d)) (funcall *shared-init-var-02-query*)))) (5 10) t 6 11 (t t nil nil) (6 11)) (deftest shared-initialize.2.2 (progn (funcall *shared-init-var-02-init* 5 10) (let ((obj (allocate-instance (find-class 'shared-init-class-02)))) (values (funcall *shared-init-var-02-query*) (eqt obj (shared-initialize obj nil)) (map-slot-boundp* obj '(a b c d)) (funcall *shared-init-var-02-query*)))) (5 10) t (nil nil nil nil) (5 10)) (deftest shared-initialize.2.3 (progn (funcall *shared-init-var-02-init* 5 10) (let ((obj (allocate-instance (find-class 'shared-init-class-02)))) (values (funcall *shared-init-var-02-query*) (eqt obj (shared-initialize obj '(a))) (slot-value obj 'a) (map-slot-boundp* obj '(a b c d)) (funcall *shared-init-var-02-query*)))) (5 10) t 6 (t nil nil nil) (6 10)) (deftest shared-initialize.2.4 (progn (funcall *shared-init-var-02-init* 5 10) (let ((obj (allocate-instance (find-class 'shared-init-class-02)))) (values (funcall *shared-init-var-02-query*) (eqt obj (shared-initialize obj '(b))) (slot-value obj 'b) (map-slot-boundp* obj '(a b c d)) (funcall *shared-init-var-02-query*)))) (5 10) t 11 (nil t nil nil) (5 11)) (deftest shared-initialize.2.5 (progn (funcall *shared-init-var-02-init* 5 10) (let ((obj (allocate-instance (find-class 'shared-init-class-02)))) (values (funcall *shared-init-var-02-query*) (eqt obj (shared-initialize obj t :a 34 :b 49)) (map-slot-value obj '(a b)) (map-slot-boundp* obj '(a b c d)) (funcall *shared-init-var-02-query*)))) (5 10) t (34 49) (t t nil nil) (5 10)) (deftest shared-initialize.2.6 (progn (funcall *shared-init-var-02-init* 5 10) (let ((obj (allocate-instance (find-class 'shared-init-class-02)))) (values (funcall *shared-init-var-02-query*) (eqt obj (shared-initialize obj '(a b c d) :a 34 :b 49)) (map-slot-value obj '(a b)) (map-slot-boundp* obj '(a b c d)) (funcall *shared-init-var-02-query*)))) (5 10) t (34 49) (t t nil nil) (5 10)) ;;; Defining new methods on shared-initialize (defstruct shared-init-class-03 a b c) (defmethod shared-initialize ((obj shared-init-class-03) slots-to-init &key (a nil a-p) (b nil b-p) (c nil c-p) &allow-other-keys) (declare (ignore slots-to-init)) ;; (when a-p (setf (slot-value obj 'a) a)) ;; (when b-p (setf (slot-value obj 'b) b)) ;; (when c-p (setf (slot-value obj 'c) c)) (when a-p (setf (shared-init-class-03-a obj) a)) (when b-p (setf (shared-init-class-03-b obj) b)) (when c-p (setf (shared-init-class-03-c obj) c)) obj) (deftest shared-initialize.3.1 (let ((obj (make-shared-init-class-03))) (values (eqt obj (shared-initialize obj nil :a 1 :b 5 :c 19)) (shared-init-class-03-a obj) (shared-init-class-03-b obj) (shared-init-class-03-c obj))) t 1 5 19) ;;; Inheritance (defclass shared-init-class-04a () ((a :initform 4 :initarg :a) (b :initform 8 :initarg :b))) (defclass shared-init-class-04b (shared-init-class-04a) ((c :initform 17 :initarg :c) d) (:default-initargs :a 1)) (deftest shared-initialize.4.1 (let ((obj (allocate-instance (find-class 'shared-init-class-04b)))) (values (eqt obj (shared-initialize obj nil :a 'x)) (map-slot-boundp* obj '(a b c d)) (slot-value obj 'a))) t (t nil nil nil) x) (deftest shared-initialize.4.2 (let ((obj (allocate-instance (find-class 'shared-init-class-04b)))) (values (eqt obj (shared-initialize obj nil)) (map-slot-boundp* obj '(a b c d)))) t (nil nil nil nil)) (deftest shared-initialize.4.3 (let ((obj (allocate-instance (find-class 'shared-init-class-04b)))) (values (eqt obj (shared-initialize obj t)) (map-slot-boundp* obj '(a b c d)) (map-slot-value obj '(a b c)))) t (t t t nil) (4 8 17)) (deftest shared-initialize.4.4 (let ((obj (allocate-instance (find-class 'shared-init-class-04b)))) (values (eqt obj (shared-initialize obj '(a c))) (map-slot-boundp* obj '(a b c d)) (map-slot-value obj '(a c)))) t (t nil t nil) (4 17)) (deftest shared-initialize.4.5 (let ((obj (allocate-instance (find-class 'shared-init-class-04b)))) (values (eqt obj (shared-initialize obj '(a c) :c 81)) (map-slot-boundp* obj '(a b c d)) (map-slot-value obj '(a c)))) t (t nil t nil) (4 81)) (deftest shared-initialize.4.6 (let ((obj (allocate-instance (find-class 'shared-init-class-04b)))) (values (eqt obj (shared-initialize obj '(a c) :a 91)) (map-slot-boundp* obj '(a b c d)) (map-slot-value obj '(a c)))) t (t nil t nil) (91 17)) (deftest shared-initialize.4.7 (let ((obj (allocate-instance (find-class 'shared-init-class-04b)))) (values (eqt obj (shared-initialize obj '(c))) (map-slot-boundp* obj '(a b c d)) (slot-value obj 'c))) t (nil nil t nil) 17) ;;; shared-initialize and class slots (defclass shared-init-class-05 () ((a :initarg :a :allocation :class) (b :initarg :b :initform 'foo :allocation :class))) (deftest shared-initialize.5.1 (let* ((class (find-class 'shared-init-class-05)) (obj (allocate-instance class))) (slot-makunbound obj 'a) (slot-makunbound obj 'b) (values (eqt obj (shared-initialize obj t)) (map-slot-boundp* obj '(a b)) (slot-value obj 'b))) t (nil t) foo) (deftest shared-initialize.5.2 (let* ((class (find-class 'shared-init-class-05)) (obj (allocate-instance class))) (slot-makunbound obj 'a) (slot-makunbound obj 'b) (values (eqt obj (shared-initialize obj '(b))) (map-slot-boundp* obj '(a b)) (slot-value obj 'b))) t (nil t) foo) (deftest shared-initialize.5.3 (let* ((class (find-class 'shared-init-class-05)) (obj (allocate-instance class)) (obj2 (allocate-instance class))) (slot-makunbound obj 'a) (slot-makunbound obj 'b) (values (eqt obj (shared-initialize obj t :a 117)) (map-slot-boundp* obj '(a b)) (map-slot-value obj '(a b)) (map-slot-value obj2 '(a b)))) t (t t) (117 foo) (117 foo)) (deftest shared-initialize.5.4 (let* ((class (find-class 'shared-init-class-05)) (obj (allocate-instance class)) (obj2 (allocate-instance class))) (slot-makunbound obj 'a) (values (setf (slot-value obj 'b) 'bar) (eqt obj (shared-initialize obj t :a 117)) (map-slot-boundp* obj '(a b)) (map-slot-value obj '(a b)) (map-slot-value obj2 '(a b)))) bar t (t t) (117 bar) (117 bar)) ;;; Shared initargs (defclass shared-init-class-06 () ((a :initarg :i1 :initarg :i2 :initform 'x) (b :initarg :i2 :initarg :i3 :initform 'y))) (deftest shared-initialize.6.1 (let* ((class (find-class 'shared-init-class-06)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil)) (map-slot-boundp* obj '(a b)))) (nil nil) t (nil nil)) (deftest shared-initialize.6.2 (let* ((class (find-class 'shared-init-class-06)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj t)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) (nil nil) t (t t) x y) (deftest shared-initialize.6.3 (let* ((class (find-class 'shared-init-class-06)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil :i1 'z)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a))) (nil nil) t (t nil) z) (deftest shared-initialize.6.4 (let* ((class (find-class 'shared-init-class-06)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil :i2 'z)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) (nil nil) t (t t) z z) (deftest shared-initialize.6.5 (let* ((class (find-class 'shared-init-class-06)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil :i1 'w :i2 'z)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) (nil nil) t (t t) w z) (deftest shared-initialize.6.6 (let* ((class (find-class 'shared-init-class-06)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil :i2 'z :i1 'w)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) (nil nil) t (t t) z z) (deftest shared-initialize.6.7 (let* ((class (find-class 'shared-init-class-06)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil :i2 'z :i2 'w)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) (nil nil) t (t t) z z) (deftest shared-initialize.6.8 (let* ((class (find-class 'shared-init-class-06)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil :i2 'z :i2 'w :foo t)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) (nil nil) t (t t) z z) (deftest shared-initialize.6.9 (let* ((class (find-class 'shared-init-class-06)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil :allow-other-keys nil :i2 'z :i2 'w :foo t)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) (nil nil) t (t t) z z) ;;; Before methods fill in slots before the default system method (defclass shared-init-class-07 () ((a :initform 'x) (b :initform 'y))) (defmethod shared-initialize :before ((obj shared-init-class-07) slot-names &rest args) (declare (ignore args slot-names)) (setf (slot-value obj 'a) 'foo) obj) (deftest shared-initialize.7.1 (let* ((class (find-class 'shared-init-class-07)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a))) (nil nil) t (t nil) foo) (deftest shared-initialize.7.2 (let* ((class (find-class 'shared-init-class-07)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj t)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) (nil nil) t (t t) foo y) ;;; :around method tests (defclass shared-init-class-08 () ((a :initform 'x) (b :initform 'y))) (defmethod shared-initialize :around ((obj shared-init-class-08) slot-names &rest args &key only &allow-other-keys) (declare (ignore slot-names args)) (setf (slot-value obj 'a) 'foo) (if only obj (call-next-method))) (deftest shared-initialize.8.1 (let* ((class (find-class 'shared-init-class-08)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a))) (nil nil) t (t nil) foo) (deftest shared-initialize.8.2 (let* ((class (find-class 'shared-init-class-08)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj t)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) (nil nil) t (t t) foo y) (deftest shared-initialize.8.3 (let* ((class (find-class 'shared-init-class-08)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj t :only t)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a))) (nil nil) t (t nil) foo) ;;; (defclass shared-init-class-09 () ((a :allocation :class :initform 'x) (b :initform 'y))) (deftest shared-initialize.9.1 (let* ((class (find-class 'shared-init-class-09)) (obj (allocate-instance class))) (slot-makunbound obj 'a) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj '(b))) (map-slot-boundp* obj '(a b)) (slot-value obj 'b))) (nil nil) t (nil t) y) ;;; Order of evaluation tests (deftest shared-initialize.order.1 (let ((obj (allocate-instance (find-class 'shared-init-class-01))) (i 0) x r y z w q) (values (eqt obj (shared-initialize (progn (setf x (incf i)) obj) (progn (setf r (incf i)) nil) :b (setf y (incf i)) :a (setf z (incf i)) :b (setf w (incf i)) :c (setf q (incf i)))) (map-slot-value obj '(a b c)) i x r y z w q)) t (4 3 6) 6 1 2 3 4 5 6) ;;; Error tests (deftest shared-initialize.error.1 (signals-error (shared-initialize) program-error) t) (deftest shared-initialize.error.2 (signals-error (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) (shared-initialize obj)) program-error) t) (deftest shared-initialize.error.3 (signals-error (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) (shared-initialize obj nil :a)) program-error) t) (deftest shared-initialize.error.4 (signals-error (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) (shared-initialize obj nil '(a b c) nil)) program-error) t) gcl27-2.7.0/ansi-tests/shiftf.lsp000066400000000000000000000030261454061450500165400ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 15:43:44 2003 ;;;; Contains: Tests of SHIFTF (in-package :cl-test) (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 shiftf.1 (let ((x 0)) (values x (shiftf x 1) x)) 0 0 1) (deftest shiftf.2 (let ((x 'a) (y 'b) (z 'c)) (values x y z (shiftf x y z 'd) x y z)) a b c a b c d) (deftest shiftf.3 (let ((x (vector 0 1 2 3))) (values (copy-seq x) (shiftf (aref x (aref x 0)) (aref x (aref x 1)) (aref x (aref x 2)) (aref x (aref x 3)) 'foo) (copy-seq x))) #(0 1 2 3) 0 #(1 2 3 foo)) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest shiftf.4 (macrolet ((%m (z) z)) (let ((x 1) (y 2)) (values (shiftf (expand-in-current-env (%m x)) y 'foo) x y))) 1 2 foo) (deftest shiftf.5 (macrolet ((%m (z) z)) (let ((x 1) (y 2)) (values (shiftf x (expand-in-current-env (%m y)) 'foo) x y))) 1 2 foo) (deftest shiftf.6 (macrolet ((%m (z) z)) (let ((x 1) (y 2)) (values (shiftf x y (expand-in-current-env (%m 'foo))) x y))) 1 2 foo) ;;; Need to add more shiftf tests here gcl27-2.7.0/ansi-tests/signum.lsp000066400000000000000000000043611454061450500165620ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Sep 4 22:29:09 2003 ;;;; Contains: Tests of SIGNUM (in-package :cl-test) (deftest signum.error.1 (signals-error (signum) program-error) t) (deftest signum.error.2 (signals-error (signum 1 1) program-error) t) (deftest signum.error.3 (signals-error (signum 1 nil) program-error) t) (deftest signum.1 (signum 0) 0) (deftest signum.2 (signum 123) 1) (deftest signum.3 (signum -123123) -1) (deftest signum.4 (loop for i in *rationals* for s = (signum i) unless (cond ((zerop i) (eql s 0)) ((plusp i) (eql s 1)) (t (eql s -1))) collect (list i s)) nil) (deftest signum.5 (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) for one = (float 1 x) for y = (float 13122 x) for s1 = (signum x) for s2 = (signum y) for s3 = (signum (- y)) unless (and (eql s1 x) (eql s2 one) (eql s3 (- one))) collect (list x one y s1 s2 s3)) nil) (deftest signum.6 (loop for tp in '(short-float single-float double-float long-float) for z = (coerce 0 tp) for mz = (- z) nconc (loop for x in (list z mz) nconc (loop for y in (list z mz) for c = (complex z mz) for s = (signum c) unless (eql c s) collect (list c s)))) nil) (deftest signum.7 (loop for tp in '(short-float single-float double-float long-float) for z = (coerce 0 tp) for one = (coerce 1 tp) for onem = (coerce -1 tp) for c1 = (complex one z) for c2 = (complex onem z) for c3 = (complex z one) for c4 = (complex z onem) unless (eql c1 (signum c1)) collect (list c1 (signum c1)) unless (eql c2 (signum c2)) collect (list c2 (signum c2)) unless (eql c3 (signum c3)) collect (list c3 (signum c3)) unless (eql c4 (signum c4)) collect (list c4 (signum c4))) nil) (deftest signum.8 (let* ((c (complex 0 1)) (s (signum c))) (or (eqlt c s) (eqlt s #c(0.0 1.0)))) t) (deftest signum.9 (let* ((c (complex 0 -1)) (s (signum c))) (or (eqlt c s) (eqlt s #c(0.0 -1.0)))) t) (deftest signum.10 (let* ((c (complex 3/5 4/5)) (s (signum c))) (or (eqlt c s) (eqlt s (complex (float 3/5) (float 4/5))))) t) (deftest signum.11 (let ((i 0)) (values (signum (the (integer 1 1) (incf i))) i)) 1 1) gcl27-2.7.0/ansi-tests/simple-array-t.lsp000066400000000000000000000126341454061450500201300ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/simple-array.lsp000066400000000000000000000144521454061450500176670ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/simple-base-string.lsp000066400000000000000000000024361454061450500207660ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 29 17:30:40 2004 ;;;; Contains: Tests associated with SIMPLE-BASE-STRING (in-package :cl-test) (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) (deftest simple-base-string.9 :notes (:allow-nil-arrays :nil-vectors-are-strings) (subtypep* '(simple-array nil (*)) 'simple-base-string) nil t) (deftest simple-base-string.10 :notes (:allow-nil-arrays :nil-vectors-are-strings) (typep* (make-array '(0) :element-type nil) 'simple-base-string) nil) (deftest simple-base-string.11 :notes (:allow-nil-arrays :nil-vectors-are-strings) (typep* (make-array '(12) :element-type nil) 'simple-base-string) nil) gcl27-2.7.0/ansi-tests/simple-bit-vector-p.lsp000066400000000000000000000023271454061450500210620ustar00rootroot00000000000000;-*- 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 (check-type-predicate #'simple-bit-vector-p 'simple-bit-vector) nil) (deftest simple-bit-vector-p.error.1 (signals-error (simple-bit-vector-p) program-error) t) (deftest simple-bit-vector-p.error.2 (signals-error (simple-bit-vector-p #* #*) program-error) t) gcl27-2.7.0/ansi-tests/simple-bit-vector.lsp000066400000000000000000000026741454061450500206320ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/simple-string-p.lsp000066400000000000000000000033201454061450500203040ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 29 17:31:24 2004 ;;;; Contains: Tests of SIMPLE-STRING-P (in-package :cl-test) (deftest simple-string-p.1 (check-type-predicate #'simple-string-p 'simple-string) nil) (deftest simple-string-p.2 (notnot-mv (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-mv (simple-string-p (make-array 4 :element-type 'base-char :initial-contents '(#\a #\a #\a #\b)))) t) (deftest simple-string-p.6 (notnot-mv (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) (deftest simple-string-p.8 :notes (:nil-vectors-are-strings) (notnot-mv (simple-string-p (make-array '(0) :element-type nil))) t) (deftest simple-string-p.9 :notes (:nil-vectors-are-strings) (notnot-mv (simple-string-p (make-array '(37) :element-type nil))) t) (deftest simple-string-p.10 (let ((i 0)) (values (notnot (simple-string-p (progn (incf i) ""))) i)) t 1) ;;; Error tests (deftest simple-string-p.error.1 (signals-error (simple-string-p) program-error) t) (deftest simple-string-p.error.2 (signals-error (simple-string-p "" nil) program-error) t) gcl27-2.7.0/ansi-tests/simple-string.lsp000066400000000000000000000034041454061450500200520ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 29 17:27:46 2004 ;;;; Contains: Tests associated with SIMPLE-STRING (in-package :cl-test) (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) (deftest simple-string.6 (subtypep* 'simple-string '(simple-array * (*))) t t) (deftest simple-string.7 (subtypep* 'simple-string '(simple-array * 1)) t t) (deftest simple-string.8 :notes (:nil-vectors-are-strings) (subtypep* 'simple-string '(simple-array character (*))) nil t) (deftest simple-string.9 :notes (:nil-vectors-are-strings) (subtypep* 'simple-string '(simple-array base-char (*))) nil t) (deftest simple-string.10 :notes (:nil-vectors-are-strings) (subtypep* 'simple-string 'simple-base-string) nil t) (deftest simple-string.11 :notes (:nil-vectors-are-strings) (subtypep* '(simple-array nil (*)) 'simple-string) t t) (deftest simple-string.12 :notes (:nil-vectors-are-strings) (typep* (make-array '(0) :element-type nil) 'simple-string) t) (deftest simple-string.13 :notes (:nil-vectors-are-strings) (typep* (make-array '(12) :element-type nil) 'simple-string) t) (deftest simple-string.14 (typep* "abc" '(simple-string)) t) (deftest simple-string.15 (typep* "abc" '(simple-string *)) t) (deftest simple-string.16 (typep* "abc" '(simple-string 3)) t) (deftest simple-string.17 (typep* "abc" '(simple-string 2)) nil) (deftest simple-string.18 (typep* "abc" '(simple-string 4)) nil) gcl27-2.7.0/ansi-tests/simple-vector-p.lsp000066400000000000000000000027221454061450500203050ustar00rootroot00000000000000;-*- 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 (check-type-predicate #'simple-vector-p 'simple-vector) 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 (signals-error (simple-vector-p) program-error) t) (deftest simple-vector-p.error.2 (signals-error (simple-vector-p #(a b) nil) program-error) t) gcl27-2.7.0/ansi-tests/sin.lsp000066400000000000000000000063731454061450500160560ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Feb 9 20:20:46 2004 ;;;; Contains: Tests for SIN (in-package :cl-test) (deftest sin.1 (loop for i from -1000 to 1000 for rlist = (multiple-value-list (sin i)) for y = (car rlist) always (and (null (cdr rlist)) (<= -1 y 1) (or (rationalp y) (typep y 'single-float)))) t) (deftest sin.2 (loop for x = (- (random 2000.0s0) 1000.0s0) for rlist = (multiple-value-list (sin x)) for y = (car rlist) repeat 1000 always (and (null (cdr rlist)) (<= -1 y 1) (typep y 'short-float))) t) (deftest sin.3 (loop for x = (- (random 2000.0f0) 1000.0f0) for rlist = (multiple-value-list (sin x)) for y = (car rlist) repeat 1000 always (and (null (cdr rlist)) (<= -1 y 1) (typep y 'single-float))) t) (deftest sin.4 (loop for x = (- (random 2000.0d0) 1000.0d0) for rlist = (multiple-value-list (sin x)) for y = (car rlist) repeat 1000 always (and (null (cdr rlist)) (<= -1 y 1) (typep y 'double-float))) t) (deftest sin.5 (loop for x = (- (random 2000.0l0) 1000.0l0) for rlist = (multiple-value-list (sin x)) for y = (car rlist) repeat 1000 always (and (null (cdr rlist)) (<= -1 y 1) (typep y 'long-float))) t) (deftest sin.6 (let ((r (sin 0))) (or (eqlt r 0) (eqlt r 0.0))) t) (deftest sin.7 (sin 0.0s0) 0.0s0) (deftest sin.8 (sin 0.0) 0.0) (deftest sin.9 (sin 0.0d0) 0.0d0) (deftest sin.10 (sin 0.0l0) 0.0l0) (deftest sin.11 (loop for i from 1 to 100 unless (approx= (sin i) (sin (coerce i 'single-float))) collect i) nil) (deftest sin.12 (approx= (sin (coerce (/ pi 2) 'single-float)) 1.0) t) (deftest sin.13 (approx= (sin (coerce (/ pi -2) 'single-float)) -1.0) t) (deftest sin.14 (approx= (sin (coerce (/ pi 2) 'short-float)) 1.0s0) t) (deftest sin.15 (approx= (sin (coerce (/ pi -2) 'short-float)) -1.0s0) t) (deftest sin.16 (approx= (sin (coerce (/ pi 2) 'double-float)) 1.0d0) t) (deftest sin.17 (approx= (sin (coerce (/ pi -2) 'double-float)) -1.0d0) t) (deftest sin.18 (approx= (sin (coerce (/ pi 2) 'long-float)) 1.0l0) t) (deftest sin.19 (approx= (sin (coerce (/ pi -2) 'long-float)) -1.0l0) t) (deftest sin.20 (loop for r = (- (random 2000) 1000) for i = (- (random 20) 10) for y = (sin (complex r i)) repeat 1000 always (numberp y)) t) (deftest sin.21 (loop for r = (- (random 2000.0s0) 1000.0s0) for i = (- (random 20.0s0) 10.0s0) for y = (sin (complex r i)) repeat 1000 always (numberp y)) t) (deftest sin.22 (loop for r = (- (random 2000.0f0) 1000.0f0) for i = (- (random 20.0f0) 10.0f0) for y = (sin (complex r i)) repeat 1000 always (numberp y)) t) (deftest sin.23 (loop for r = (- (random 2000.0d0) 1000.0d0) for i = (- (random 20.0d0) 10.0d0) for y = (sin (complex r i)) repeat 1000 always (numberp y)) t) (deftest sin.24 (loop for r = (- (random 2000.0l0) 1000.0l0) for i = (- (random 20.0l0) 10.0l0) for y = (sin (complex r i)) repeat 1000 always (numberp y)) t) ;;; FIXME ;;; More accuracy tests here ;;; Error tests (deftest sin.error.1 (signals-error (sin) program-error) t) (deftest sin.error.2 (signals-error (sin 0.0 0.0) program-error) t) (deftest sin.error.3 (check-type-error #'sin #'numberp) nil) gcl27-2.7.0/ansi-tests/sinh.lsp000066400000000000000000000036111454061450500162160ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Feb 11 06:29:51 2004 ;;;; Contains: Tests for SINH (in-package :cl-test) (deftest sinh.1 (let ((result (sinh 0))) (or (eqlt result 0) (eqlt result 0.0))) t) (deftest sinh.2 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 type) unless (equal (multiple-value-list (sinh zero)) (list zero)) collect type) nil) (deftest sinh.3 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 `(complex ,type)) unless (equal (multiple-value-list (sinh zero)) (list zero)) collect type) nil) (deftest sinh.4 (loop for den = (1+ (random 10000)) for num = (random (* 10 den)) for x = (/ num den) for rlist = (multiple-value-list (sinh x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (numberp y)) collect (list x rlist)) nil) (deftest sinh.5 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x = (- (random (coerce 20 type)) 10) for rlist = (multiple-value-list (sinh x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y type)) collect (list x rlist))) nil) (deftest sinh.6 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x1 = (- (random (coerce 20 type)) 10) for x2 = (- (random (coerce 20 type)) 10) for rlist = (multiple-value-list (sinh (complex x1 x2))) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y `(complex ,type))) collect (list x1 x2 rlist))) nil) ;;; FIXME ;;; Add accuracy tests here ;;; Error tests (deftest sinh.error.1 (signals-error (sinh) program-error) t) (deftest sinh.error.2 (signals-error (sinh 1.0 1.0) program-error) t) (deftest sinh.error.3 (check-type-error #'sinh #'numberp) nil) gcl27-2.7.0/ansi-tests/sleep.lsp000066400000000000000000000020771454061450500163720ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 8 19:53:39 2005 ;;;; Contains: Tests of SLEEP (in-package :cl-test) (deftest sleep.1 (sleep 0) nil) (deftest sleep.2 (sleep 0.0s0) nil) (deftest sleep.3 (sleep 0.0f0) nil) (deftest sleep.4 (sleep 0.0d0) nil) (deftest sleep.5 (sleep 0.0l0) nil) (deftest sleep.6 (sleep 1.0f-8) nil) (deftest sleep.7 (sleep 1/100) nil) (deftest sleep.8 (sleep (/ internal-time-units-per-second)) nil) (deftest sleep.9 (sleep (/ 1000000000000000000000000000000)) nil) (deftest sleep.10 (sleep least-positive-short-float) nil) (deftest sleep.11 (sleep least-positive-single-float) nil) (deftest sleep.12 (sleep least-positive-double-float) nil) (deftest sleep.13 (sleep least-positive-long-float) nil) ;;; Error cases (deftest sleep.error.1 (signals-error (sleep) program-error) t) (deftest sleep.error.2 (signals-error (sleep 100 nil) program-error) t) (deftest sleep.error.3 (check-type-error #'sleep #'(lambda (x) (and (realp x) (>= x 0)))) nil) gcl27-2.7.0/ansi-tests/slot-boundp.lsp000066400000000000000000000040631454061450500175250ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue May 6 05:53:32 2003 ;;;; Contains: Tests of SLOT-BOUNDP (in-package :cl-test) ;;; SLOT-BOUNDP is extensively tested in other files as well (defclass slot-boundp-class-01 () (a (b :initarg :b) (c :initform 'x))) (deftest slot-boundp.1 (let ((obj (make-instance 'slot-boundp-class-01))) (slot-boundp obj 'a)) nil) (deftest slot-boundp.2 (let ((obj (make-instance 'slot-boundp-class-01))) (setf (slot-value obj 'a) nil) (notnot-mv (slot-boundp obj 'a))) t) (deftest slot-boundp.3 (let ((obj (make-instance 'slot-boundp-class-01 :b nil))) (notnot-mv (slot-boundp obj 'b))) t) (deftest slot-boundp.4 (let ((obj (make-instance 'slot-boundp-class-01))) (notnot-mv (slot-boundp obj 'c))) t) (deftest slot-boundp.5 (let ((obj (make-instance 'slot-boundp-class-01))) (slot-makunbound obj 'c) (slot-boundp obj 'c)) nil) ;;; Argument order test(s) (deftest slot-boundp.order.1 (let ((obj (make-instance 'slot-boundp-class-01)) (i 0) x y) (values (slot-boundp (progn (setf x (incf i)) obj) (progn (setf y (incf i)) 'a)) i x y)) nil 2 1 2) ;;; Error tests (deftest slot-boundp.error.1 (signals-error (slot-boundp) program-error) t) (deftest slot-boundp.error.2 (signals-error (let ((obj (make-instance 'slot-boundp-class-01))) (slot-boundp obj)) program-error) t) (deftest slot-boundp.error.3 (signals-error (let ((obj (make-instance 'slot-boundp-class-01))) (slot-boundp obj 'a nil)) program-error) t) (deftest slot-boundp.error.4 (signals-error (let ((obj (make-instance 'slot-boundp-class-01))) (slot-boundp obj 'nonexistent-slot)) error) t) ;;; SLOT-BOUNDP should signal an error on elements of built-in-classes (deftest slot-boundp.error.5 (let ((built-in-class (find-class 'built-in-class))) (loop for e in *mini-universe* for class = (class-of e) when (and (eq (class-of class) built-in-class) (handler-case (progn (slot-boundp e 'foo) t) (error () nil))) collect e)) nil) gcl27-2.7.0/ansi-tests/slot-exists-p.lsp000066400000000000000000000116731454061450500200170ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 10 09:39:01 2003 ;;;; Contains: Tests of SLOT-EXISTS-P (in-package :cl-test) ;;; This function is also tested incidentally in many other files (defclass slot-exists-p-class-01 () (a (b :allocation :class) (c :allocation :instance))) (deftest slot-exists-p.1 (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01)))) (notnot-mv (slot-exists-p obj 'a))) t) (deftest slot-exists-p.2 (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01)))) (notnot-mv (slot-exists-p obj 'b))) t) (deftest slot-exists-p.3 (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01)))) (notnot-mv (slot-exists-p obj 'c))) t) (deftest slot-exists-p.4 (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01)))) (slot-exists-p obj 'd)) nil) (deftest slot-exists-p.5 (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01)))) (slot-exists-p obj (gensym))) nil) (deftest slot-exists-p.6 (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01)))) (slot-exists-p obj nil)) nil) (deftest slot-exists-p.7 (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01)))) (slot-exists-p obj t)) nil) ;;; SLOT-EXISTS-P may be called on any object, not just on standard objects (deftest slot-exists-p.8 (let ((slot-name (gensym))) (check-predicate #'(lambda (x) (not (slot-exists-p x slot-name))))) nil) ;;; With various types (defclass slot-exists-p-class-02 () ((a :type t) (b :type nil) (c :type symbol) (d :type cons) (e :type float) (f :type single-float) (g :type short-float) (h :type double-float) (i :type long-float) (j :type character) (k :type base-char) (l :type rational) (m :type ratio) (n :type integer) (o :type fixnum) (p :type complex) (q :type condition))) (deftest slot-exists-p.9 (let ((obj (allocate-instance (find-class 'slot-exists-p-class-02)))) (map-slot-exists-p* obj '(a b c d e f g h i j k l m n o p q))) (t t t t t t t t t t t t t t t t t)) ;;; Inheritance (defclass slot-exists-p-class-03a () (a b)) (defclass slot-exists-p-class-03b () (a c)) (defclass slot-exists-p-class-03c (slot-exists-p-class-03a slot-exists-p-class-03b) (d e)) (deftest slot-exists-p.10 (let ((obj (allocate-instance (find-class 'slot-exists-p-class-03c)))) (map-slot-exists-p* obj '(a b c d e f g))) (t t t t t nil nil)) ;;; SLOT-EXISTS-P is supposed to work on structure objects and condition objects (defstruct slot-exists-p-struct-01 a b c) (deftest slot-exists-p.11 (let ((obj (make-slot-exists-p-struct-01))) (map-slot-exists-p* obj '(a b c z nil))) (t t t nil nil)) (deftest slot-exists-p.12 (let ((obj (make-slot-exists-p-struct-01 :a 1 :b 2 :c 3))) (map-slot-exists-p* obj '(a b c z nil))) (t t t nil nil)) (defstruct (slot-exists-p-struct-02 (:include slot-exists-p-struct-01)) d e) (deftest slot-exists-p.13 (let ((obj (make-slot-exists-p-struct-02))) (map-slot-exists-p* obj '(a b c d e f z nil))) (t t t t t nil nil nil)) (deftest slot-exists-p.14 (let ((obj (make-slot-exists-p-struct-02 :a 1 :b 3 :e 5))) (map-slot-exists-p* obj '(a b c d e f z nil))) (t t t t t nil nil nil)) ;;; SLOT-EXISTS-P is supposed to work on condition objects, too ;;; (after all, they are objects, and they have slots) (define-condition slot-exists-p-condition-01 () ((a) (b) (c))) (deftest slot-exists-p.15 (let ((obj (make-condition 'slot-exists-p-condition-01))) (map-slot-exists-p* obj (list 'a 'b 'c (gensym)))) (t t t nil)) (define-condition slot-exists-p-condition-02 (slot-exists-p-condition-01) ((a) (d) (e))) (deftest slot-exists-p.16 (let ((obj (make-condition 'slot-exists-p-condition-02))) (map-slot-exists-p* obj (list 'a 'b 'c 'd 'e (gensym)))) (t t t t t nil)) ;;; Order of evaluation tests (deftest slot-exists-p.order.1 (let ((i 0) x y) (values (slot-exists-p (progn (setf x (incf i)) 'a) (progn (setf y (incf i)) (gensym))) i x y)) nil 2 1 2) (deftest slot-exists-p.order.2 (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01))) (i 0) x y) (values (notnot (slot-exists-p (progn (setf x (incf i)) obj) (progn (setf y (incf i)) 'a))) i x y)) t 2 1 2) (deftest slot-exists-p.order.3 (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01))) (i 0) x y) (values (notnot (slot-exists-p (progn (setf x (incf i)) obj) (progn (setf y (incf i)) 'b))) i x y)) t 2 1 2) ;;; Errors tests (deftest slot-exists-p.error.1 (signals-error (slot-exists-p) program-error) t) (deftest slot-exists-p.error.2 (signals-error (slot-exists-p 'a) program-error) t) (deftest slot-exists-p.error.3 (signals-error (slot-exists-p (make-instance 'slot-exists-p-class-01)) program-error) t) (deftest slot-exists-p.error.4 (signals-error (slot-exists-p (make-instance 'slot-exists-p-class-01) 'a nil) program-error) t) gcl27-2.7.0/ansi-tests/slot-makunbound.lsp000066400000000000000000000043731454061450500204050ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 10 14:39:01 2003 ;;;; Contains: Tests for SLOT-MAKUNBOUND (in-package :cl-test) ;;; This function is heavily tested in other files as well (defclass slot-makunbound-class-01 () (a (b :allocation :instance) (c :allocation :class) (d :type fixnum) (e :type t) (f :type cons))) (deftest slot-makunbound.1 (loop for slot-name in '(a b c d e) unless (let ((obj (allocate-instance (find-class 'slot-makunbound-class-01)))) (and (equalt (multiple-value-list (slot-makunbound obj slot-name)) (list obj)) (not (slot-boundp obj slot-name)))) collect slot-name) nil) (deftest slot-makunbound.2 (loop for slot-name in '(a b c d e) for slot-value in '(t t t 10 t '(a)) unless (let ((obj (allocate-instance (find-class 'slot-makunbound-class-01)))) (setf (slot-value obj slot-name) slot-value) (and (equalt (multiple-value-list (slot-makunbound obj slot-name)) (list obj)) (not (slot-boundp obj slot-name)))) collect slot-name) nil) ;;; Order of evaluation test(s) (deftest slot-makunbound.order.1 (let ((obj (make-instance 'slot-makunbound-class-01)) (i 0) x y) (values (eqt (slot-makunbound (progn (setf x (incf i)) obj) (progn (setf y (incf i)) 'a)) obj) i x y)) t 2 1 2) (deftest slot-makunbound.order.2 (let ((obj (make-instance 'slot-makunbound-class-01)) (i 0) x y) (setf (slot-value obj 'a) t) (values (eqt (slot-makunbound (progn (setf x (incf i)) obj) (progn (setf y (incf i)) 'a)) obj) i x y)) t 2 1 2) ;;; Error cases (deftest slot-makunbound.error.1 (signals-error (slot-makunbound) program-error) t) (deftest slot-makunbound.error.2 (signals-error (slot-makunbound (make-instance 'slot-makunbound-class-01)) program-error) t) (deftest slot-makunbound.error.3 (signals-error (slot-makunbound (make-instance 'slot-makunbound-class-01) 'a nil) program-error) t) (deftest slot-makunbound.error.4 (let ((built-in-class (find-class 'built-in-class))) (loop for e in *mini-universe* for class = (class-of e) when (and (eq (class-of class) built-in-class) (handler-case (progn (slot-makunbound e 'foo) t) (error () nil))) collect e)) nil) gcl27-2.7.0/ansi-tests/slot-missing.lsp000066400000000000000000000037601454061450500177120ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jun 15 06:03:58 2003 ;;;; Contains: Tests of SLOT-MISSING (in-package :cl-test) (defparameter *slot-missing-class-01-var* nil) (defclass slot-missing-class-01 () (a b c)) (defmethod slot-missing ((class t) (obj slot-missing-class-01) (slot-name t) (operation t) &optional (new-value nil new-value-p)) (setf *slot-missing-class-01-var* (list slot-name operation new-value (notnot new-value-p)))) (deftest slot-missing.1 (let ((obj (make-instance 'slot-missing-class-01))) (values (slot-value obj 'foo) *slot-missing-class-01-var*)) (foo slot-value nil nil) (foo slot-value nil nil)) (deftest slot-missing.2 (let ((obj (make-instance 'slot-missing-class-01))) (values (setf (slot-value obj 'foo) 'bar) *slot-missing-class-01-var*)) bar (foo setf bar t)) (deftest slot-missing.3 (let ((obj (make-instance 'slot-missing-class-01))) (values (eqt obj (slot-makunbound obj 'xyz)) *slot-missing-class-01-var*)) t (xyz slot-makunbound nil nil)) (deftest slot-missing.4 (let ((obj (make-instance 'slot-missing-class-01))) (values (notnot (slot-boundp obj 'abc)) *slot-missing-class-01-var*)) t (abc slot-boundp nil nil)) (deftest slot-missing.5 (let ((obj (make-instance 'slot-missing-class-01))) (slot-value obj 'd)) (d slot-value nil nil)) (deftest slot-missing.6 (let ((obj (make-instance 'slot-missing-class-01))) (setf (slot-value obj 'd) 'bar)) bar) (deftest slot-missing.7 (let* ((obj (make-instance 'slot-missing-class-01)) (val (slot-makunbound obj 'd))) (if (eq val obj) :good val)) :good) (defmethod slot-missing ((class t) (obj slot-missing-class-01) (slot-name (eql 'not-there)) (operation (eql 'slot-boundp)) &optional new-value) (declare (ignore new-value)) (values nil :ignore-this)) (deftest slot-missing.8 (let* ((obj (make-instance 'slot-missing-class-01))) (slot-boundp obj 'not-there)) nil) gcl27-2.7.0/ansi-tests/slot-unbound.lsp000066400000000000000000000025761454061450500177170ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jun 15 06:57:23 2003 ;;;; Contains: Tests for SLOT-UNBOUND (in-package :cl-test) (defclass slot-unbound-class-01 () ((a :reader sunb-a) (b :accessor sunb-b) (c :writer sunb-c) (e :reader sunb-e) (f :reader sunb-f))) (defmethod slot-unbound ((class t) (obj slot-unbound-class-01) (slot-name t)) (list (class-name class) slot-name)) (deftest slot-unbound.1 (let ((obj (make-instance 'slot-unbound-class-01))) (values (slot-value obj 'a) (slot-value obj 'b) (slot-value obj 'c))) (slot-unbound-class-01 a) (slot-unbound-class-01 b) (slot-unbound-class-01 c)) (deftest slot-unbound.2 (let ((obj (make-instance 'slot-unbound-class-01))) (values (sunb-a obj) (sunb-b obj))) (slot-unbound-class-01 a) (slot-unbound-class-01 b)) (defmethod slot-unbound ((class t) (obj slot-unbound-class-01) (slot-name (eql 'e))) (values)) (defmethod slot-unbound ((class t) (obj slot-unbound-class-01) (slot-name (eql 'f))) (values 1 2 3)) (deftest slot-unbound.3 (slot-value (make-instance 'slot-unbound-class-01) 'e) nil) (deftest slot-unbound.4 (slot-value (make-instance 'slot-unbound-class-01) 'f) 1) (deftest slot-unbound.5 (sunb-e (make-instance 'slot-unbound-class-01)) nil) (deftest slot-unbound.6 (sunb-f (make-instance 'slot-unbound-class-01)) 1) gcl27-2.7.0/ansi-tests/slot-value.lsp000066400000000000000000000073221454061450500173530ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 10 16:16:59 2003 ;;;; Contains: Tests of SLOT-VALUE (in-package :cl-test) ;;; SLOT-VALUE is used extensively elsewhere. (defclass slot-value-class-01 () (a (b :type t) (c :type fixnum) (d :type float) (e :type symbol) (f :type short-float) (g :type single-float) (h :type double-float) (i :type long-float) (j :type rational) (k :type ratio) (l :type cons) (m :type string) (n :type vector) (o :type bit) )) (defparameter *slot-value-test-slot-names* '(a b c d e f g h i j k l m n o)) (defparameter *slot-value-test-slot-values* '(t nil 10 4.0 a 1.0s0 2.0f0 3.0d0 4.0l0 5/4 2/3 (a . b) "abcd" #(1 2 3 4) 1)) (deftest slot-value.1 (let ((obj (make-instance 'slot-value-class-01)) (slot-names *slot-value-test-slot-names*) (slot-values *slot-value-test-slot-values*)) (loop for name in slot-names for val in slot-values unless (and (equal (multiple-value-list (setf (slot-value obj name) val)) (list val)) (equal (multiple-value-list (slot-value obj name)) (list val))) collect name)) nil) (defclass slot-value-class-02 (slot-value-class-01) ((a :allocation :class) (b :allocation :class) (c :allocation :class) (d :allocation :class) (e :allocation :class) (f :allocation :class) (g :allocation :class) (h :allocation :class) (i :allocation :class) (j :allocation :class) (k :allocation :class) (l :allocation :class) (m :allocation :class) (n :allocation :class) (o :allocation :class))) (deftest slot-value.2 (let ((obj (make-instance 'slot-value-class-02)) (slot-names *slot-value-test-slot-names*) (slot-values *slot-value-test-slot-values*)) (loop for name in slot-names for val in slot-values unless (and (equal (multiple-value-list (setf (slot-value obj name) val)) (list val)) (equal (multiple-value-list (slot-value obj name)) (list val))) collect name)) nil) ;;; Order of evaluation test(s) (deftest slot-value.order.1 (let ((obj (make-instance 'slot-value-class-01)) (i 0) x y) (values (setf (slot-value obj 'a) t) (slot-value (progn (setf x (incf i)) obj) (progn (setf y (incf i)) 'a)) i x y)) t t 2 1 2) (deftest slot-value.order.2 (let ((obj (make-instance 'slot-value-class-01)) (i 0) x y) (values (setf (slot-value (progn (setf x (incf i)) obj) (progn (setf y (incf i)) 'b)) t) (slot-value obj 'b) i x y)) t t 2 1 2) ;;; Error tests (deftest slot-value.error.1 (signals-error (slot-value) program-error) t) (deftest slot-value.error.2 (signals-error (slot-value (make-instance 'slot-value-class-01)) program-error) t) (deftest slot-value.error.3 (signals-error (let ((obj (make-instance 'slot-value-class-01))) (setf (slot-value obj 'a) t) (slot-value obj 'a nil)) program-error) t) (deftest slot-value.error.4 (handler-case (progn (slot-value (make-instance 'slot-value-class-01) (gensym)) :bad) (error () :good)) :good) (deftest slot-value.error.5 (let ((built-in-class (find-class 'built-in-class)) (slot-name (gensym))) (check-predicate #'(lambda (e) (let ((class (class-of e))) (or (not (eq (class-of class) built-in-class)) (handler-case (progn (slot-value e slot-name) nil) (error () t))))))) nil) (deftest slot-value.error.6 (let ((built-in-class (find-class 'built-in-class)) (slot-name (gensym))) (check-predicate #'(lambda (e) (let ((class (class-of e))) (or (not (eq (class-of class) built-in-class)) (handler-case (setf (slot-value e slot-name) nil) (error () t))))))) nil) gcl27-2.7.0/ansi-tests/some.lsp000066400000000000000000000170071454061450500162240ustar00rootroot00000000000000;-*- 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) ;;; Other specialized sequences (deftest some.17 (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 2 3 4 5 6) :fill-pointer 4))) (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (notnot (some #'plusp v)))) (nil nil nil nil nil t t t t t)) (deftest some.18 (loop for i from 1 to 40 for type = `(unsigned-byte ,i) unless (let ((v (make-array '(10) :initial-contents (loop for j in '(0 0 0 0 1 2 3 4 5 6) collect (mod j (ash 1 i))) :element-type type :fill-pointer 4))) (equal (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (notnot (some #'plusp v))) '(nil nil nil nil nil t t t t t))) collect i) nil) (deftest some.19 (loop for i from 1 to 40 for type = `(signed-byte ,i) unless (let ((v (make-array '(10) :initial-contents '(0 0 0 0 -1 -1 -1 -1 -1 -1) :element-type type :fill-pointer 4))) (equal (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (notnot (some #'minusp v))) '(nil nil nil nil nil t t t t t))) collect i) nil) (deftest some.20 (let ((v (make-array '(10) :initial-contents "abcd012345" :element-type 'character :fill-pointer 4))) (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (notnot (some #'digit-char-p v)))) (nil nil nil nil nil t t t t t)) (deftest some.21 (let ((v (make-array '(10) :initial-contents "abcd012345" :element-type 'base-char :fill-pointer 4))) (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (notnot (some #'digit-char-p v)))) (nil nil nil nil nil t t t t t)) (deftest some.22 (let ((v (make-array '(5) :initial-contents "abcde" :element-type 'base-char))) (values (some #'digit-char-p v) (setf (aref v 2) #\0) (notnot (some #'digit-char-p v)))) nil #\0 t) (deftest some.23 (loop for type in '(short-float single-float double-float long-float) for v = (make-array '(9) :element-type type :initial-contents (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6 0 8 3))) unless (some #'zerop v) collect (list type v)) nil) (deftest some.24 (loop for type in '(short-float single-float double-float long-float) for v = (make-array '(9) :element-type type :fill-pointer 6 :initial-contents (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6 0 8 3))) when (some #'zerop v) collect (list type v)) nil) (deftest some.25 (loop for type in '(short-float single-float double-float long-float) for ctype = `(complex ,type) for v = (make-array '(6) :element-type ctype :initial-contents (mapcar #'(lambda (x) (complex x (coerce x type))) '(1 2 3 4 5 6))) when (some (complement #'complexp) v) collect (list type v)) nil) ;;; Displaced vectors (deftest some.26 (let* ((v1 (make-array '(10) :initial-contents '(1 3 2 4 6 8 5 7 9 1))) (v2 (make-array '(4) :displaced-to v1 :displaced-index-offset 2))) (values (notnot (some #'oddp v1)) (some #'oddp v2))) t nil) (deftest some.27 (loop for i from 1 to 40 for type = `(unsigned-byte ,i) unless (let* ((v1 (make-array '(10) :initial-contents '(1 1 0 0 0 0 1 1 1 1) :element-type type)) (v2 (make-array '(4) :displaced-to v1 :displaced-index-offset 2 :element-type type))) (and (some 'oddp v1)) (not (some #'oddp v2))) collect i) nil) (deftest some.28 (loop for i from 1 to 40 for type = `(signed-byte ,i) unless (let* ((v1 (make-array '(10) :initial-contents '(-1 -1 0 0 0 0 -1 -1 -1 -1) :element-type type)) (v2 (make-array '(4) :displaced-to v1 :displaced-index-offset 2 :element-type type))) (and (some 'oddp v1) (not (some #'oddp v2)))) collect i) nil) (deftest some.29 (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'character))) (loop for i from 0 to 6 for s2 = (make-array '(2) :element-type 'character :displaced-to s1 :displaced-index-offset i) collect (notnot (some 'digit-char-p s2)))) (t t nil nil t t t)) (deftest some.30 (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'base-char))) (loop for i from 0 to 6 for s2 = (make-array '(2) :element-type 'base-char :displaced-to s1 :displaced-index-offset i) collect (notnot (some 'digit-char-p s2)))) (t t nil nil t t t)) (deftest some.31 (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) :adjustable t))) (values (some #'minusp v) (progn (adjust-array v '(11) :initial-element -1) (notnot (some #'minusp v))))) nil t) (deftest some.32 (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) :fill-pointer 10 :adjustable t))) (values (some #'minusp v) (progn (adjust-array v '(11) :initial-element -1) (some #'minusp v)))) nil 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 (check-type-error #'(lambda (x) (some x '(a b c))) (typef '(or symbol function))) nil) (deftest some.error.4 (check-type-error #'(lambda (x) (some #'null x)) #'sequencep) nil) (deftest some.error.7 (check-type-error #'(lambda (x) (some #'eql () x)) #'sequencep) nil) (deftest some.error.8 (signals-error (some) program-error) t) (deftest some.error.9 (signals-error (some #'null) program-error) t) (deftest some.error.10 (signals-error (locally (some 1 '(a b c)) t) type-error) t) (deftest some.error.11 (signals-error (some #'cons '(a b c)) program-error) t) (deftest some.error.12 (signals-error (some #'car '(a b c)) type-error) t) (deftest some.error.13 (signals-error (some #'cons '(a b c) '(b c d) '(c d e)) program-error) t) (deftest some.error.14 (signals-error (some #'null '(a b . c)) type-error) t) gcl27-2.7.0/ansi-tests/sort-aux.lsp000066400000000000000000000022231454061450500170350ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jul 17 06:42:27 2003 ;;;; Contains: Routines for testing SORT, NSORT (in-package :cl-test) (defun my-numeric-sort (list) "Sort (nondestructively) a list of reals." (if (null (cdr list)) list (let* ((len2 (ash (length list) -1)) (l1 (my-numeric-sort (subseq list 0 len2))) (l2 (my-numeric-sort (subseq list len2)))) (my-numeric-merge l1 l2)))) (defun my-numeric-merge (l1 l2) (cond ((null l1) l2) ((null l2) l1) ((<= (car l1) (car l2)) (cons (car l1) (my-numeric-merge (cdr l1) l2))) (t (cons (car l2) (my-numeric-merge l1 (cdr l2)))))) (defun generate-random-sort-test (n m) (loop for i below n collect (random m))) (defun random-sort-test (n m reps) (loop for i below reps for list = (generate-random-sort-test (random n) m) unless (equal (my-numeric-sort list) (sort (copy-seq list) #'<)) collect list)) (defun random-stable-sort-test (n m reps) (loop for i below reps for list = (generate-random-sort-test (random n) m) unless (equal (my-numeric-sort list) (stable-sort (copy-seq list) #'<)) collect list)) gcl27-2.7.0/ansi-tests/sort.lsp000066400000000000000000000136221454061450500162470ustar00rootroot00000000000000;-*- 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)) ;;; ;;; Confirm that sort only permutes the sequence, even when given ;;; a comparison function that does not define a total order. ;;; (deftest sort-list.4 (loop repeat 100 always (let ((a (list 1 2 3 4 5 6 7 8 9 0)) (cmp (make-array '(10 10)))) (loop for i from 0 to 9 do (loop for j from 0 to 9 do (setf (aref cmp i j) (zerop (logand (random 1024) 512))))) (setq a (sort a #'(lambda (i j) (aref cmp i j)))) (and (eqlt (length a) 10) (equalt (sort a #'<) '(0 1 2 3 4 5 6 7 8 9))))) t) (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-vector.5 (loop repeat 100 always (let ((a (vector 1 2 3 4 5 6 7 8 9 0)) (cmp (make-array '(10 10)))) (loop for i from 0 to 9 do (loop for j from 0 to 9 do (setf (aref cmp i j) (zerop (logand (random 1024) 512))))) (setq a (sort a #'(lambda (i j) (aref cmp i j)))) (and (eqlt (length a) 10) (equalpt (sort a #'<) #(0 1 2 3 4 5 6 7 8 9))))) t) (deftest sort-vector.6 (do-special-integer-vectors (v #(1 4 7 3 2 6 5) nil) (let ((sv (sort v #'<))) (assert (equalp sv #(1 2 3 4 5 6 7))))) nil) (deftest sort-vector.7 (do-special-integer-vectors (v #(0 1 1 0 1 1 0 1 0) nil) (let ((sv (sort v #'<))) (assert (equalp sv #(0 0 0 0 1 1 1 1 1))))) nil) (deftest sort-vector.8 (do-special-integer-vectors (v #(0 -1 -1 0 -1 -1 0 -1 0) nil) (let ((sv (sort v #'>))) (assert (equalp sv #(0 0 0 0 -1 -1 -1 -1 -1))))) nil) (deftest sort-vector.9 (let* ((ivals '(1 4 7 3 2 6 5)) (sivals '(1 2 3 4 5 6 7)) (len (length ivals))) (loop for etype in '(short-float single-float double-float long-float rational) for vals = (loop for i in ivals collect (coerce i etype)) for svals = (loop for i in sivals collect (coerce i etype)) for vec = (make-array len :element-type etype :initial-contents vals) for svec = (sort vec #'<) unless (and (eql (length svec) len) (every #'eql svals svec)) collect (list etype vals svec))) nil) (deftest sort-vector.10 (let* ((ivals '(1 4 7 3 2 6 5)) (sivals '(1 2 3 4 5 6 7)) (len (length ivals))) (loop for cetype in '(short-float single-float double-float long-float rational) for etype = `(complex ,cetype) for vals = (loop for i in ivals collect (complex (coerce i cetype) (coerce (- i) cetype))) for svals = (loop for i in sivals collect (complex (coerce i cetype) (coerce (- i) cetype))) for vec = (make-array len :element-type etype :initial-contents vals) for svec = (sort vec #'(lambda (x y) (< (abs x) (abs y)))) unless (and (eql (length svec) len) (every #'eql svals svec)) collect (list etype vals svec))) nil) ;;; Bit vectors (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") (deftest sort-string.4 (do-special-strings (s "aebdc" nil) (let ((s2 (sort s #'char<))) (assert (eq s s2)) (assert (string= s2 "abcde")))) nil) ;;; 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 (signals-error (sort) program-error) t) (deftest sort.error.2 (signals-error (sort nil) program-error) t) (deftest sort.error.3 (signals-error (sort nil #'< :key) program-error) t) (deftest sort.error.4 (signals-error (sort nil #'< 'bad t) program-error) t) (deftest sort.error.5 (signals-error (sort nil #'< 'bad t :allow-other-keys nil) program-error) t) (deftest sort.error.6 (signals-error (sort nil #'< 1 2) program-error) t) (deftest sort.error.7 (signals-error (sort (list 1 2 3 4) #'identity) program-error) t) (deftest sort.error.8 (signals-error (sort (list 1 2 3 4) #'< :key #'cons) program-error) t) (deftest sort.error.9 (signals-error (sort (list 1 2 3 4) #'< :key #'car) type-error) t) (deftest sort.error.10 (signals-error (sort (list 1 2 3 4) #'elt) type-error) t) (deftest sort.error.11 (check-type-error #'(lambda (x) (sort x #'<)) #'sequencep) nil) gcl27-2.7.0/ansi-tests/special-operator-p.lsp000066400000000000000000000030071454061450500207620ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jun 14 05:51:41 2003 ;;;; Contains: Tests fo SPECIAL-OPERATOR-P (in-package :cl-test) ;;; 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 (check-type-error #'special-operator-p #'symbolp) nil) (deftest special-operator-p.error.2 (signals-error (special-operator-p) program-error) t) (deftest special-operator-p.error.3 (signals-error (special-operator-p 'cons 'cons) program-error) t) gcl27-2.7.0/ansi-tests/special.lsp000066400000000000000000000013111454061450500166700ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 21 12:51:59 2005 ;;;; Contains: Tests of the declaration SPECIAL (in-package :cl-test) ;;; Many tests for this declaration are in the tests ;;; for specific binding forms. (deftest special.1 (let ((f 1)) (declare (special f)) (flet ((f () :good)) (flet ((g () (f))) (flet ((f () :bad)) (g))))) :good) (deftest special.2 (let ((x 'a)) (declare (special x)) (let ((x 'b)) (values x (locally (declare (special x)) x) x))) b a b) (deftest special.3 (flet ((%f () (declare (special x10)) x10)) (let ((x10 'a)) (declare (special x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)) (%f))) a) gcl27-2.7.0/ansi-tests/sqrt.lsp000066400000000000000000000103551454061450500162510ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 6 10:54:17 2003 ;;;; Contains: Tests of SQRT (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (deftest sqrt.error.1 (signals-error (sqrt) program-error) t) (deftest sqrt.error.2 (signals-error (sqrt 0 nil) program-error) t) (deftest sqrt.error.3 (check-type-error #'sqrt #'numberp) nil) (deftest sqrt.1 (let ((s (sqrt 0))) (and (realp s) (=t s 0))) t) (deftest sqrt.2 (let ((s (sqrt 1))) (and (realp s) (=t s 1))) t) (deftest sqrt.3 (loop for x in '(0.0s0 1.0s0 0.0f0 1.0f0 0.0d0 1.0d0 0.0l0 1.0l0) for s = (sqrt x) unless (eql s x) collect (list x s)) nil) (deftest sqrt.4 (loop for x in '(0.0s0 1.0s0 0.0f0 1.0f0 0.0d0 1.0d0 0.0l0 1.0l0) for c = (complex x 0) for s = (sqrt c) unless (eql s c) collect (list x c s)) nil) (deftest sqrt.5 (loop for x in '(-1.0s0 -1.0f0 -1.0d0 -1.0l0) for s = (sqrt x) unless (eql s (complex 0 (- x))) collect (list x s)) nil) ;;; (deftest sqrt.6 ;;; (let ((result (sqrt (ash 1 10000)))) ;;; (if (integerp result) ;;; (=t result (ash 1 5000)) ;;; (=t result (float (ash 1 5000) result)))) ;;; t) (deftest sqrt.7 (let ((result (sqrt -1))) (or (eqlt result #c(0 1)) (eqlt result #c(0.0 1.0)))) t) (deftest sqrt.8 (loop for x in *floats* for s = (sqrt x) unless (cond ((zerop x) (=t x 0)) ((plusp x) (and (eqlt (float s x) s) (eqlt (float x s) x))) (t (complexp s))) collect (list x s)) nil) (deftest sqrt.9 (let ((upper (rational most-positive-double-float)) (lower (rational most-negative-double-float))) (loop for x = (random-fixnum) repeat 1000 unless (or (< x lower) (> x upper) (let ((s (sqrt x))) (or (and (rationalp s) (>= s 0) (eql (* s s) x)) (and (floatp s) (>= x 0)) (and (complexp s) (zerop (realpart s)) (> (imagpart s) 0) (< x 0))))) collect (list x (sqrt x)))) nil) (deftest sqrt.10 (loop for x from 1 to 1000 for x2 = (* x x) for s = (sqrt x2) unless (if (rationalp s) (eql x s) (and (typep s 'single-float) (= x s))) collect (list x s)) nil) (deftest sqrt.11 (loop for x from 1 to 1000 for x2 = (* x x) for s = (sqrt (- x2)) unless (and (complexp s) (zerop (realpart s)) (let ((i (imagpart s))) (if (rationalp i) (eql i x) (= i x)))) collect (list x s)) nil) ;;; Tests of the branch cut (deftest sqrt.12 (loop for xr = (random-fixnum) for xi = (random-fixnum) for c = (complex xr xi) for s = (sqrt c) repeat 1000 unless (or (> (realpart s) 0) (and (= (realpart s) 0) (>= (imagpart s) 0))) collect (list c s)) nil) (deftest sqrt.13 (loop for xr = (random-from-interval 1.0f6 -1.0f6) for xi = (random-from-interval 1.0f6 -1.0f6) for c = (complex xr xi) for s = (sqrt c) repeat 1000 unless (or (> (realpart s) 0) (and (= (realpart s) 0) (>= (imagpart s) 0))) collect (list c s)) nil) (deftest sqrt.14 (loop for xr = (random-from-interval 1.0s3 -1.0s3) for xi = (random-from-interval 1.0s3 -1.0s3) for c = (complex xr xi) for s = (sqrt c) repeat 1000 unless (or (> (realpart s) 0) (and (= (realpart s) 0) (>= (imagpart s) 0))) collect (list c s)) nil) (deftest sqrt.15 (loop for xr = (random-from-interval 1.0d7 -1.0d7) for xi = (random-from-interval 1.0d7 -1.0d7) for c = (complex xr xi) for s = (sqrt c) repeat 1000 unless (or (> (realpart s) 0) (and (= (realpart s) 0) (>= (imagpart s) 0))) collect (list c s)) nil) (deftest sqrt.16 (loop for xr = (random-from-interval 1.0l9 -1.0l9) for xi = (random-from-interval 1.0l9 -1.0l9) for c = (complex xr xi) for s = (sqrt c) repeat 1000 unless (or (> (realpart s) 0) (and (= (realpart s) 0) (>= (imagpart s) 0))) collect (list c s)) nil) (deftest sqrt.17 (let ((b1 (find-largest-exactly-floatable-integer most-positive-fixnum))) (loop for i = (random-from-interval (* b1 b1) 0) repeat 1000 unless (>= (sqrt i) (isqrt i)) collect i)) nil) (deftest sqrt.18 (loop for x = (random-from-interval 1.0f6 0.0f0) repeat 1000 unless (>= (sqrt x) (isqrt (floor x))) collect x) nil) (deftest sqrt.19 (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) for s = (sqrt x) unless (= s x) collect (list x s)) nil) gcl27-2.7.0/ansi-tests/stable-sort.lsp000066400000000000000000000136071454061450500175220ustar00rootroot00000000000000;-*- 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)) ;;; FIXME Add random test similar to sort.5 here (deftest stable-sort-vector.6 (do-special-integer-vectors (v #(1 4 7 3 2 6 5) nil) (let ((sv (stable-sort v #'<))) (assert (equalp sv #(1 2 3 4 5 6 7))))) nil) (deftest stable-sort-vector.7 (do-special-integer-vectors (v #(0 1 1 0 1 1 0 1 0) nil) (let ((sv (stable-sort v #'<))) (assert (equalp sv #(0 0 0 0 1 1 1 1 1))))) nil) (deftest stable-sort-vector.8 (do-special-integer-vectors (v #(0 -1 -1 0 -1 -1 0 -1 0) nil) (let ((sv (stable-sort v #'>))) (assert (equalp sv #(0 0 0 0 -1 -1 -1 -1 -1))))) nil) (deftest stable-sort-vector.9 (let* ((ivals '(1 4 7 3 2 6 5)) (sivals '(1 2 3 4 5 6 7)) (len (length ivals))) (loop for etype in '(short-float single-float double-float long-float rational) for vals = (loop for i in ivals collect (coerce i etype)) for svals = (loop for i in sivals collect (coerce i etype)) for vec = (make-array len :element-type etype :initial-contents vals) for svec = (stable-sort vec #'<) unless (and (eql (length svec) len) (every #'eql svals svec)) collect (list etype vals svec))) nil) (deftest stable-sort-vector.10 (let* ((ivals '(1 4 7 3 2 6 5)) (sivals '(1 2 3 4 5 6 7)) (len (length ivals))) (loop for cetype in '(short-float single-float double-float long-float rational) for etype = `(complex ,cetype) for vals = (loop for i in ivals collect (complex (coerce i cetype) (coerce (- i) cetype))) for svals = (loop for i in sivals collect (complex (coerce i cetype) (coerce (- i) cetype))) for vec = (make-array len :element-type etype :initial-contents vals) for svec = (stable-sort vec #'(lambda (x y) (< (abs x) (abs y)))) unless (and (eql (length svec) len) (every #'eql svals svec)) collect (list etype vals svec))) nil) ;;; Bit vectors (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") (deftest stable-sort-string.4 (do-special-strings (s "aebdc" nil) (let ((s2 (stable-sort s #'char<))) (assert (eq s s2)) (assert (string= s2 "abcde")))) nil) ;;; 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 (signals-error (stable-sort) program-error) t) (deftest stable-sort.error.2 (signals-error (stable-sort nil) program-error) t) (deftest stable-sort.error.3 (signals-error (stable-sort nil #'< :key) program-error) t) (deftest stable-sort.error.4 (signals-error (stable-sort nil #'< 'bad t) program-error) t) (deftest stable-sort.error.5 (signals-error (stable-sort nil #'< 'bad t :allow-other-keys nil) program-error) t) (deftest stable-sort.error.6 (signals-error (stable-sort nil #'< 1 2) program-error) t) (deftest stable-sort.error.7 (signals-error (stable-sort (list 1 2 3 4) #'identity) program-error) t) (deftest stable-sort.error.8 (signals-error (stable-sort (list 1 2 3 4) #'< :key #'cons) program-error) t) (deftest stable-sort.error.9 (signals-error (stable-sort (list 1 2 3 4) #'< :key #'car) type-error) t) (deftest stable-sort.error.10 (signals-error (stable-sort (list 1 2 3 4) #'elt) type-error) t) (deftest stable-sort.error.11 (check-type-error #'(lambda (x) (stable-sort x #'<)) #'sequencep) nil) gcl27-2.7.0/ansi-tests/standard-generic-function.lsp000066400000000000000000000015401454061450500223110ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue May 20 06:47:20 2003 ;;;; Contains: Additional tests for class STANDARD-GENERIC-FUNCTION (in-package :cl-test) ;;; Most tests of this are elsewhere (unless (typep #'cons 'generic-function) (deftest standard-generic-function.1 (progn (eval '(defgeneric sgf-cpl-gf.1 (x) (:method ((x generic-function)) 1) (:method ((x function)) 2) (:method ((x t)) 3))) (values (sgf-cpl-gf.1 #'make-instance) (sgf-cpl-gf.1 #'cons) (sgf-cpl-gf.1 'a))) 1 2 3) (deftest standard-generic-function.2 (progn (eval '(defgeneric sgf-cpl-gf.2 (x) (:method ((x standard-generic-function)) 1) (:method ((x function)) 2) (:method ((x t)) 3))) (values (sgf-cpl-gf.2 #'make-instance) (sgf-cpl-gf.2 #'cons) (sgf-cpl-gf.2 'a))) 1 2 3) ) gcl27-2.7.0/ansi-tests/store-value.lsp000066400000000000000000000023741454061450500175300ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 23 09:10:22 2003 ;;;; Contains: Tests for STORE-VALUE restart and function (in-package :cl-test) (deftest store-value.1 (restart-case (progn (store-value 10) 'bad) (store-value (x) (list x 'good))) (10 good)) (deftest store-value.2 (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 (list (first (compute-restarts))) (store-value 17 c2)) (store-value (x) (list x 'bad)) (store-value (x) (list x 'good)))) (17 good)) (deftest store-value.3 (restart-case (progn (store-value 11 nil) 'bad) (store-value (x) (list x 'good))) (11 good)) (deftest store-value.4 (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 (list (first (compute-restarts))) (store-value 18 nil)) (store-value (x) (list x 'good)) (store-value (x) (list x 'bad)))) (18 good)) (deftest store-value.5 (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (with-condition-restarts c1 (compute-restarts) ;; All conditions are now associated with c1 (store-value 21 c2))) nil) gcl27-2.7.0/ansi-tests/stream-element-type.lsp000066400000000000000000000052551454061450500211640ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 13 20:09:50 2004 ;;;; Contains: Tests for STREAM-ELEMENT-TYPE (in-package :cl-test) (deftest stream-element-type.1 (loop for s in (list *debug-io* *error-output* *query-io* *standard-input* *standard-output* *trace-output* *terminal-io*) for results = (multiple-value-list (stream-element-type s)) unless (and (eql (length results) 1) (car results)) collect s) nil) (deftest stream-element-type.2 (let ((pn "foo.txt")) (loop for i from 1 to 100 for etype = `(unsigned-byte ,i) for s = (progn (delete-all-versions pn) (open pn :direction :output :element-type etype)) unless (multiple-value-bind (sub good) (subtypep etype (stream-element-type s)) (close s) (or sub (not good))) collect i)) nil) (deftest stream-element-type.3 (let ((pn "foo.txt")) (loop for i from 1 to 100 for etype = `(signed-byte ,i) for s = (progn (delete-all-versions pn) (open pn :direction :output :element-type etype)) unless (multiple-value-bind (sub good) (subtypep etype (stream-element-type s)) (close s) (or sub (not good))) collect i)) nil) (deftest stream-element-type.4 (let ((pn "foo.txt")) (loop for i from 1 to 100 for etype = `(integer 0 ,i) for s = (progn (delete-all-versions pn) (open pn :direction :output :element-type etype)) unless (multiple-value-bind (sub good) (subtypep etype (stream-element-type s)) (close s) (or sub (not good))) collect i)) nil) (deftest stream-element-type.5 :notes (:assume-no-simple-streams) (let ((pn "foo.txt")) (delete-all-versions pn) (let ((s (open pn :direction :output))) (let ((etype (stream-element-type s))) (unwind-protect (equalt (multiple-value-list (subtypep* 'character etype)) '(nil t)) (close s))))) nil) (deftest stream-element-type.6 :notes (:assume-no-simple-streams) (let ((pn "foo.txt")) (delete-all-versions pn) (let ((s (open pn :direction :output :element-type :default))) (let ((etype (stream-element-type s))) (unwind-protect (multiple-value-bind (sub1 good1) (subtypep* etype 'integer) (multiple-value-bind (sub2 good2) (subtypep* etype 'character) (or (not good1) (not good2) sub1 sub2))) (close s))))) t) (deftest stream-element-type.error.1 (signals-error (stream-element-type) program-error) t) (deftest stream-element-type.error.2 (signals-error (stream-element-type *standard-input* nil) program-error) t) (deftest stream-element-type.error.3 (check-type-error #'stream-element-type #'streamp) nil) gcl27-2.7.0/ansi-tests/stream-error-stream.lsp000066400000000000000000000012151454061450500211660ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 14 20:51:33 2004 ;;;; Contains: Tests of STREAM-ERROR-STREAM (in-package :cl-test) (deftest stream-error-stream.1 (with-input-from-string (s "") (handler-case (read-char s) (stream-error (c) (eqlt (stream-error-stream c) s)))) t) ;;; Error tests (deftest stream-error-stream.error.1 (signals-error (stream-error-stream) program-error) t) (deftest stream-error-stream.error.2 (signals-error (with-input-from-string (s "") (handler-case (read-char s) (stream-error (c) (stream-error-stream c nil)))) program-error) t) gcl27-2.7.0/ansi-tests/stream-external-format.lsp000066400000000000000000000010641454061450500216560ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 27 20:53:21 2004 ;;;; Contains: Tests of STREAM-EXTERNAL-FORMAT (in-package :cl-test) ;;; This is tested in open.lsp ;;; Error tests (deftest stream-external-format.error.1 (signals-error (stream-external-format) program-error) t) (deftest stream-external-format.error.2 (signals-error (let ((pn #p"tmp.dat")) (delete-all-versions pn) (with-open-file (s pn :direction :output :if-exists :supersede) (stream-external-format s nil))) program-error) t) gcl27-2.7.0/ansi-tests/streamp.lsp000066400000000000000000000017011454061450500167260ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 17 17:12:38 2004 ;;;; Contains: Tests for STREAMP (in-package :cl-test) (deftest streamp.1 (loop for s in (list *debug-io* *error-output* *query-io* *standard-input* *standard-output* *trace-output* *terminal-io*) unless (equal (multiple-value-list (notnot-mv (streamp s))) '(t)) collect s) nil) (deftest streamp.2 (check-type-predicate #'streamp 'stream) nil) (deftest streamp.3 (let ((s (open "foo.txt" :direction :output :if-exists :supersede))) (close s) (notnot-mv (streamp s))) t) (deftest streamp.4 (let ((s (open "foo.txt" :direction :output :if-exists :supersede))) (unwind-protect (notnot-mv (streamp s)) (close s))) t) ;;; Error tests (deftest streamp.error.1 (signals-error (streamp) program-error) t) (deftest streamp.error.2 (signals-error (streamp *standard-input* nil) program-error) t) gcl27-2.7.0/ansi-tests/string-aux.lsp000066400000000000000000000111721454061450500173570ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 4 06:51:32 2002 ;;;; Contains: Auxiliary functions for string testing (in-package :cl-test) (eval-when (:compile-toplevel :load-toplevel :execute) (compile-and-load "random-aux.lsp")) (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 (my-aref string1 i1)) (c2 (my-aref 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)) ;; Maximum 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)))) (s1 (make-random-string len1)) (s2 (make-random-string len2)) ;; Actual lengths of the strings (len1 (length s1)) (len2 (length s2)) ;; 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)) ) #| (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 (and (coin) (equal (array-element-type s1) (array-element-type s2))) (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 "Strings: ~s ~s - Args = ~S~%" s1 s2 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 string-all-the-same (s) (let ((len (length s))) (or (= len 0) (let ((c (my-aref s 0))) (loop for i below len for d = (my-aref s i) always (eql c d)))))) gcl27-2.7.0/ansi-tests/string-capitalize.lsp000066400000000000000000000105031454061450500207040ustar00rootroot00000000000000;-*- 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.11 :notes (:nil-vectors-are-strings) (string-capitalize (make-array '(0) :element-type nil)) "") (deftest string-capitalize.12 (loop for type in '(standard-char base-char character) for s = (make-array '(10) :element-type type :fill-pointer 5 :initial-contents "aB0cDefGHi") collect (list s (string-capitalize s))) (("aB0cD" "Ab0cd") ("aB0cD" "Ab0cd") ("aB0cD" "Ab0cd"))) (deftest string-capitalize.13 (loop for type in '(standard-char base-char character) for s0 = (make-array '(10) :element-type type :initial-contents "zZaB0cDefG") for s = (make-array '(5) :element-type type :displaced-to s0 :displaced-index-offset 2) collect (list s (string-capitalize s))) (("aB0cD" "Ab0cd") ("aB0cD" "Ab0cd") ("aB0cD" "Ab0cd"))) (deftest string-capitalize.14 (loop for type in '(standard-char base-char character) for s = (make-array '(5) :element-type type :adjustable t :initial-contents "aB0cD") collect (list s (string-capitalize s))) (("aB0cD" "Ab0cd") ("aB0cD" "Ab0cd") ("aB0cD" "Ab0cd"))) ;;; Order of evaluation tests (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) (def-fold-test string-capitalize.fold.1 (string-capitalize "ABCDE")) ;;; Error cases (deftest string-capitalize.error.1 (signals-error (string-capitalize) program-error) t) (deftest string-capitalize.error.2 (signals-error (string-capitalize (copy-seq "abc") :bad t) program-error) t) (deftest string-capitalize.error.3 (signals-error (string-capitalize (copy-seq "abc") :start) program-error) t) (deftest string-capitalize.error.4 (signals-error (string-capitalize (copy-seq "abc") :bad t :allow-other-keys nil) program-error) t) (deftest string-capitalize.error.5 (signals-error (string-capitalize (copy-seq "abc") :end) program-error) t) (deftest string-capitalize.error.6 (signals-error (string-capitalize (copy-seq "abc") 1 2) program-error) t) gcl27-2.7.0/ansi-tests/string-comparisons.lsp000066400000000000000000000647771454061450500211420ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 4 06:32:41 2002 ;;;; Contains: Tests of string comparison functions (in-package :cl-test) (compile-and-load "string-aux.lsp") (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)) ;;; Keyword argument processing (deftest string-comparison.allow-other-keys.1 (loop for fn in '(string= string<= string>= string/= string< string> string-equal string-not-greaterp string-not-lessp string-not-equal string-lessp string-greaterp) for expected in '(nil 0 nil 0 0 nil nil 0 nil 0 0 nil) for result = (funcall fn "a" "b" :allow-other-keys t :foo nil) unless (eql result expected) collect (list fn expected result)) nil) (deftest string-comparison.allow-other-keys.2 (loop for fn in '(string= string<= string>= string/= string< string> string-equal string-not-greaterp string-not-lessp string-not-equal string-lessp string-greaterp) for expected in '(nil nil 0 0 nil 0 nil nil 0 0 nil 0) for result = (funcall fn "c" "b" :allow-other-keys t :allow-other-keys nil :foo 1) unless (eql result expected) collect (list fn expected result)) nil) (deftest string-comparison.allow-other-keys.3 (loop for fn in '(string= string<= string>= string/= string< string> string-equal string-not-greaterp string-not-lessp string-not-equal string-lessp string-greaterp) for expected in '(nil 0 nil 0 0 nil nil 0 nil 0 0 nil) for result = (funcall fn "a" "b" :allow-other-keys nil) unless (eql result expected) collect (list fn expected result)) nil) ;;; 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))) ;;; Tests on nil arrays (deftest string=.nil-array.1 :notes (:nil-vectors-are-strings) (let ((s1 (make-array '(0) :element-type nil))) (values (notnot (string= s1 s1)) (notnot (string= s1 (make-array '(0) :element-type nil))) (notnot (string= s1 (make-array '(0) :element-type 'base-char))) (notnot (string= s1 "")) (notnot (string= "" s1)) (string= s1 "a") (string= "a" s1))) t t t t t nil nil) (deftest string/=.nil-array.1 :notes (:nil-vectors-are-strings) (let ((s1 (make-array '(0) :element-type nil))) (values (string/= s1 s1) (string/= s1 (make-array '(0) :element-type nil)) (string/= s1 (make-array '(0) :element-type 'base-char)) (string/= s1 "") (string/= "" s1) (string/= s1 "a") (string/= "a" s1))) nil nil nil nil nil 0 0) (deftest string<.nil-array.1 :notes (:nil-vectors-are-strings) (let ((s1 (make-array '(0) :element-type nil))) (values (string< s1 s1) (string< s1 (make-array '(0) :element-type nil)) (string< s1 (make-array '(0) :element-type 'base-char)) (string< s1 "") (string< "" s1) (string< s1 "a") (string< "a" s1))) nil nil nil nil nil 0 nil) (deftest string<=.nil-array.1 :notes (:nil-vectors-are-strings) (let ((s1 (make-array '(0) :element-type nil))) (values (string<= s1 s1) (string<= s1 (make-array '(0) :element-type nil)) (string<= s1 (make-array '(0) :element-type 'base-char)) (string<= s1 "") (string<= "" s1) (string<= s1 "a") (string<= "a" s1))) 0 0 0 0 0 0 nil) (deftest string>.nil-array.1 :notes (:nil-vectors-are-strings) (let ((s1 (make-array '(0) :element-type nil))) (values (string> s1 s1) (string> s1 (make-array '(0) :element-type nil)) (string> s1 (make-array '(0) :element-type 'base-char)) (string> s1 "") (string> "" s1) (string> s1 "a") (string> "a" s1))) nil nil nil nil nil nil 0) (deftest string>=.nil-array.1 :notes (:nil-vectors-are-strings) (let ((s1 (make-array '(0) :element-type nil))) (values (string>= s1 s1) (string>= s1 (make-array '(0) :element-type nil)) (string>= s1 (make-array '(0) :element-type 'base-char)) (string>= s1 "") (string>= "" s1) (string>= s1 "a") (string>= "a" s1))) 0 0 0 0 0 nil 0) (deftest string-equal.nil-array.1 :notes (:nil-vectors-are-strings) (let ((s1 (make-array '(0) :element-type nil))) (values (notnot (string-equal s1 s1)) (notnot (string-equal s1 (make-array '(0) :element-type nil))) (notnot (string-equal s1 (make-array '(0) :element-type 'base-char))) (notnot (string-equal s1 "")) (notnot (string-equal "" s1)) (string-equal s1 "a") (string-equal "a" s1))) t t t t t nil nil) (deftest string-not-equal.nil-array.1 :notes (:nil-vectors-are-strings) (let ((s1 (make-array '(0) :element-type nil))) (values (string-not-equal s1 s1) (string-not-equal s1 (make-array '(0) :element-type nil)) (string-not-equal s1 (make-array '(0) :element-type 'base-char)) (string-not-equal s1 "") (string-not-equal "" s1) (string-not-equal s1 "a") (string-not-equal "a" s1))) nil nil nil nil nil 0 0) (deftest string-lessp.nil-array.1 :notes (:nil-vectors-are-strings) (let ((s1 (make-array '(0) :element-type nil))) (values (string-lessp s1 s1) (string-lessp s1 (make-array '(0) :element-type nil)) (string-lessp s1 (make-array '(0) :element-type 'base-char)) (string-lessp s1 "") (string-lessp "" s1) (string-lessp s1 "a") (string-lessp "a" s1))) nil nil nil nil nil 0 nil) (deftest string-not-greaterp.nil-array.1 :notes (:nil-vectors-are-strings) (let ((s1 (make-array '(0) :element-type nil))) (values (string-not-greaterp s1 s1) (string-not-greaterp s1 (make-array '(0) :element-type nil)) (string-not-greaterp s1 (make-array '(0) :element-type 'base-char)) (string-not-greaterp s1 "") (string-not-greaterp "" s1) (string-not-greaterp s1 "a") (string-not-greaterp "a" s1))) 0 0 0 0 0 0 nil) (deftest string-greaterp.nil-array.1 :notes (:nil-vectors-are-strings) (let ((s1 (make-array '(0) :element-type nil))) (values (string-greaterp s1 s1) (string-greaterp s1 (make-array '(0) :element-type nil)) (string-greaterp s1 (make-array '(0) :element-type 'base-char)) (string-greaterp s1 "") (string-greaterp "" s1) (string-greaterp s1 "a") (string-greaterp "a" s1))) nil nil nil nil nil nil 0) (deftest string-not-lessp.nil-array.1 :notes (:nil-vectors-are-strings) (let ((s1 (make-array '(0) :element-type nil))) (values (string-not-lessp s1 s1) (string-not-lessp s1 (make-array '(0) :element-type nil)) (string-not-lessp s1 (make-array '(0) :element-type 'base-char)) (string-not-lessp s1 "") (string-not-lessp "" s1) (string-not-lessp s1 "a") (string-not-lessp "a" s1))) 0 0 0 0 0 nil 0) ;;; Error cases (deftest string=.error.1 (signals-error (string=) program-error) t) (deftest string=.error.2 (signals-error (string= "") program-error) t) (deftest string=.error.3 (signals-error (string= "a" "b" nil nil) program-error) t) (deftest string=.error.4 (signals-error (string= "a" "b" :start1) program-error) t) (deftest string=.error.5 (signals-error (string= "a" "b" 1 nil) program-error) t) (deftest string=.error.6 (signals-error (string= "a" "b" :allow-other-keys nil :allow-other-keys t :foo 'bar) program-error) t) (deftest string/=.error.1 (signals-error (string/=) program-error) t) (deftest string/=.error.2 (signals-error (string/= "") program-error) t) (deftest string/=.error.3 (signals-error (string/= "a" "b" nil nil) program-error) t) (deftest string/=.error.4 (signals-error (string/= "a" "b" :start1) program-error) t) (deftest string/=.error.5 (signals-error (string/= "a" "b" 1 nil) program-error) t) (deftest string/=.error.6 (signals-error (string/= "a" "b" :allow-other-keys nil :allow-other-keys t :foo 'bar) program-error) t) (deftest string<.error.1 (signals-error (string<) program-error) t) (deftest string<.error.2 (signals-error (string< "") program-error) t) (deftest string<.error.3 (signals-error (string< "a" "b" nil nil) program-error) t) (deftest string<.error.4 (signals-error (string< "a" "b" :start1) program-error) t) (deftest string<.error.5 (signals-error (string< "a" "b" 1 nil) program-error) t) (deftest string<.error.6 (signals-error (string< "a" "b" :allow-other-keys nil :allow-other-keys t :foo 'bar) program-error) t) (deftest string<=.error.1 (signals-error (string<=) program-error) t) (deftest string<=.error.2 (signals-error (string<= "") program-error) t) (deftest string<=.error.3 (signals-error (string<= "a" "b" nil nil) program-error) t) (deftest string<=.error.4 (signals-error (string<= "a" "b" :start1) program-error) t) (deftest string<=.error.5 (signals-error (string<= "a" "b" 1 nil) program-error) t) (deftest string<=.error.6 (signals-error (string<= "a" "b" :allow-other-keys nil :allow-other-keys t :foo 'bar) program-error) t) (deftest string>.error.1 (signals-error (string>) program-error) t) (deftest string>.error.2 (signals-error (string> "") program-error) t) (deftest string>.error.3 (signals-error (string> "a" "b" nil nil) program-error) t) (deftest string>.error.4 (signals-error (string> "a" "b" :start1) program-error) t) (deftest string>.error.5 (signals-error (string> "a" "b" 1 nil) program-error) t) (deftest string>.error.6 (signals-error (string> "a" "b" :allow-other-keys nil :allow-other-keys t :foo 'bar) program-error) t) (deftest string>=.error.1 (signals-error (string>=) program-error) t) (deftest string>=.error.2 (signals-error (string>= "") program-error) t) (deftest string>=.error.3 (signals-error (string>= "a" "b" nil nil) program-error) t) (deftest string>=.error.4 (signals-error (string>= "a" "b" :start1) program-error) t) (deftest string>=.error.5 (signals-error (string>= "a" "b" 1 nil) program-error) t) (deftest string>=.error.6 (signals-error (string>= "a" "b" :allow-other-keys nil :allow-other-keys t :foo 'bar) program-error) t) (deftest string-equal.error.1 (signals-error (string-equal) program-error) t) (deftest string-equal.error.2 (signals-error (string-equal "") program-error) t) (deftest string-equal.error.3 (signals-error (string-equal "a" "b" nil nil) program-error) t) (deftest string-equal.error.4 (signals-error (string-equal "a" "b" :start1) program-error) t) (deftest string-equal.error.5 (signals-error (string-equal "a" "b" 1 nil) program-error) t) (deftest string-equal.error.6 (signals-error (string-equal "a" "b" :allow-other-keys nil :allow-other-keys t :foo 'bar) program-error) t) (deftest string-not-equal.error.1 (signals-error (string-not-equal) program-error) t) (deftest string-not-equal.error.2 (signals-error (string-not-equal "") program-error) t) (deftest string-not-equal.error.3 (signals-error (string-not-equal "a" "b" nil nil) program-error) t) (deftest string-not-equal.error.4 (signals-error (string-not-equal "a" "b" :start1) program-error) t) (deftest string-not-equal.error.5 (signals-error (string-not-equal "a" "b" 1 nil) program-error) t) (deftest string-not-equal.error.6 (signals-error (string-not-equal "a" "b" :allow-other-keys nil :allow-other-keys t :foo 'bar) program-error) t) (deftest string-lessp.error.1 (signals-error (string-lessp) program-error) t) (deftest string-lessp.error.2 (signals-error (string-lessp "") program-error) t) (deftest string-lessp.error.3 (signals-error (string-lessp "a" "b" nil nil) program-error) t) (deftest string-lessp.error.4 (signals-error (string-lessp "a" "b" :start1) program-error) t) (deftest string-lessp.error.5 (signals-error (string-lessp "a" "b" 1 nil) program-error) t) (deftest string-lessp.error.6 (signals-error (string-lessp "a" "b" :allow-other-keys nil :allow-other-keys t :foo 'bar) program-error) t) (deftest string-greaterp.error.1 (signals-error (string-greaterp) program-error) t) (deftest string-greaterp.error.2 (signals-error (string-greaterp "") program-error) t) (deftest string-greaterp.error.3 (signals-error (string-greaterp "a" "b" nil nil) program-error) t) (deftest string-greaterp.error.4 (signals-error (string-greaterp "a" "b" :start1) program-error) t) (deftest string-greaterp.error.5 (signals-error (string-greaterp "a" "b" 1 nil) program-error) t) (deftest string-greaterp.error.6 (signals-error (string-greaterp "a" "b" :allow-other-keys nil :allow-other-keys t :foo 'bar) program-error) t) (deftest string-not-lessp.error.1 (signals-error (string-not-lessp) program-error) t) (deftest string-not-lessp.error.2 (signals-error (string-not-lessp "") program-error) t) (deftest string-not-lessp.error.3 (signals-error (string-not-lessp "a" "b" nil nil) program-error) t) (deftest string-not-lessp.error.4 (signals-error (string-not-lessp "a" "b" :start1) program-error) t) (deftest string-not-lessp.error.5 (signals-error (string-not-lessp "a" "b" 1 nil) program-error) t) (deftest string-not-lessp.error.6 (signals-error (string-not-lessp "a" "b" :allow-other-keys nil :allow-other-keys t :foo 'bar) program-error) t) (deftest string-not-greaterp.error.1 (signals-error (string-not-greaterp) program-error) t) (deftest string-not-greaterp.error.2 (signals-error (string-not-greaterp "") program-error) t) (deftest string-not-greaterp.error.3 (signals-error (string-not-greaterp "a" "b" nil nil) program-error) t) (deftest string-not-greaterp.error.4 (signals-error (string-not-greaterp "a" "b" :start1) program-error) t) (deftest string-not-greaterp.error.5 (signals-error (string-not-greaterp "a" "b" 1 nil) program-error) t) (deftest string-not-greaterp.error.6 (signals-error (string-not-greaterp "a" "b" :allow-other-keys nil :allow-other-keys t :foo 'bar) program-error) t) gcl27-2.7.0/ansi-tests/string-downcase.lsp000066400000000000000000000107121454061450500203640ustar00rootroot00000000000000;-*- 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.11 :notes (:nil-vectors-are-strings) (string-downcase (make-array '(0) :element-type nil)) "") (deftest string-downcase.12 (loop for type in '(standard-char base-char character) for s = (make-array '(10) :element-type type :fill-pointer 5 :initial-contents "aB0cDefGHi") collect (list s (string-downcase s))) (("aB0cD" "ab0cd") ("aB0cD" "ab0cd") ("aB0cD" "ab0cd"))) (deftest string-downcase.13 (loop for type in '(standard-char base-char character) for s0 = (make-array '(10) :element-type type :initial-contents "zZaB0cDefG") for s = (make-array '(5) :element-type type :displaced-to s0 :displaced-index-offset 2) collect (list s (string-downcase s))) (("aB0cD" "ab0cd") ("aB0cD" "ab0cd") ("aB0cD" "ab0cd"))) (deftest string-downcase.14 (loop for type in '(standard-char base-char character) for s = (make-array '(5) :element-type type :adjustable t :initial-contents "aB0cD") collect (list s (string-downcase s))) (("aB0cD" "ab0cd") ("aB0cD" "ab0cd") ("aB0cD" "ab0cd"))) ;;; Order of evaluation tests (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) (def-fold-test string-downcase.fold.1 (string-downcase "ABCDE")) ;;; Error cases (deftest string-downcase.error.1 (signals-error (string-downcase) program-error) t) (deftest string-downcase.error.2 (signals-error (string-downcase (copy-seq "abc") :bad t) program-error) t) (deftest string-downcase.error.3 (signals-error (string-downcase (copy-seq "abc") :start) program-error) t) (deftest string-downcase.error.4 (signals-error (string-downcase (copy-seq "abc") :bad t :allow-other-keys nil) program-error) t) (deftest string-downcase.error.5 (signals-error (string-downcase (copy-seq "abc") :end) program-error) t) (deftest string-downcase.error.6 (signals-error (string-downcase (copy-seq "abc") 1 2) program-error) t) gcl27-2.7.0/ansi-tests/string-left-trim.lsp000066400000000000000000000125601454061450500204670ustar00rootroot00000000000000;-*- 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.10a (let* ((s (make-array 9 :initial-contents "abcdabadd" :element-type 'base-char :fill-pointer 7)) (s2 (string-left-trim "ab" s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.10b (let* ((s (make-array 9 :initial-contents "abcdabadd" :element-type 'base-char :adjustable t :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.20 :notes (:nil-vectors-are-strings) (string-left-trim "abcd" (make-array '(0) :element-type nil)) "") (deftest string-left-trim.21 :notes (:nil-vectors-are-strings) (string-left-trim (make-array '(0) :element-type nil) "abcd") "abcd") (deftest string-left-trim.22 (let ((s (make-array '(6) :initial-contents "abcaeb" :element-type 'base-char :adjustable t))) (values (string-left-trim "ab" s) s)) "caeb" "abcaeb") (deftest string-left-trim.23 (let ((s (make-array '(6) :initial-contents "abcaeb" :element-type 'character :adjustable t))) (values (string-left-trim "ab" s) s)) "caeb" "abcaeb") (deftest string-left-trim.24 (let* ((etype 'base-char) (s0 (make-array '(6) :initial-contents "abcaeb" :element-type etype)) (s (make-array '(3) :element-type etype :displaced-to s0 :displaced-index-offset 1))) (values (string-left-trim "ab" s) s s0)) "ca" "bca" "abcaeb") (deftest string-left-trim.25 (let* ((etype 'character) (s0 (make-array '(6) :initial-contents "abcaeb" :element-type etype)) (s (make-array '(3) :element-type etype :displaced-to s0 :displaced-index-offset 1))) (values (string-left-trim "ab" s) s s0)) "ca" "bca" "abcaeb") (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) (def-fold-test string-left-trim.fold.1 (string-left-trim " " " abcd")) ;;; Error cases (deftest string-left-trim.error.1 (signals-error (string-left-trim) program-error) t) (deftest string-left-trim.error.2 (signals-error (string-left-trim "abc") program-error) t) (deftest string-left-trim.error.3 (signals-error (string-left-trim "abc" "abcdddabc" nil) program-error) t) gcl27-2.7.0/ansi-tests/string-right-trim.lsp000066400000000000000000000126431454061450500206540ustar00rootroot00000000000000;-*- 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.10a (let* ((s (make-array 9 :initial-contents "abcdabadd" :element-type 'base-char :fill-pointer 7)) (s2 (string-right-trim "ab" s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.10b (let* ((s (make-array 9 :initial-contents "abcdabadd" :element-type 'base-char :adjustable t :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.20 :notes (:nil-vectors-are-strings) (string-right-trim "abcd" (make-array '(0) :element-type nil)) "") (deftest string-right-trim.21 :notes (:nil-vectors-are-strings) (string-right-trim (make-array '(0) :element-type nil) "abcd") "abcd") (deftest string-right-trim.22 (let ((s (make-array '(6) :initial-contents "abcaeb" :element-type 'base-char :adjustable t))) (values (string-right-trim "ab" s) s)) "abcae" "abcaeb") (deftest string-right-trim.23 (let ((s (make-array '(6) :initial-contents "abcaeb" :element-type 'character :adjustable t))) (values (string-right-trim "ab" s) s)) "abcae" "abcaeb") (deftest string-right-trim.24 (let* ((etype 'base-char) (s0 (make-array '(6) :initial-contents "abcaeb" :element-type etype)) (s (make-array '(3) :element-type etype :displaced-to s0 :displaced-index-offset 1))) (values (string-right-trim "ab" s) s s0)) "bc" "bca" "abcaeb") (deftest string-right-trim.25 (let* ((etype 'character) (s0 (make-array '(6) :initial-contents "abcaeb" :element-type etype)) (s (make-array '(3) :element-type etype :displaced-to s0 :displaced-index-offset 1))) (values (string-right-trim "ab" s) s s0)) "bc" "bca" "abcaeb") (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) (def-fold-test string-right-trim.fold.1 (string-right-trim " " "abcd ")) ;;; Error cases (deftest string-right-trim.error.1 (signals-error (string-right-trim) program-error) t) (deftest string-right-trim.error.2 (signals-error (string-right-trim "abc") program-error) t) (deftest string-right-trim.error.3 (signals-error (string-right-trim "abc" "abcdddabc" nil) program-error) t) gcl27-2.7.0/ansi-tests/string-trim.lsp000066400000000000000000000120271454061450500175350ustar00rootroot00000000000000;-*- 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.8a (let* ((s (copy-seq "abcdaba")) (s2 (string-trim (make-array 4 :initial-contents '(#\a #\b #\c #\d) :element-type 'base-char :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.10a (let* ((s (make-array 9 :initial-contents "abcdabadd" :element-type 'base-char :adjustable t :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.20 :notes (:nil-vectors-are-strings) (string-trim "abcd" (make-array '(0) :element-type nil)) "") (deftest string-trim.21 :notes (:nil-vectors-are-strings) (string-trim (make-array '(0) :element-type nil) "abcd") "abcd") (deftest string-trim.22 (let ((s (make-array '(6) :initial-contents "abcaeb" :element-type 'base-char :adjustable t))) (values (string-trim "ab" s) s)) "cae" "abcaeb") (deftest string-trim.23 (let ((s (make-array '(6) :initial-contents "abcaeb" :element-type 'character :adjustable t))) (values (string-trim "ab" s) s)) "cae" "abcaeb") (deftest string-trim.24 (let* ((etype 'base-char) (s0 (make-array '(6) :initial-contents "abcaeb" :element-type etype)) (s (make-array '(3) :element-type etype :displaced-to s0 :displaced-index-offset 1))) (values (string-trim "ab" s) s s0)) "c" "bca" "abcaeb") (deftest string-trim.25 (let* ((etype 'character) (s0 (make-array '(6) :initial-contents "abcaeb" :element-type etype)) (s (make-array '(3) :element-type etype :displaced-to s0 :displaced-index-offset 1))) (values (string-trim "ab" s) s s0)) "c" "bca" "abcaeb") (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) (def-fold-test string-trim.fold.1 (string-trim " " " abcd ")) ;;; Error cases (deftest string-trim.error.1 (signals-error (string-trim) program-error) t) (deftest string-trim.error.2 (signals-error (string-trim "abc") program-error) t) (deftest string-trim.error.3 (signals-error (string-trim "abc" "abcdddabc" nil) program-error) t) gcl27-2.7.0/ansi-tests/string-upcase.lsp000066400000000000000000000105631454061450500200450ustar00rootroot00000000000000;-*- 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.11 :notes (:nil-vectors-are-strings) (string-upcase (make-array '(0) :element-type nil)) "") (deftest string-upcase.12 (loop for type in '(standard-char base-char character) for s = (make-array '(10) :element-type type :fill-pointer 5 :initial-contents "aB0cDefGHi") collect (list s (string-upcase s))) (("aB0cD" "AB0CD") ("aB0cD" "AB0CD") ("aB0cD" "AB0CD"))) (deftest string-upcase.13 (loop for type in '(standard-char base-char character) for s0 = (make-array '(10) :element-type type :initial-contents "zZaB0cDefG") for s = (make-array '(5) :element-type type :displaced-to s0 :displaced-index-offset 2) collect (list s (string-upcase s))) (("aB0cD" "AB0CD") ("aB0cD" "AB0CD") ("aB0cD" "AB0CD"))) (deftest string-upcase.14 (loop for type in '(standard-char base-char character) for s = (make-array '(5) :element-type type :adjustable t :initial-contents "aB0cD") collect (list s (string-upcase s))) (("aB0cD" "AB0CD") ("aB0cD" "AB0CD") ("aB0cD" "AB0CD"))) ;;; Order of evaluation tests (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) ;;; Const fold tests (def-fold-test string-upcase.fold.1 (string-upcase "abcde")) ;;; Error tests (deftest string-upcase.error.1 (signals-error (string-upcase) program-error) t) (deftest string-upcase.error.2 (signals-error (string-upcase (copy-seq "abc") :bad t) program-error) t) (deftest string-upcase.error.3 (signals-error (string-upcase (copy-seq "abc") :start) program-error) t) (deftest string-upcase.error.4 (signals-error (string-upcase (copy-seq "abc") :bad t :allow-other-keys nil) program-error) t) (deftest string-upcase.error.5 (signals-error (string-upcase (copy-seq "abc") :end) program-error) t) (deftest string-upcase.error.6 (signals-error (string-upcase (copy-seq "abc") 1 2) program-error) t) gcl27-2.7.0/ansi-tests/string.lsp000066400000000000000000000065651454061450500165760ustar00rootroot00000000000000;-*- 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 (check-predicate #'(lambda (x) (handler-case (stringp (string x)) (type-error () :caught)))) nil) (deftest string.8 :notes (:allow-nil-arrays :nil-vectors-are-strings) (subtypep* '(array nil (*)) 'string) t t) (deftest string.9 :notes (:allow-nil-arrays :nil-vectors-are-strings) (subtypep* '(array nil 1) 'string) t t) (deftest string.10 :notes (:allow-nil-arrays :nil-vectors-are-strings) (string (make-array '(0) :element-type nil)) "") (deftest string.11 (typep* "abcd" 'string) t) (deftest string.12 :notes (:allow-nil-arrays :nil-vectors-are-strings) (typep* (make-array '(17) :element-type nil) 'string) t) (deftest string.13 :notes (:allow-nil-arrays :nil-vectors-are-strings) (typep* (make-array '(0) :element-type nil) 'string) t) (deftest string.14 (let ((count 0)) (loop for i below (min char-code-limit 65536) for c = (code-char i) for s = (and c (string c)) when (and c (or (not (stringp s)) (not (= (length s) 1)) (not (eql c (char s 0))))) collect (progn (incf count) (list i c s)) until (>= count 100))) nil) (deftest string.15 (when (> char-code-limit 65536) (loop for i = (random char-code-limit) for c = (code-char i) for s = (and c (string c)) repeat 2000 when (and c (or (not (stringp s)) (not (= (length s) 1)) (not (eql c (char s 0))))) collect (list i c s))) nil) (deftest string.16 (check-predicate #'(lambda (s) (or (not (stringp s)) (eq s (string s))))) nil) (deftest string.17 (typep* "abc" '(string)) t) (deftest string.18 (typep* "abc" '(string *)) t) (deftest string.19 (typep* "abc" '(string 3)) t) (deftest string.20 (typep* "abc" '(string 2)) nil) (deftest string.21 (typep* "abc" '(string 4)) nil) (deftest string.22 (do-special-strings (s "X") (assert (typep s 'string))) nil) (deftest string.23 (do-special-strings (s "X") (assert (typep s '(string)))) nil) (deftest string.24 (do-special-strings (s "X") (assert (typep s '(string *)))) nil) (deftest string.25 (do-special-strings (s "X") (or (array-has-fill-pointer-p s) (assert (typep s '(string 1))))) nil) (deftest string.26 (let ((i 0)) (values (string (progn (incf i) "")) i)) "" 1) ;;Spec does not appear to require this to be a fresh string ;#-gcl(def-fold-test string.fold.1 (string #\A)) (deftest string.fold.1 :notes (:string-on-character-can-be-constant) (flet ((%f nil (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0) (debug 0))) (string #\a))) (eq (%f) (%f))) nil) ;;; Error tests (deftest string.error.1 (signals-error (string) program-error) t) (deftest string.error.2 (signals-error (string nil nil) program-error) t) gcl27-2.7.0/ansi-tests/stringp.lsp000066400000000000000000000041351454061450500167450ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 29 17:32:20 2004 ;;;; Contains: Tests of STRINGP (in-package :cl-test) (deftest stringp.1 (check-type-predicate #'stringp 'string) nil) (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) (deftest stringp.9 :notes (:nil-vectors-are-strings) (notnot-mv (stringp (make-array '(0) :element-type nil))) t) (deftest stringp.10 :notes (:nil-vectors-are-strings) (notnot-mv (stringp (make-array '(37) :element-type nil))) t) (deftest stringp.11 (notnot (stringp (make-array 4 :element-type 'base-char :fill-pointer 2 :initial-contents '(#\a #\b #\c #\d)))) t) (deftest stringp.12 (notnot (stringp (make-array 4 :element-type 'base-char :adjustable t :initial-contents '(#\a #\b #\c #\d)))) t) (deftest stringp.13 (notnot (stringp (make-array 4 :element-type 'character :fill-pointer 2 :initial-contents '(#\a #\b #\c #\d)))) t) (deftest stringp.14 (notnot (stringp (make-array 4 :element-type 'character :adjustable t :initial-contents '(#\a #\b #\c #\d)))) t) (deftest stringp.15 (let ((i 0)) (values (notnot (stringp (progn (incf i) ""))) i)) t 1) ;;; Error tests (deftest stringp.error.1 (signals-error (stringp) program-error) t) (deftest stringp.error.2 (signals-error (stringp "" nil) program-error) t) gcl27-2.7.0/ansi-tests/structure-00.lsp000066400000000000000000000420441454061450500175350ustar00rootroot00000000000000;-*- 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))))) ) (declare (ignorable initial-offset)) ;; Build the tests in an eval-when form `(eval-when (:load-toplevel :compile-toplevel :execute) (report-and-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") (signals-error (,p-fn) program-error) t) (deftest ,(make-struct-test-name name "ERROR.2") (signals-error (,p-fn (,make-fn) nil) program-error) t) )) ;; 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) initval inits)) (push `(and (eqlt (quote ,initval) (,field-fn ,var)) (eqlt (quote ,initval) (funcall #',field-fn ,var))) tests)) ; `(let ((,var (,make-fn . ,inits))) `(let ((,var (apply ',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 `(multiple-value-bind (x val) (signals-error (,field-fn) program-error) (unless x (list ',slot-name ',field-fn val)))))) 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 `(multiple-value-bind (x val) (signals-error (,field-fn (,make-fn) nil) program-error) (unless x (list ',slot-name ',field-fn val)))))) 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") (signals-error (,copy-fn) program-error) t) (deftest ,(make-struct-test-name name "ERROR.6") (signals-error (,copy-fn (,make-fn) nil) program-error) t) )) ;; 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 (apply ',make-fn '(,@(loop for (slot-name . initval) in initial-value-alist nconc (list (intern (string slot-name) "KEYWORD") 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 (apply ',make-fn '(,@(loop for (slot-name . initval) in initial-value-alist nconc (list (intern (string slot-name) "KEYWORD") 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)))) gcl27-2.7.0/ansi-tests/structures-01.lsp000066400000000000000000000044071454061450500177220ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/structures-02.lsp000066400000000000000000000323031454061450500177170ustar00rootroot00000000000000;-*- 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 (my-aref s 5) (my-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 (my-aref s 5) (my-aref s 6) (my-aref s 9) (my-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-toplevel :execute) (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))) (assert (typep f 'function)) (values (struct-test-62-a s) (funcall (the function 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))) (assert (typep f 'function)) (assert (typep g 'function)) (locally (declare (type function f g)) (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) (defstruct-with-tests struct-test-65 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) (defstruct-with-tests struct-test-65A least-negative-normalized-short-float least-negative-normalized-single-float least-negative-short-float least-negative-single-float least-positive-double-float least-positive-long-float least-positive-normalized-double-float least-positive-normalized-long-float least-positive-normalized-short-float least-positive-normalized-single-float least-positive-short-float least-positive-single-float long-float-epsilon long-float-negative-epsilon most-negative-double-float most-negative-fixnum most-negative-long-float most-negative-short-float most-negative-single-float most-positive-double-float most-positive-fixnum most-positive-long-float most-positive-short-float most-positive-single-float multiple-values-limit pi short-float-epsilon short-float-negative-epsilon single-float-epsilon single-float-negative-epsilon t) (defstruct-with-tests struct-test-66 nil) (defstruct-with-tests struct-test-67 (a 0 :type (integer 0 (#.(ash 1 32)))) (b nil)) (defstruct-with-tests (struct-test-68 (:include struct-test-67)) c d) ;;; Error tests (deftest copy-structure.error.1 (signals-error (copy-structure) program-error) t) (deftest copy-structure.error.2 (signals-error (copy-structure (make-s-2) nil) program-error) t) gcl27-2.7.0/ansi-tests/structures-03.lsp000066400000000000000000000236231454061450500177250ustar00rootroot00000000000000;-*- 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 (signals-error (sbt-15-con :a 1) program-error) t) (deftest structure-boa-test-15/3 (signals-error (sbt-15-con :b 1) program-error) t) (deftest structure-boa-test-15/4 (signals-error (sbt-15-con 'x 1) program-error) t) (deftest structure-boa-test-15/5 (signals-error (sbt-15-con :y 1) program-error) t) (deftest structure-boa-test-15/6 (signals-error (sbt-15-con 'c 1) program-error) t) (deftest structure-boa-test-15/7 (signals-error (sbt-15-con 'a 1) program-error) t) (deftest structure-boa-test-15/8 (signals-error (sbt-15-con 'b 1) program-error) t) ;;; 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 (signals-error (make-sbt-16 :d 1) program-error) t) (deftest structure-boa-test-16/4 (signals-error (make-sbt-16 :a) program-error) t) (deftest structure-boa-test-16/5 (signals-error (make-sbt-16 'a) program-error) t) (deftest structure-boa-test-16/6 (signals-error (make-sbt-16 1 1) program-error) t) (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)) ;;; Error test (def-macro-test struct.error.1 (defstruct nonexistent-structure-type a b c)) gcl27-2.7.0/ansi-tests/structures-04.lsp000066400000000000000000000056441454061450500177310ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon May 19 20:07:40 2003 ;;;; Contains: More tests of structures (in-package :cl-test) ;;; I realized I had forgotten to test slot override in :include ;;; clauses in defstruct. (defstruct struct-include-01a a (b 0)) (defstruct (struct-include-01b (:include struct-include-01a (a 100) (b 'x))) (c 200) d) (deftest struct-include.1 (let ((obj (make-struct-include-01b))) (values (typep* obj 'struct-include-01a) (typep* obj 'struct-include-01b) (struct-include-01a-a obj) (struct-include-01a-b obj) (struct-include-01b-a obj) (struct-include-01b-b obj) (struct-include-01b-c obj))) t t 100 x 100 x 200) (deftest struct-include.2 (let ((obj (make-struct-include-01b :a 1 :b 2 :c 3 :d 4))) (values (typep* obj 'struct-include-01a) (typep* obj 'struct-include-01b) (struct-include-01a-a obj) (struct-include-01a-b obj) (struct-include-01b-a obj) (struct-include-01b-b obj) (struct-include-01b-c obj) (struct-include-01b-d obj) )) t t 1 2 1 2 3 4) (defstruct struct-include-02a (a 0 :type number)) (defstruct (struct-include-02b (:include struct-include-02a (a 10 :type integer)))) (deftest struct-include.3 (let ((obj (make-struct-include-02b))) (values (typep* obj 'struct-include-02a) (typep* obj 'struct-include-02b) (struct-include-02a-a obj) (struct-include-02b-a obj))) t t 10 10) (deftest struct-include.4 (let ((obj (make-struct-include-02a))) (values (typep* obj 'struct-include-02a) (typep* obj 'struct-include-02b) (struct-include-02a-a obj))) t nil 0) (deftest struct-include.5 (let ((obj (make-struct-include-02b :a 100))) (values (typep* obj 'struct-include-02a) (typep* obj 'struct-include-02b) (struct-include-02a-a obj) (struct-include-02b-a obj))) t t 100 100) (defstruct struct-include-03a (a 0 :type number)) (defstruct (struct-include-03b (:include struct-include-03a (a)))) (deftest struct-include.5a (let ((obj (make-struct-include-03b :a 100))) (values (typep* obj 'struct-include-03a) (typep* obj 'struct-include-03b) (struct-include-03a-a obj) (struct-include-03b-a obj))) t t 100 100) (defstruct struct-include-04a a b) (defstruct (struct-include-04b (:include struct-include-04a (a 0 :read-only t)))) (deftest struct-include.6 (let ((obj (make-struct-include-04b))) (values (typep* obj 'struct-include-04a) (typep* obj 'struct-include-04b) (struct-include-04a-a obj) (struct-include-04b-a obj))) t t 0 0) (deftest struct-include.7 (let ((obj (make-struct-include-04b :a 1 :b 2))) (values (typep* obj 'struct-include-04a) (typep* obj 'struct-include-04b) (struct-include-04a-a obj) (struct-include-04b-a obj) (struct-include-04a-b obj) (struct-include-04b-b obj))) t t 1 1 2 2) gcl27-2.7.0/ansi-tests/sublis.lsp000066400000000000000000000110531454061450500165550ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:32:50 2003 ;;;; Contains: Tests of SUBLIS (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) (deftest sublis.9 (check-sublis (list 0 3 8 20) '((1 . x) (5 . y) (10 . z)) :test #'(lambda (x y) (and (realp x) (realp y) (< x y)))) (x y z 20)) (deftest sublis.10 (check-sublis (list 0 3 8 20) '((1 . x) (5 . y) (10 . z)) :test-not #'(lambda (x y) (not (and (realp x) (realp y) (< x y))))) (x y z 20)) (defharmless sublis.test-and-test-not.1 (sublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :test #'eql :test-not #'eql)) (defharmless sublis.test-and-test-not.2 (sublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :test-not #'eql :test #'eql)) ;;; 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) ;;; Const fold tests (def-fold-test sublis.fold.1 (sublis '((a . b)) '(a x y . a))) ;;; 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 (signals-error (sublis) program-error) t) (deftest sublis.error.2 (signals-error (sublis nil) program-error) t) (deftest sublis.error.3 (signals-error (sublis nil 'a :test) program-error) t) (deftest sublis.error.4 (signals-error (sublis nil 'a :bad-keyword t) program-error) t) (deftest sublis.error.5 (signals-error (sublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :test #'identity) program-error) t) (deftest sublis.error.6 (signals-error (sublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :key #'cons) program-error) t) (deftest sublis.error.7 (signals-error (sublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :test-not #'identity) program-error) t) (deftest sublis.error.8 (signals-error (sublis '((a . 1) . bad) (list 'a 'b 'c 'd)) type-error) t) (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))) gcl27-2.7.0/ansi-tests/subseq-aux.lsp000066400000000000000000000154531454061450500173610ustar00rootroot00000000000000;-*- 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 (elt x i) 'b)) (unless (every #'(lambda (e) (eqt e 'a)) y) (return 5)) (loop for i from 0 to 3 do (setf (elt 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 (elt x i) 2)) (unless (every #'(lambda (e) (eqlt e 1)) y) (return 5)) (loop for i from 0 to 3 do (setf (elt 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 (elt x i) 2.0)) (unless (every #'(lambda (e) (= e 1.0)) y) (return 5)) (loop for i from 0 to 3 do (setf (elt 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 (elt x i) 2.0d0)) (unless (every #'(lambda (e) (= e 1.0)) y) (return 5)) (loop for i from 0 to 3 do (setf (elt 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 (elt x i) 2.0s0)) (unless (every #'(lambda (e) (= e 1.0)) y) (return 5)) (loop for i from 0 to 3 do (setf (elt 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 (elt x i) 2.0l0)) (unless (every #'(lambda (e) (= e 1.0)) y) (return 5)) (loop for i from 0 to 3 do (setf (elt 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 (elt 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 (elt 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 (elt 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 (elt 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 (elt 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 (elt 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 (elt 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 (elt s1 i)) 'bit-vector))))))) gcl27-2.7.0/ansi-tests/subseq.lsp000066400000000000000000000154421454061450500165640ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 12 19:41:14 2002 ;;;; Contains: Tests on SUBSEQ (in-package :cl-test) (compile-and-load "subseq-aux.lsp") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 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) ;;; Specialized string tests (deftest subseq.specialized-string.1 (let* ((s0 "abcde") (len (length s0))) (do-special-strings (s "abcde" nil) (loop for i from 0 below len for s1 = (subseq s i) do (assert (typep s1 'simple-array)) do (assert (string= (subseq s i) (subseq s0 i))) do (loop for j from i to len for s2 = (subseq s i j) do (assert (typep s2 'simple-array)) (assert (string= s2 (subseq s0 i j))))))) nil) ;;; Other specialized vectors (deftest subseq.specialized-vector.1 (let* ((v0 #(1 0 1 1 0 1 1 0)) (len (length v0))) (do-special-integer-vectors (v (copy-seq v0) nil) (loop for i from 0 below len for v1 = (subseq v i) do (assert (typep v1 'simple-array)) do (assert (equalp (subseq v i) (subseq v0 i))) do (loop for j from i to len for v2 = (subseq v i j) do (assert (typep v2 'simple-array)) (assert (equalp v2 (subseq v0 i j))))))) nil) (deftest subseq.specialized-vector.2 (loop for type in '(short-float single-float long-float double-float) for len = 10 for vals = (loop for i from 1 to len collect (coerce i type)) for vec = (make-array len :element-type type :initial-contents vals) for result = (subseq vec 1 9) unless (and (= (length result) 8) (equal (array-element-type vec) (array-element-type result)) (equalp result (apply #'vector (subseq vals 1 9)))) collect (list type vals result)) nil) (deftest subseq.specialized-vector.3 (loop for etype in '(short-float single-float long-float double-float integer rational) for type = `(complex ,etype) for len = 10 for vals = (loop for i from 1 to len collect (complex (coerce i etype) (coerce (- i) etype))) for vec = (make-array len :element-type type :initial-contents vals) for result = (subseq vec 1 9) unless (and (= (length result) 8) (equal (array-element-type vec) (array-element-type result)) (equalp result (apply #'vector (subseq vals 1 9)))) collect (list type vals result)) nil) ;;; 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) ;;; Constant folding (def-fold-test subseq.fold.1 (subseq '(1 2 3) 0)) (def-fold-test subseq.fold.2 (subseq #(1 2 3) 0)) (def-fold-test subseq.fold.3 (subseq #*011101 0)) (def-fold-test subseq.fold.4 (subseq "abcdef" 0)) ;;; Error cases (deftest subseq.error.1 (signals-error (subseq) program-error) t) (deftest subseq.error.2 (signals-error (subseq nil) program-error) t) (deftest subseq.error.3 (signals-error (subseq nil 0 0 0) program-error) t) gcl27-2.7.0/ansi-tests/subsetp.lsp000066400000000000000000000145121454061450500167440ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Apr 1 22:10:54 1998 ;;;; Contains: Tests of SUBSETP (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) (defharmless subsetp.test-and-test-not.1 (subsetp '(a b c) '(a g c e b) :test #'eql :test-not #'eql)) (defharmless subsetp.test-and-test-not.3 (subsetp '(a b c) '(a g c e b) :test-not #'eql :test #'eql)) ;;; 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 (signals-error (subsetp) program-error) t) (deftest subsetp.error.2 (signals-error (subsetp nil) program-error) t) (deftest subsetp.error.3 (signals-error (subsetp nil nil :bad t) program-error) t) (deftest subsetp.error.4 (signals-error (subsetp nil nil :key) program-error) t) (deftest subsetp.error.5 (signals-error (subsetp nil nil 1 2) program-error) t) (deftest subsetp.error.6 (signals-error (subsetp nil nil :bad t :allow-other-keys nil) program-error) t) (deftest subsetp.error.7 (signals-error (subsetp (list 1 2) (list 3 4) :test #'identity) program-error) t) (deftest subsetp.error.8 (signals-error (subsetp (list 1 2) (list 3 4) :test-not #'identity) program-error) t) (deftest subsetp.error.9 (signals-error (subsetp (list 1 2) (list 3 4) :key #'cons) program-error) t) (deftest subsetp.error.10 (signals-error (subsetp (list 1 2) (list 3 4) :key #'car) type-error) t) (deftest subsetp.error.11 (signals-error (subsetp (list 1 2 3) (list* 4 5 6)) type-error) t) (deftest subsetp.error.12 (signals-error (subsetp (list* 1 2 3) (list 1 2 3 4 5 6)) type-error) t) ;;; The next two tests previously compared against NIL, but arguably ;;; a conforming implementation is not required to signal an error ;;; in these cases, since it doesn't have to traverse the other list. (deftest subsetp.error.13 (check-type-error #'(lambda (x) (subsetp x '(a b))) #'listp) nil) (deftest subsetp.error.14 (check-type-error #'(lambda (x) (subsetp '(a b) x)) #'listp) nil) gcl27-2.7.0/ansi-tests/subst-if-not.lsp000066400000000000000000000055361454061450500176170ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:48:22 2003 ;;;; Contains: Tests of SUBST-IF-NOT (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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-not.2 (check-subst-if-not 'a (complement #'listp) '((100 1) (2 3) (4 3 2 1) (a b c))) a) (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-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-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-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) (def-fold-test subst-if-not.fold.1 (subst-if-not 'a #'consp '((1 . 2) 3 . 4))) ;;; 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) ;;; error cases (deftest subst-if-not.error.1 (signals-error (subst-if-not) program-error) t) (deftest subst-if-not.error.2 (signals-error (subst-if-not 'a) program-error) t) (deftest subst-if-not.error.3 (signals-error (subst-if-not 'a #'null) program-error) t) (deftest subst-if-not.error.4 (signals-error (subst-if-not 'a #'null nil :foo nil) program-error) t) (deftest subst-if-not.error.5 (signals-error (subst-if-not 'a #'null nil :test) program-error) t) (deftest subst-if-not.error.6 (signals-error (subst-if-not 'a #'null nil 1) program-error) t) (deftest subst-if-not.error.7 (signals-error (subst-if-not 'a #'null nil :bad t :allow-other-keys nil) program-error) t) (deftest subst-if-not.error.8 (signals-error (subst-if-not 'a #'null (list 'a nil 'c) :key #'cons) program-error) t) gcl27-2.7.0/ansi-tests/subst-if.lsp000066400000000000000000000053421454061450500170140ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:39:42 2003 ;;;; Contains: Tests of SUBST-IF (in-package :cl-test) (compile-and-load "cons-aux.lsp") (deftest subst-if.1 (check-subst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c))) a) (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.4 (check-subst-if 'b #'identity '((100 1) (2 3) (4 3 2 1) (a b c)) :key #'listp) b) (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.6 (check-subst-if 'a #'(lambda (x) (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) (def-fold-test subst-if.fold.1 (subst-if 'x 'numberp '(a b 3 (4) c d . 12))) ;;; 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) ;;; Error tests (deftest subst-if.error.1 (signals-error (subst-if) program-error) t) (deftest subst-if.error.2 (signals-error (subst-if 'a) program-error) t) (deftest subst-if.error.3 (signals-error (subst-if 'a #'null) program-error) t) (deftest subst-if.error.4 (signals-error (subst-if 'a #'null nil :foo nil) program-error) t) (deftest subst-if.error.5 (signals-error (subst-if 'a #'null nil :test) program-error) t) (deftest subst-if.error.6 (signals-error (subst-if 'a #'null nil 1) program-error) t) (deftest subst-if.error.7 (signals-error (subst-if 'a #'null nil :bad t :allow-other-keys nil) program-error) t) (deftest subst-if.error.8 (signals-error (subst-if 'a #'null (list 'a nil 'c) :key #'cons) program-error) t) gcl27-2.7.0/ansi-tests/subst.lsp000066400000000000000000000107071454061450500164210ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:37:56 2003 ;;;; Contains: Tests of SUBST (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) (deftest subst.10 (check-subst 'x 10 (copy-tree '(1 2 10 20 30 4)) :test #'(lambda (x y) (and (realp x) (realp y) (< x y)))) (1 2 10 x x 4)) (deftest subst.11 (check-subst 'x 10 (copy-tree '(1 2 10 20 30 4)) :test-not #'(lambda (x y) (not (and (realp x) (realp y) (< x y))))) (1 2 10 x x 4)) (defharmless subset.test-and-test-not.1 (subst 'a 'b (list 'a 'b 'c 'd 'e) :test #'eq :test-not #'eq)) (defharmless subset.test-and-test-not.2 (subst 'a 'b (list 'a 'b 'c 'd 'e) :test-not #'eq :test #'eq)) ;;; 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) ;;; Const fold tests (def-fold-test subst.fold.1 (subst 'a 'b '(a b c (a . b) . a))) ;;; 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)) (deftest subst.error.1 (signals-error (subst) program-error) t) (deftest subst.error.2 (signals-error (subst 'a) program-error) t) (deftest subst.error.3 (signals-error (subst 'a 'b) program-error) t) (deftest subst.error.4 (signals-error (subst 'a 'b nil :foo nil) program-error) t) (deftest subst.error.5 (signals-error (subst 'a 'b nil :test) program-error) t) (deftest subst.error.6 (signals-error (subst 'a 'b nil 1) program-error) t) (deftest subst.error.7 (signals-error (subst 'a 'b nil :bad t :allow-other-keys nil) program-error) t) (deftest subst.error.8 (signals-error (subst 'a 'b (list 'a 'b) :test #'identity) program-error) t) (deftest subst.error.9 (signals-error (subst 'a 'b (list 'a 'b) :test-not #'identity) program-error) t) (deftest subst.error.10 (signals-error (subst 'a 'b (list 'a 'b) :key #'equal) program-error) t) gcl27-2.7.0/ansi-tests/substitute-if-not.lsp000066400000000000000000000652621454061450500206740ustar00rootroot00000000000000;-*- 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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-p 'a) x) x)) #() #()) (deftest substitute-if-not-vector.2 (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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)) (deftest substitute-if-not-vector.32 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (values (substitute-if-not 'x (is-not-eql-p 'c) v2 :count 1) v1)) #(d a b x d a b c) #(a b c d a b c d a b c d a b c d)) (deftest substitute-if-not-vector.33 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (values (substitute-if-not 'x (is-not-eql-p 'c) v2 :count 1 :from-end t) v1)) #(d a b c d a b x) #(a b c d a b c d a b c d a b c d)) ;;; Tests on strings (deftest substitute-if-not-string.1 (let ((x "")) (values (substitute-if-not #\b (is-not-eql-p #\a) x) x)) "" "") (deftest substitute-if-not-string.2 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eql-p #\a) x) x)) "bbbc" "abac") (deftest substitute-if-not-string.3 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eql-p #\a) x :count nil) x)) "bbbc" "abac") (deftest substitute-if-not-string.4 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eql-p #\a) x :count 2) x)) "bbbc" "abac") (deftest substitute-if-not-string.5 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eql-p #\a) x :count 1) x)) "bbac" "abac") (deftest substitute-if-not-string.6 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eql-p #\a) x :count 0) x)) "abac" "abac") (deftest substitute-if-not-string.7 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eql-p #\a) x :count -1) x)) "abac" "abac") (deftest substitute-if-not-string.8 (let ((x "")) (values (substitute-if-not #\b (is-not-eql-p #\a) x :from-end t) x)) "" "") (deftest substitute-if-not-string.9 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-p #\1) x :key #'nextdigit :start 1 :end 6))) (and (equalp orig x) result)) "01a2342015") (deftest substitute-if-not-string.26 (do-special-strings (s "xyzabcxyzabc" nil) (assert (string= (substitute-if-not #\! (is-not-eql-p #\a) s) "xyz!bcxyz!bc")) (assert (string= (substitute-if-not #\! (is-not-eql-p #\a) s :count 1) "xyz!bcxyzabc")) (assert (string= (substitute-if-not #\! (is-not-eql-p #\a) s :count 1 :from-end t) "xyzabcxyz!bc")) (assert (string= s "xyzabcxyzabc"))) nil) (deftest substitute-if-not-bitstring.26 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (substitute-if-not 1 (is-not-eql-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-eql-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)) ;;; Constant folding tests (def-fold-test substitute-if-not.fold.1 (substitute-if-not 'z 'identity '(a nil b))) (def-fold-test substitute-if-not.fold.2 (substitute-if-not 'z 'identity #(a nil b))) (def-fold-test substitute-if-not.fold.3 (substitute-if-not 0 'zerop #*100110)) (def-fold-test substitute-if-not.fold.4 (substitute-if-not #\0 #'digit-char-p "asdaw82213nn1239123dd")) ;;; Error cases (deftest substitute-if-not.error.1 (signals-error (substitute-if-not) program-error) t) (deftest substitute-if-not.error.2 (signals-error (substitute-if-not 'a) program-error) t) (deftest substitute-if-not.error.3 (signals-error (substitute-if-not 'a #'null) program-error) t) (deftest substitute-if-not.error.4 (signals-error (substitute-if-not 'a #'null nil 'bad t) program-error) t) (deftest substitute-if-not.error.5 (signals-error (substitute-if-not 'a #'null nil 'bad t :allow-other-keys nil) program-error) t) (deftest substitute-if-not.error.6 (signals-error (substitute-if-not 'a #'null nil :key) program-error) t) (deftest substitute-if-not.error.7 (signals-error (substitute-if-not 'a #'null nil 1 2) program-error) t) (deftest substitute-if-not.error.8 (signals-error (substitute-if-not 'a #'cons (list 'a 'b 'c)) program-error) t) (deftest substitute-if-not.error.9 (signals-error (substitute-if-not 'a #'car (list 'a 'b 'c)) type-error) t) (deftest substitute-if-not.error.10 (signals-error (substitute-if-not 'a #'identity (list 'a 'b 'c) :key #'car) type-error) t) (deftest substitute-if-not.error.11 (signals-error (substitute-if-not 'a #'identity (list 'a 'b 'c) :key #'cons) program-error) t) (deftest substitute-if-not.error.12 (check-type-error #'(lambda (x) (substitute-if-not 'a #'not x)) #'sequencep) nil) gcl27-2.7.0/ansi-tests/substitute-if.lsp000066400000000000000000000627331454061450500200760ustar00rootroot00000000000000;-*- 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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-p 'a) x) x)) #() #()) (deftest substitute-if-vector.2 (let ((x #(a b a c))) (values (substitute-if 'b (is-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-p 'a) x :from-end t) x)) #() #()) (deftest substitute-if-vector.9 (let ((x #(a b a c))) (values (substitute-if 'b (is-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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)) (deftest substitute-if-vector.32 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (values (substitute-if 'x (is-eql-p 'c) v2 :count 1) v1)) #(d a b x d a b c) #(a b c d a b c d a b c d a b c d)) (deftest substitute-if-vector.33 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (values (substitute-if 'x (is-eql-p 'c) v2 :count 1 :from-end t) v1)) #(d a b c d a b x) #(a b c d a b c d a b c d a b c d)) ;;; Tests on strings (deftest substitute-if-string.1 (let ((x "")) (values (substitute-if #\b (is-eql-p #\a) x) x)) "" "") (deftest substitute-if-string.2 (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x) x)) "bbbc" "abac") (deftest substitute-if-string.3 (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count nil) x)) "bbbc" "abac") (deftest substitute-if-string.4 (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count 2) x)) "bbbc" "abac") (deftest substitute-if-string.5 (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count 1) x)) "bbac" "abac") (deftest substitute-if-string.6 (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count 0) x)) "abac" "abac") (deftest substitute-if-string.7 (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count -1) x)) "abac" "abac") (deftest substitute-if-string.8 (let ((x "")) (values (substitute-if #\b (is-eql-p #\a) x :from-end t) x)) "" "") (deftest substitute-if-string.9 (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :from-end t) x)) "bbbc" "abac") (deftest substitute-if-string.10 (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :from-end t :count nil) x)) "bbbc" "abac") (deftest substitute-if-string.11 (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count 2 :from-end t) x)) "bbbc" "abac") (deftest substitute-if-string.12 (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count 1 :from-end t) x)) "abbc" "abac") (deftest substitute-if-string.13 (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count 0 :from-end t) x)) "abac" "abac") (deftest substitute-if-string.14 (let ((x "abac")) (values (substitute-if #\b (is-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-p #\1) x :key #'nextdigit :start 1 :end 6))) (and (equalp orig x) result)) "01a2342015") (deftest substitute-if-string.26 (do-special-strings (s "xyzabcxyzabc" nil) (assert (string= (substitute-if #\! (is-eql-p #\a) s) "xyz!bcxyz!bc")) (assert (string= (substitute-if #\! (is-eql-p #\a) s :count 1) "xyz!bcxyzabc")) (assert (string= (substitute-if #\! (is-eql-p #\a) s :count 1 :from-end t) "xyzabcxyz!bc")) (assert (string= s "xyzabcxyzabc"))) nil) ;;; More bit vector tests (deftest substitute-if-bit-vector.22 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (substitute-if 1 (is-eql-p 1) x :key #'1+))) (and (equalp orig x) result)) #*11111111111111111) (deftest substitute-if-bit-vector.23 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (substitute-if 1 (is-eql-p 1) x :key #'1+ :start 1 :end 10))) (and (equalp orig x) result)) #*01111111111010110) (deftest substitute-if-bit-vector.24 (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.25 (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.26 (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.27 (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) ;;; Order of evaluation tests (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)) ;;; Constant folding tests (def-fold-test substitute-if.fold.1 (substitute-if 'z 'null '(a nil b))) (def-fold-test substitute-if.fold.2 (substitute-if 'z 'null #(a nil b))) (def-fold-test substitute-if.fold.3 (substitute-if 0 'plusp #*100110)) (def-fold-test substitute-if.fold.4 (substitute-if #\x 'digit-char-p "asdf8234n123f")) ;;; Error cases (deftest substitute-if.error.1 (signals-error (substitute-if) program-error) t) (deftest substitute-if.error.2 (signals-error (substitute-if 'a) program-error) t) (deftest substitute-if.error.3 (signals-error (substitute-if 'a #'null) program-error) t) (deftest substitute-if.error.4 (signals-error (substitute-if 'a #'null nil 'bad t) program-error) t) (deftest substitute-if.error.5 (signals-error (substitute-if 'a #'null nil 'bad t :allow-other-keys nil) program-error) t) (deftest substitute-if.error.6 (signals-error (substitute-if 'a #'null nil :key) program-error) t) (deftest substitute-if.error.7 (signals-error (substitute-if 'a #'null nil 1 2) program-error) t) (deftest substitute-if.error.8 (signals-error (substitute-if 'a #'cons (list 'a 'b 'c)) program-error) t) (deftest substitute-if.error.9 (signals-error (substitute-if 'a #'car (list 'a 'b 'c)) type-error) t) (deftest substitute-if.error.10 (signals-error (substitute-if 'a #'identity (list 'a 'b 'c) :key #'car) type-error) t) (deftest substitute-if.error.11 (signals-error (substitute-if 'a #'identity (list 'a 'b 'c) :key #'cons) program-error) t) (deftest substitute-if.error.12 (check-type-error #'(lambda (x) (substitute-if 'a #'not x)) #'sequencep) nil) gcl27-2.7.0/ansi-tests/substitute.lsp000066400000000000000000000762041454061450500175000ustar00rootroot00000000000000;-*- 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)) (deftest substitute-vector.32 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (values (substitute 'x 'c v2 :count 1) v1)) #(d a b x d a b c) #(a b c d a b c d a b c d a b c d)) (deftest substitute-vector.33 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (values (substitute 'x 'c v2 :count 1 :from-end t) v1)) #(d a b c d a b x) #(a b c d a b c d a b c d a b c d)) ;;; 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") (deftest substitute-string.32 (do-special-strings (s "xyzabcxyzabc" nil) (assert (string= (substitute #\! #\a s) "xyz!bcxyz!bc")) (assert (string= (substitute #\! #\a s :count 1) "xyz!bcxyzabc")) (assert (string= (substitute #\! #\a s :count 1 :from-end t) "xyzabcxyz!bc")) (assert (string= s "xyzabcxyzabc"))) nil) ;;; 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) (defharmless substitute.test-and-test-not.1 (substitute 'b 'a (list 'a 'b 'c 'd 'a 'b) :test #'eql :test-not #'eql)) (defharmless substitute.test-and-test-not.2 (substitute 'b 'a (list 'a 'b 'c 'd 'a 'b) :test-not #'eql :test #'eql)) (defharmless substitute.test-and-test-not.3 (substitute 'b 'a (vector 'a 'b 'c 'd 'a 'b) :test #'eql :test-not #'eql)) (defharmless substitute.test-and-test-not.4 (substitute 'b 'a (vector 'a 'b 'c 'd 'a 'b) :test-not #'eql :test #'eql)) (defharmless substitute.test-and-test-not.5 (substitute #\b #\a (copy-seq "abcdab") :test #'eql :test-not #'eql)) (defharmless substitute.test-and-test-not.6 (substitute #\b #\a (copy-seq "abcdab") :test-not #'eql :test #'eql)) (defharmless substitute.test-and-test-not.7 (substitute 1 0 (copy-seq #*001101001) :test #'eql :test-not #'eql)) (defharmless substitute.test-and-test-not.8 (substitute 0 1 (copy-seq #*1100110101) :test-not #'eql :test #'eql)) (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)) ;;; Constant folding tests (def-fold-test substitute.fold.1 (substitute 'z 'b '(a b c))) (def-fold-test substitute.fold.2 (substitute 'z 'b #(a b c))) (def-fold-test substitute.fold.3 (substitute 0 1 #*001101)) (def-fold-test substitute.fold.4 (substitute #\a #\b "abcebadfke")) ;;; Error cases (deftest substitute.error.1 (signals-error (substitute) program-error) t) (deftest substitute.error.2 (signals-error (substitute 'a) program-error) t) (deftest substitute.error.3 (signals-error (substitute 'a 'b) program-error) t) (deftest substitute.error.4 (signals-error (substitute 'a 'b nil 'bad t) program-error) t) (deftest substitute.error.5 (signals-error (substitute 'a 'b nil 'bad t :allow-other-keys nil) program-error) t) (deftest substitute.error.6 (signals-error (substitute 'a 'b nil :key) program-error) t) (deftest substitute.error.7 (signals-error (substitute 'a 'b nil 1 2) program-error) t) (deftest substitute.error.8 (signals-error (substitute 'a 'b (list 'a 'b 'c) :test #'identity) program-error) t) (deftest substitute.error.9 (signals-error (substitute 'a 'b (list 'a 'b 'c) :test-not #'identity) program-error) t) (deftest substitute.error.10 (signals-error (substitute 'a 'b (list 'a 'b 'c) :key #'cons) program-error) t) (deftest substitute.error.11 (signals-error (substitute 'a 'b (list 'a 'b 'c) :key #'car) type-error) t) (deftest substitute.error.12 (check-type-error #'(lambda (x) (substitute 'a 'b x)) #'sequencep) nil) gcl27-2.7.0/ansi-tests/subtypep-array.lsp000066400000000000000000000172561454061450500202560ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 1 16:23:57 2003 ;;;; Contains: Tests of SUBTYPEP on array types (in-package :cl-test) (compile-and-load "types-aux.lsp") ;;; *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.array.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.array.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) (deftest subtypep.array.8 (let ((limit (min 16 array-rank-limit))) (loop for i below limit for type1 = `(array t ,i) nconc (loop for j below limit for type2 = `(array t ,j) when (and (/= i j) (subtypep type1 type2)) collect (list type1 type2)))) nil) (deftest subtypep.array.9 (let ((limit (min 16 array-rank-limit))) (loop for i below limit for type1 = `(array t ,(make-list i :initial-element 1)) nconc (loop for j below limit for type2 = `(array t ,(make-list j :initial-element 1)) when (and (/= i j) (subtypep type1 type2)) collect (list type1 type2)))) nil) (deftest subtypep.array.10 (subtypep* '(array t nil) 'integer) nil t) (deftest subtypep.array.11 (subtypep* '(array t nil) '(array t (*))) nil t) (deftest subtypep.array.12 (subtypep* '(array t nil) '(array t 1)) nil t) (deftest subtypep.array.13 (subtypep* '(array bit nil) '(array bit 1)) nil t) ;;;; Tests on the definitions of various vector types (deftest string-is-not-vector-of-character.1 :notes (:nil-vectors-are-strings) (subtypep* 'string '(vector character)) nil t) (deftest vector-of-character-is-string.2 (subtypep* '(vector character) 'string) t t) (deftest string-is-not-vector-of-character.3 :notes (:nil-vectors-are-strings) (subtypep* '(string *) '(vector character)) nil t) (deftest vector-of-character-is-string.4 (subtypep* '(vector character) '(string *)) t t) (deftest string-is-not-vector-of-character.5 :notes (:nil-vectors-are-strings) (subtypep* '(string 17) '(vector character 17)) nil t) (deftest vector-of-character-is-string.6 (subtypep* '(vector character 17) '(string 17)) t t) (deftest base-string-is-vector-of-base-char.1 (subtypep* 'base-string '(vector base-char)) t t) (deftest base-string-is-vector-of-base-char.2 (subtypep* '(vector base-char) 'base-string) t t) (deftest base-string-is-vector-of-base-char.3 (subtypep* '(base-string *) '(vector base-char)) t t) (deftest base-string-is-vector-of-base-char.4 (subtypep* '(vector base-char) '(base-string *)) t t) (deftest base-string-is-vector-of-base-char.5 (subtypep* '(base-string 17) '(vector base-char 17)) t t) (deftest base-string-is-vector-of-base-char.6 (subtypep* '(vector base-char 17) '(base-string 17)) t t) (deftest simple-base-string-is-simple-1d-array-of-base-char.1 (subtypep* 'simple-base-string '(simple-array base-char (*))) t t) (deftest simple-base-string-is-simple-1d-array-of-base-char.2 (subtypep* '(simple-array base-char (*)) 'simple-base-string) t t) (deftest simple-base-string-is-simple-1d-array-of-base-char.3 (subtypep* '(simple-base-string *) '(simple-array base-char (*))) t t) (deftest simple-base-string-is-simple-1d-array-of-base-char.4 (subtypep* '(simple-array base-char (*)) '(simple-base-string *)) t t) (deftest simple-base-string-is-simple-1d-array-of-base-char.5 (subtypep* '(simple-base-string 17) '(simple-array base-char (17))) t t) (deftest simple-base-string-is-simple-1d-array-of-base-char.6 (subtypep* '(simple-array base-char (17)) '(simple-base-string 17)) t t) (deftest simple-string-is-not-simple-1d-array-of-character.1 :notes (:nil-vectors-are-strings) (subtypep* 'simple-string '(simple-array character (*))) nil t) (deftest simple-1d-array-of-character-is-simple-string.2 (subtypep* '(simple-array character (*)) 'simple-string) t t) (deftest simple-string-is-not-simple-1d-array-of-character.3 :notes (:nil-vectors-are-strings) (subtypep* '(simple-string *) '(simple-array character (*))) nil t) (deftest simple-1d-array-of-character-is-simple-string.4 (subtypep* '(simple-array character (*)) '(simple-string *)) t t) (deftest simple-string-is-not-simple-1d-array-of-character.5 :notes (:nil-vectors-are-strings) (subtypep* '(simple-string 17) '(simple-array character (17))) nil t) (deftest simple-1d-array-of-character-is-simple-string.6 (subtypep* '(simple-array character (17)) '(simple-string 17)) t t) (deftest vector-is-1d-array.1 (subtypep* 'vector '(array * (*))) t t) (deftest vector-is-1d-array.2 (subtypep* '(array * (*)) 'vector) t t) (deftest vector-is-1d-array.3 (subtypep* '(vector *) '(array * (*))) t t) (deftest vector-is-1d-array.4 (subtypep* '(array * (*)) '(vector *)) t t) (deftest vector-is-1d-array.5 (subtypep* '(vector * 17) '(array * (17))) t t) (deftest vector-is-1d-array.6 (subtypep* '(array * (17)) '(vector * 17)) t t) (deftest simple-vector-is-simple-1d-array.1 (subtypep* 'simple-vector '(simple-array t (*))) t t) (deftest simple-vector-is-simple-1d-array.2 (subtypep* '(simple-array t (*)) 'simple-vector) t t) (deftest simple-vector-is-simple-1d-array.3 (subtypep* '(simple-vector *) '(simple-array t (*))) t t) (deftest simple-vector-is-simple-1d-array.4 (subtypep* '(simple-array t (*)) '(simple-vector *)) t t) (deftest simple-vector-is-simple-1d-array.5 (subtypep* '(simple-vector 17) '(simple-array t (17))) t t) (deftest simple-vector-is-simple-1d-array.6 (subtypep* '(simple-array t (17)) '(simple-vector 17)) t t) gcl27-2.7.0/ansi-tests/subtypep-complex.lsp000066400000000000000000000101001454061450500205640ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 23 07:12:38 2005 ;;;; Contains: Tests of SUBTYPEP on complex types (in-package :cl-test) (compile-and-load "types-aux.lsp") (deftest subtypep-complex.1 (subtypep* 'complex 'number) t t) (deftest subtypep-complex.2 (subtypep* 'number 'complex) nil t) (defun check-not-complex-type (type) (let ((result1 (multiple-value-list (subtypep* type 'complex))) (result2 (multiple-value-list (subtypep* 'complex type)))) (if (and (equal result1 '(nil t)) (equal result2 '(nil t))) nil (list (list type result1 result2))))) (deftest subtypep-complex.3 (mapcan #'check-not-complex-type '(bit unsigned-byte integer rational ratio real float short-float single-float double-float long-float fixnum bignum)) nil) (deftest subtypep-complex.4 (loop for i from 1 to 100 nconc (check-not-complex-type `(unsigned-byte ,i))) nil) (deftest subtypep-complex.5 (loop for i from 1 to 100 nconc (check-not-complex-type `(signed-byte ,i))) nil) (deftest subtypep-complex.7 (let ((types '(complex (complex) (complex *)))) (loop for tp1 in types nconc (loop for tp2 in types for result = (multiple-value-list (subtypep* tp1 tp2)) unless (equal result '(t t)) collect (list tp1 tp2 result)))) nil) (defun check-complex-upgrading (t1 t2) (let* ((ucpt1 (upgraded-complex-part-type t1)) (ucpt2 (upgraded-complex-part-type t2)) (result (multiple-value-list (subtypep* `(complex ,t1) `(complex ,t2))))) (cond ((or (equal ucpt1 ucpt2) (subtypep t1 t2)) (unless (equal result '(t t)) (list (list :case1 t1 t2 ucpt1 ucpt2 result)))) (t (multiple-value-bind (ucpt-sub1? good1?) (subtypep* ucpt1 ucpt2) (multiple-value-bind (ucpt-sub2? good2?) (subtypep* ucpt2 ucpt1) (cond ;; the second is not a subtype of the first ((and good2? ucpt-sub1? (not ucpt-sub2?)) (assert good1?) (unless (equal result '(nil t)) (list (list :case2 t1 t2 ucpt1 ucpt2 result)))) ;; the first is not a subtype of the second ((and good1? (not ucpt-sub1?) ucpt-sub2?) (assert good2?) (unless (equal result '(nil t)) (list (list :case3 t1 t2 ucpt1 ucpt2 result)))) ;; they are both subtypes of each other, and so represent ;; the same set of objects ((and ucpt-sub1? ucpt-sub2?) (assert good1?) (assert good2?) (unless (equal result '(t t)) (list (list :case4 t1 t2 ucpt1 ucpt2 result))))))))))) (deftest subtypep-complex.8 (let ((types (reverse '(bit fixnum bignum integer unsigned-byte rational ratio short-float single-float double-float long-float float real))) (float-types (remove-duplicates '(short-float single-float double-float long-float) :test #'(lambda (t1 t2) (eql (coerce 0 t1) (coerce 0 t2)))))) (loop for i in '(1 2 3 4 6 8 13 16 17 28 29 31 32 48 64) do (push `(unsigned-byte ,i) types) do (push `(signed-byte ,i) types) do (loop for ftp in float-types do (push `(,ftp ,(coerce 0 ftp) ,(coerce i ftp)) types) do (push `(,ftp (,(coerce (- i) ftp)) ,(coerce i ftp)) types)) do (push `(float ,(coerce 0 'single-float) ,(coerce i 'single-float)) types)) (setq types (reverse types)) (let ((results (mapcan #'(lambda (t1) (mapcan #'(lambda (t2) (check-complex-upgrading t1 t2)) types)) types))) (subseq results 0 (min 100 (length results))))) nil) (deftest subtypep-complex.9 (check-all-not-subtypep '(complex (or (integer 1 2) (integer 5 6))) '(or (complex (integer 1 2)) (complex (integer 5 6)))) nil) (deftest subtypep-complex.10 (check-all-subtypep '(or (complex (integer 1 2)) (complex (integer 5 6))) '(complex (or (integer 1 2) (integer 5 6)))) nil) (deftest subtypep-complex.11 (check-all-not-subtypep '(complex (rational 1 3/2)) '(complex (rational (1) 3/2))) nil) (deftest subtypep-complex.12 (check-all-subtypep '(complex (rational (1) 3/2)) '(complex (rational 1 3/2))) nil) gcl27-2.7.0/ansi-tests/subtypep-cons.lsp000066400000000000000000000260051454061450500200720ustar00rootroot00000000000000;-*- 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) (compile-and-load "types-aux.lsp") ;;; 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) ;;; Test case that came up in SBCL (deftest subtypep.cons.21 (check-all-subtypep '(cons integer single-float) '(or (cons fixnum single-float) (cons bignum single-float))) nil) (deftest subtypep.cons.22 (check-all-subtypep '(cons single-float integer) '(or (cons single-float fixnum) (cons single-float bignum))) nil) ;;; More test cases from SBCL, CMUCL, culled from random test failures (deftest subtype.cons.23 (let ((t1 '(cons t (cons (not long-float) symbol))) (t2 '(not (cons symbol (cons integer integer))))) (subtypep-and-contrapositive-are-consistent t1 t2)) t) (deftest subtype.cons.24 (let ((t1 '(cons (eql 3671) (cons short-float (eql -663423073525)))) (t2 '(not (cons t (cons (not complex) (cons integer t)))))) (subtypep-and-contrapositive-are-consistent t1 t2)) t) (deftest subtype.cons.25 (let ((t1 '(cons t (cons (not long-float) (integer 44745969 61634129)))) (t2 '(not (cons (eql -3) (cons short-float (cons t float)))))) (subtypep-and-contrapositive-are-consistent t1 t2)) t) (deftest subtype.cons.26 (let ((t1 '(cons integer (cons single-float (cons t t)))) (t2 '(cons t (cons (not complex) (not (eql 8)))))) (subtypep-and-contrapositive-are-consistent t1 t2)) t) (deftest subtype.cons.27 (let ((t1 '(cons (not (integer -27 30)) (cons rational (cons integer integer)))) (t2 '(not (cons integer (cons integer (eql 378132631)))))) (subtypep-and-contrapositive-are-consistent t1 t2)) t) (deftest subtype.cons.28 (let ((t1 '(cons (integer -1696888 -1460338) (cons single-float symbol))) (t2 '(not (cons (not (integer -14 20)) (cons (not integer) cons))))) (subtypep-and-contrapositive-are-consistent t1 t2)) t) (deftest subtypep.cons.29 (let ((t2 '(or (not (cons unsigned-byte cons)) (not (cons (integer -6 22) rational))))) (subtypep-and-contrapositive-are-consistent 'cons t2)) t) (deftest subtypep.cons.30 (let ((t1 '(not (cons t (cons t (cons cons t))))) (t2 '(or (or (cons (cons t integer) t) (not (cons t (cons t cons)))) (not (cons (cons (eql -27111309) t) (cons t (eql 1140730))))))) (subtypep-and-contrapositive-are-consistent t1 t2)) t) (deftest subtypep.cons.31 (let ((t2 '(or (not (cons (or (cons t ratio) (cons short-float t)) (cons (cons (eql -7418623) (integer -9 53)) (cons cons t)))) (not (cons (cons t (eql -265039)) (cons (cons t cons) t)))))) (subtypep-and-contrapositive-are-consistent 'cons t2)) t) (deftest subtypep.cons.32 (let ((t2 '(cons t (or (not (cons integer (eql 0))) (not (cons (or float (eql 0)) cons)))))) (subtypep-and-contrapositive-are-consistent 'cons t2)) t) (deftest subtypep.cons.33 (let ((t2 '(or (not (cons (cons t cons) (cons t (cons unsigned-byte t)))) (not (cons (cons integer t) (cons t (cons cons t))))))) (subtypep-and-contrapositive-are-consistent 'cons t2)) t) (deftest subtypep.cons.34 (let ((t2 '(or (not (cons (or (eql 0) ratio) (not cons))) (not (cons integer cons))))) (subtypep-and-contrapositive-are-consistent 'cons t2)) t) (deftest subtypep.cons.35 (notnot-mv (subtypep '(cons nil t) 'float)) t t) (deftest subtypep.cons.36 (notnot-mv (subtypep '(cons t nil) 'symbol)) t t) (deftest subtypep.cons.37 (notnot-mv (subtypep '(cons nil nil) 'real)) t t) (deftest subtypep.cons.38 (let ((t1 '(cons t (complex (real -32 0)))) (t2 `(not (cons t (complex (integer * -500)))))) (subtypep-and-contrapositive-are-consistent t1 t2)) t) ;;; From GCL (deftest subtypep.cons.39 (values (subtypep t '(and (not (cons cons (cons cons t))) (not (cons t cons))))) nil) (deftest subtypep.cons.40 (let ((type1 '(cons (eql 0) cons)) (type2 '(cons unsigned-byte symbol))) (values (subtypep* type1 type2) (subtypep* `(not ,type2) `(not ,type1)))) nil nil) ;;; From sbcl 0.9.5.31 (deftest subtypep.cons.41 (let ((type1 '(cons t (complex (real -10 -4)))) (type2 '(not (cons t (complex (integer -200 -100)))))) (multiple-value-bind (sub1 success1) (subtypep* type1 type2) (multiple-value-bind (sub2 success2) (subtypep* `(not ,type2) `(not ,type1)) (if (and success1 success2 (not (eq sub1 sub2))) (values sub1 sub2) nil)))) nil) (deftest subtypep.cons.42 (let ((t1 '(cons (cons (cons (real -744833699 -744833699) cons) (integer -234496 215373)) integer)) (t2 '(cons (cons (cons integer integer) (integer -234496 215373)) t))) (values (subtypep `(not ,t2) `(not ,t1)))) nil) ;;;; From sbcl 0.9.6.57 (deftest subtypep.cons.43 (let* ((n -3.926510009989861d7) (t1 '(not (cons float t))) (t2 `(or (not (cons (eql 0) (real ,n ,n))) (not (cons t (eql 0)))))) (multiple-value-bind (sub1 good1) (subtypep* t1 t2) (multiple-value-bind (sub2 good2) (subtypep* `(not ,t2) `(not ,t1)) (or (not good1) (not good2) (and sub1 sub2) (and (not sub1) (not sub2)))))) t) #+gcl (deftest subtypep.cons.44 (check-all-subtypep 'si::proper-list 'list) nil) #+gcl (deftest subtypep.cons.45 (check-all-not-subtypep 'si::proper-list nil) nil) #+gcl (deftest subtypep.cons.46 (check-all-not-subtypep 'list 'si::proper-list) nil) #+gcl (deftest subtypep.cons.47 (check-all-subtypep '(cons t (cons t null)) 'si::proper-list) nil) #+gcl (deftest subtypep.cons.48 (check-all-subtypep '(cons t (cons t si::proper-list)) 'si::proper-list) nil) #+gcl (deftest subtypep.cons.49 (check-all-not-subtypep 'si::proper-list '(cons t (cons t si::proper-list))) nil) #+gcl (deftest subtypep.cons.50 (check-all-not-subtypep '(cons t (cons t (not si::proper-list))) 'si::proper-list) nil) #+gcl (deftest subtypep.cons.51 (check-all-not-subtypep '(cons t (cons t (not si::proper-list))) nil) nil) #+gcl (deftest subtypep.cons.52 (check-all-not-subtypep 'si::proper-list '(cons t (cons t (not si::proper-list)))) nil) gcl27-2.7.0/ansi-tests/subtypep-eql.lsp000066400000000000000000000025201454061450500177050ustar00rootroot00000000000000;-*- 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) (compile-and-load "types-aux.lsp") (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) gcl27-2.7.0/ansi-tests/subtypep-float.lsp000066400000000000000000000257761454061450500202530ustar00rootroot00000000000000;-*- 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) (compile-and-load "types-aux.lsp") ;;;;;;; (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) ;;; Signed zero tests (deftest subtypep.short-float.zero.1 (check-equivalence '(short-float 0.0s0 *) '(or (short-float (0.0s0) *) (member -0.0s0 0.0s0))) nil) (unless (eql 0.0s0 -0.0s0) (deftest subtypep.short-float.zero.2a (values (subtypep '(short-float 0.0s0) '(or (short-float (0.0s0)) (member 0.0s0)))) nil) (deftest subtypep.short-float.zero.2b (values (subtypep '(short-float 0.0s0) '(or (short-float (0.0s0)) (member -0.0s0)))) nil)) (deftest subtypep.short-float.zero.3 (subtypep* '(short-float -0.0s0 *) '(short-float 0.0s0 *)) t t) (deftest subtypep.short-float.zero.4 (subtypep* '(short-float * -0.0s0) '(short-float * 0.0s0)) t t) (deftest subtypep.short-float.zero.5 (subtypep* '(short-float (-0.0s0) *) '(short-float (0.0s0) *)) t t) (deftest subtypep.short-float.zero.6 (subtypep* '(short-float * (-0.0s0)) '(short-float * (0.0s0))) t t) (deftest subtypep.short-float.zero.7 (subtypep* '(short-float 0.0s0 *) '(short-float -0.0s0 *)) t t) (deftest subtypep.short-float.zero.8 (subtypep* '(short-float * 0.0s0) '(short-float * -0.0s0)) t t) (deftest subtypep.short-float.zero.9 (subtypep* '(short-float (0.0s0) *) '(short-float (-0.0s0) *)) t t) (deftest subtypep.short-float.zero.10 (subtypep* '(short-float * (0.0s0)) '(short-float * (-0.0s0))) t t) ;;; (deftest subtypep.float.zero.3 (subtypep* '(float -0.0 *) '(float 0.0 *)) t t) (deftest subtypep.float.zero.4 (subtypep* '(float * -0.0) '(float * 0.0)) t t) (deftest subtypep.float.zero.5 (subtypep* '(float (-0.0) *) '(float (0.0) *)) t t) (deftest subtypep.float.zero.6 (subtypep* '(float * (-0.0)) '(float * (0.0))) t t) (deftest subtypep.float.zero.7 (subtypep* '(float 0.0 *) '(float -0.0 *)) t t) (deftest subtypep.float.zero.8 (subtypep* '(float * 0.0) '(float * -0.0)) t t) (deftest subtypep.float.zero.9 (subtypep* '(float (0.0) *) '(float (-0.0) *)) t t) (deftest subtypep.float.zero.10 (subtypep* '(float * (0.0)) '(float * (-0.0))) t t) ;;; (deftest subtypep.single-float.zero.1 (check-equivalence '(single-float 0.0f0 *) '(or (single-float (0.0f0) *) (member -0.0f0 0.0f0))) nil) (unless (eql 0.0f0 -0.0f0) (deftest subtypep.single-float.zero.2a (values (subtypep '(single-float 0.0f0) '(or (single-float (0.0f0)) (member 0.0f0)))) nil) (deftest subtypep.single-float.zero.2b (values (subtypep '(single-float 0.0f0) '(or (single-float (0.0f0)) (member -0.0f0)))) nil)) (deftest subtypep.single-float.zero.3 (subtypep* '(single-float -0.0f0 *) '(single-float 0.0f0 *)) t t) (deftest subtypep.single-float.zero.4 (subtypep* '(single-float * -0.0f0) '(single-float * 0.0f0)) t t) (deftest subtypep.single-float.zero.5 (subtypep* '(single-float (-0.0f0) *) '(single-float (0.0f0) *)) t t) (deftest subtypep.single-float.zero.6 (subtypep* '(single-float * (-0.0f0)) '(single-float * (0.0f0))) t t) (deftest subtypep.single-float.zero.7 (subtypep* '(single-float 0.0f0 *) '(single-float -0.0f0 *)) t t) (deftest subtypep.single-float.zero.8 (subtypep* '(single-float * 0.0f0) '(single-float * -0.0f0)) t t) (deftest subtypep.single-float.zero.9 (subtypep* '(single-float (0.0f0) *) '(single-float (-0.0f0) *)) t t) (deftest subtypep.single-float.zero.10 (subtypep* '(single-float * (0.0f0)) '(single-float * (-0.0f0))) t t) ;;; (deftest subtypep.long-float.zero.1 (check-equivalence '(long-float 0.0l0 *) '(or (long-float (0.0l0) *) (member -0.0l0 0.0l0))) nil) (unless (eql 0.0l0 -0.0l0) (deftest subtypep.long-float.zero.2a (values (subtypep '(long-float 0.0l0) '(or (long-float (0.0l0)) (member 0.0l0)))) nil) (deftest subtypep.long-float.zero.2b (values (subtypep '(long-float 0.0l0) '(or (long-float (0.0l0)) (member -0.0l0)))) nil)) (deftest subtypep.long-float.zero.3 (subtypep* '(long-float -0.0l0 *) '(long-float 0.0l0 *)) t t) (deftest subtypep.long-float.zero.4 (subtypep* '(long-float * -0.0l0) '(long-float * 0.0l0)) t t) (deftest subtypep.long-float.zero.5 (subtypep* '(long-float (-0.0l0) *) '(long-float (0.0l0) *)) t t) (deftest subtypep.long-float.zero.6 (subtypep* '(long-float * (-0.0l0)) '(long-float * (0.0l0))) t t) (deftest subtypep.long-float.zero.7 (subtypep* '(long-float 0.0l0 *) '(long-float -0.0l0 *)) t t) (deftest subtypep.long-float.zero.8 (subtypep* '(long-float * 0.0l0) '(long-float * -0.0l0)) t t) (deftest subtypep.long-float.zero.9 (subtypep* '(long-float (0.0l0) *) '(long-float (-0.0l0) *)) t t) (deftest subtypep.long-float.zero.10 (subtypep* '(long-float * (0.0l0)) '(long-float * (-0.0l0))) t t) ;;; (deftest subtypep.double-float.zero.1 (check-equivalence '(double-float 0.0d0 *) '(or (double-float (0.0d0) *) (member -0.0d0 0.0d0))) nil) (unless (eql 0.0d0 -0.0d0) (deftest subtypep.double-float.zero.2a (values (subtypep '(double-float 0.0d0) '(or (double-float (0.0d0)) (member 0.0d0)))) nil) (deftest subtypep.double-float.zero.2b (values (subtypep '(double-float 0.0d0) '(or (double-float (0.0d0)) (member -0.0d0)))) nil)) (deftest subtypep.double-float.zero.3 (subtypep* '(double-float -0.0d0 *) '(double-float 0.0d0 *)) t t) (deftest subtypep.double-float.zero.4 (subtypep* '(double-float * -0.0d0) '(double-float * 0.0d0)) t t) (deftest subtypep.double-float.zero.5 (subtypep* '(double-float (-0.0d0) *) '(double-float (0.0d0) *)) t t) (deftest subtypep.double-float.zero.6 (subtypep* '(double-float * (-0.0d0)) '(double-float * (0.0d0))) t t) (deftest subtypep.double-float.zero.7 (subtypep* '(double-float 0.0d0 *) '(double-float -0.0d0 *)) t t) (deftest subtypep.double-float.zero.8 (subtypep* '(double-float * 0.0d0) '(double-float * -0.0d0)) t t) (deftest subtypep.double-float.zero.9 (subtypep* '(double-float (0.0d0) *) '(double-float (-0.0d0) *)) t t) (deftest subtypep.double-float.zero.10 (subtypep* '(double-float * (0.0d0)) '(double-float * (-0.0d0))) t t) gcl27-2.7.0/ansi-tests/subtypep-function.lsp000066400000000000000000000010571454061450500207550ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Dec 15 21:57:44 2004 ;;;; Contains: Tests of SUBTYPEP on FUNCTION types (in-package :cl-test) (compile-and-load "types-aux.lsp") (deftest subtypep-function.1 (check-all-not-subtypep t '(function (t) t)) nil) (deftest subtypep-function.2 (check-all-subtypep nil '(function (t) t)) nil) (deftest subtypep-function.3 (check-all-subtypep '(function (t) t) 'function) nil) (deftest subtypep-function.4 (check-all-subtypep '(function (t) integer) '(function (t) real)) nil) gcl27-2.7.0/ansi-tests/subtypep-integer.lsp000066400000000000000000000240651454061450500205710ustar00rootroot00000000000000;-*- 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) (compile-and-load "types-aux.lsp") (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) gcl27-2.7.0/ansi-tests/subtypep-member.lsp000066400000000000000000000136271454061450500204050ustar00rootroot00000000000000;-*- 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) (compile-and-load "types-aux.lsp") ;;; 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) (deftest subtypep.member.45 (check-all-subtypep `(member #c(1 6)) `(complex (or (integer 1 2) (integer 5 6)))) nil) (deftest subtypep.member.46 (check-all-not-subtypep `(member #c(1 6)) `(or (complex (integer 1 2)) (complex (integer 5 6)))) nil) (deftest subtypep.member.47 (check-all-subtypep `(member #c(1 3/2)) `(complex (rational 1 3/2))) nil) (deftest subtypep.member.48 (check-all-not-subtypep `(member #c(1 3/2)) `(complex (rational (1) 3/2))) nil) gcl27-2.7.0/ansi-tests/subtypep-rational.lsp000066400000000000000000000103351454061450500207400ustar00rootroot00000000000000;-*- 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) (compile-and-load "types-aux.lsp") ;;; 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) gcl27-2.7.0/ansi-tests/subtypep-real.lsp000066400000000000000000000105521454061450500200530ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Feb 18 18:38:55 2003 ;;;; Contains: Tests of SUBTYPEP on REAL types. (in-package :cl-test) (compile-and-load "types-aux.lsp") ;;; 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) (deftest subtypep.real.25 (check-all-subtypep t '(or (not (real 0 10)) (not (real -100 -50)))) nil) gcl27-2.7.0/ansi-tests/subtypep.lsp000066400000000000000000000115071454061450500171330ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jan 29 17:28:19 2003 ;;;; Contains: Tests of SUBTYPEP (in-package :cl-test) (compile-and-load "types-aux.lsp") ;;; 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 (signals-error (subtypep) program-error) t) (deftest subtypep.error.2 (signals-error (subtypep t) program-error) t) (deftest subtypep.error.3 (signals-error (subtypep t t nil nil) program-error) t) ;;; 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) ;;; Extended characters (deftest subtypep.extended-char.1 (if (subtypep* 'character 'base-char) (subtypep* 'extended-char nil) (values t t)) t t) (deftest subtypep.extended-char.2 (if (subtypep* 'extended-char nil) (subtypep* 'character 'base-char) (values t t)) t t) (deftest subtypep.extended-char.3 (check-equivalence 'extended-char '(and character (not base-char))) nil) ;;; Some and, or combinations (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) gcl27-2.7.0/ansi-tests/svref.lsp000066400000000000000000000022361454061450500164040ustar00rootroot00000000000000;-*- 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 (signals-error (svref) program-error) t) (deftest svref.error.2 (signals-error (svref (vector 1)) program-error) t) (deftest svref.error.3 (signals-error (svref (vector 1) 0 0) program-error) t) (deftest svref.error.4 (signals-error (svref (vector 1) 0 nil) program-error) t) gcl27-2.7.0/ansi-tests/sxhash.lsp000066400000000000000000000170331454061450500165560ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Nov 28 21:18:12 2003 ;;;; Contains: Tests of SXHASH (in-package :cl-test) (deftest sxhash.1 (check-predicate #'(lambda (x) (typep (sxhash x) '(and unsigned-byte fixnum)))) nil) (deftest sxhash.2 (loop for i from 0 below 256 for c = (code-char i) when (and c (not (= (sxhash (string c)) (sxhash (string c))))) collect c) nil) (deftest sxhash.3 (=t (sxhash "") (sxhash (copy-seq ""))) t) (deftest sxhash.4 (loop for bv1 in '(#* #*0 #*1 #*01 #*00 #*10 #*11 #*1100101101100 #*110010101011001011010000111001011) for bv2 = (copy-seq bv1) for sx1 = (sxhash bv1) for sx2 = (sxhash bv2) always (and (not (eq bv1 bv2)) (equal bv1 bv2) (typep sx1 '(and unsigned-byte fixnum)) (typep sx2 '(and unsigned-byte fixnum)) (= sx1 sx2))) t) (deftest sxhash.5 (let ((s1 "abcd") (s2 (make-array 10 :element-type 'character :initial-contents "abcdefghij" :fill-pointer 4))) (and (equalt s1 s2) (=t (sxhash s1) (sxhash s2)))) t) (deftest sxhash.6 (let ((s1 #*01101) (s2 (make-array 10 :element-type 'bit :initial-contents #*0110111101 :fill-pointer 5))) (and (equalt s1 s2) (=t (sxhash s1) (sxhash s2)))) t) (deftest sxhash.7 (let* ((a (make-array 10 :initial-element nil)) (sx1 (sxhash a))) (setf (aref a 4) 'x) (let ((sx2 (sxhash a))) (and (typep sx1 '(and unsigned-byte fixnum)) (eqlt sx1 sx2)))) t) (deftest sxhash.8 :notes (:nil-vectors-are-strings) (eqlt (sxhash (make-array 0 :element-type nil)) (sxhash "")) t) (deftest sxhash.9 (let ((s1 (make-array 5 :element-type 'base-char :initial-contents "abcde")) (s2 (copy-seq "abcde"))) (eqlt (sxhash s1) (sxhash s2))) t) (deftest sxhash.10 (let ((s1 "abcd") (s2 (make-array 10 :element-type 'base-char :initial-contents "abcdefghij" :fill-pointer 4))) (and (equalt s1 s2) (=t (sxhash s1) (sxhash s2)))) t) (deftest sxhash.11 (let* ((x (cons 'a 'b)) (sx1 (sxhash x)) (sx2 (sxhash '(a . b)))) (setf (car x) 'c) (let* ((sx3 (sxhash x)) (sx4 (sxhash '(c . b)))) (and (=t sx1 sx2) (=t sx3 sx4)))) t) (deftest sxhash.12 (let ((x (1+ most-positive-fixnum)) (y (1+ most-positive-fixnum))) (=t (sxhash x) (sxhash y))) t) (deftest sxhash.13 (let ((sx1 (sxhash (make-symbol "FOO"))) (sx2 (sxhash (make-symbol "FOO")))) (and (typep sx1 '(and unsigned-byte fixnum)) (eqlt sx1 sx2))) t) ;; (deftest sxhash.14 ;; (let ((sx1 (sxhash :foo)) ;; (sx2 (sxhash '#:foo))) ;; (and (typep sx1 '(and unsigned-byte fixnum)) ;; (eqlt sx1 sx2))) ;; t) (deftest sxhash.15 (let* ((package-name (loop for i from 0 for name = (format nil "PACKAGE-~A" i) for package = (find-package name) unless package do (return name))) (sx1 (let* ((package (make-package package-name :nicknames nil :use nil)) (symbol (intern "FOO" package))) (prog1 (sxhash symbol) (delete-package package)))) (sx2 (let* ((package (make-package package-name :nicknames nil :use nil)) (symbol (intern "FOO" package))) (prog1 (sxhash symbol) (delete-package package))))) (assert (typep sx1 '(and unsigned-byte fixnum))) (if (= sx1 sx2) :good (list sx1 sx2))) :good) (deftest sxhash.16 (let ((c1 (list 'a)) (c2 (list 'a))) (setf (cdr c1) c1) (setf (cdr c2) c2) (let ((sx1 (sxhash c1)) (sx2 (sxhash c2))) (or (eqlt sx1 sx2) (list sx1 sx2)))) t) ;;; Since similarity of numbers is 'same type and same mathematical value', ;;; and since sxhash must produce the same value for similar numeric arguments, ;;; (sxhash 0.0) and (sxhash -0.0) must be eql for all float types. ;;; This may be a spec bug, so I've added a note. (deftest sxhash.17 :notes (:negative-zero-is-similar-to-positive-zero) (loop for c1 in '(0.0s0 0.0f0 0.0d0 0.0l0) for c2 in '(-0.0s0 -0.0f0 -0.0d0 -0.0l0) for t1 = (type-of c1) for t2 = (type-of c2) for sx1 = (sxhash c1) for sx2 = (sxhash c2) unless (or (not (subtypep t1 t2)) (not (subtypep t2 t1)) (eql sx1 sx2)) collect (list c1 c2 sx1 sx2)) nil) (deftest sxhash.18 :notes (:negative-zero-is-similar-to-positive-zero) (loop for r1 in '(0.0s0 0.0f0 0.0d0 0.0l0) for c1 = (complex r1) for r2 in '(-0.0s0 -0.0f0 -0.0d0 -0.0l0) for c2 = (complex r2) for t1 = (type-of c1) for t2 = (type-of c2) for sx1 = (sxhash c1) for sx2 = (sxhash c2) unless (or (not (subtypep t1 t2)) (not (subtypep t2 t1)) (eql sx1 sx2)) collect (list c1 c2 sx1 sx2)) nil) (deftest sxhash.19 :notes (:negative-zero-is-similar-to-positive-zero) (loop for r1 in '(0.0s0 0.0f0 0.0d0 0.0l0) for c1 = (complex 0 r1) for r2 in '(-0.0s0 -0.0f0 -0.0d0 -0.0l0) for c2 = (complex 0 r2) for t1 = (type-of c1) for t2 = (type-of c2) for sx1 = (sxhash c1) for sx2 = (sxhash c2) unless (or (not (subtypep t1 t2)) (not (subtypep t2 t1)) (eql sx1 sx2)) collect (list c1 c2 sx1 sx2)) nil) ;;; Similar pathnames have the same hash (deftest sxhash.20 (let* ((pathspec "sxhash.lsp") (sx1 (sxhash (pathname (copy-seq pathspec)))) (sx2 (sxhash (pathname (copy-seq pathspec))))) (if (and (typep sx1 '(and fixnum unsigned-byte)) (eql sx1 sx2)) :good (list sx1 sx2))) :good) ;;; Similarity for strings (deftest sxhash.21 (let* ((s1 "abc") (s2 (make-array '(3) :element-type 'character :initial-contents s1)) (s3 (make-array '(3) :element-type 'base-char :initial-contents s1)) (s4 (make-array '(3) :element-type 'standard-char :initial-contents s1)) (s5 (make-array '(3) :element-type 'character :adjustable t :initial-contents "abc")) (s6 (make-array '(5) :element-type 'character :fill-pointer 3 :initial-contents "abcde")) (s7 (make-array '(3) :element-type 'character :displaced-to s2 :displaced-index-offset 0)) (s8 (make-array '(3) :element-type 'character :displaced-to (make-array '(7) :element-type 'character :initial-contents "xxabcyy") :displaced-index-offset 2)) (strings (list s1 s2 s3 s4 s5 s6 s7 s8)) (hashes (mapcar #'sxhash strings))) (if (and (every #'(lambda (h) (typep h '(and unsigned-byte fixnum))) hashes) (not (position (car hashes) hashes :test #'/=))) :good hashes)) :good) ;;; Similarity for bit vectors (deftest sxhash.22 (let* ((bv1 #*010) (bv2 (make-array '(3) :element-type 'bit :initial-contents bv1)) (bv5 (make-array '(3) :element-type 'bit :adjustable t :initial-contents bv1)) (bv6 (make-array '(5) :element-type 'bit :fill-pointer 3 :initial-contents #*01010)) (bv7 (make-array '(3) :element-type 'bit :displaced-to bv2 :displaced-index-offset 0)) (bv8 (make-array '(3) :element-type 'bit :displaced-to (make-array '(7) :element-type 'bit :initial-contents #*1101001) :displaced-index-offset 2)) (bit-vectors (list bv1 bv2 bv5 bv6 bv7 bv8)) (hashes (mapcar #'sxhash bit-vectors))) (if (and (every #'(lambda (h) (typep h '(and unsigned-byte fixnum))) hashes) (not (position (car hashes) hashes :test #'/=))) :good hashes)) :good) ;;; The hash of a symbol does not change when its package changes (deftest sxhash.23 (progn (safely-delete-package "A") (defpackage "A" (:use)) (let* ((pkg (find-package "A")) (sym (intern "FOO" pkg)) (hash (sxhash sym))) (unintern sym pkg) (let ((hash2 (sxhash sym))) (if (eql hash hash2) nil (list hash hash2))))) nil) ;;; Error cases (deftest sxhash.error.1 (signals-error (sxhash) program-error) t) (deftest sxhash.error.2 (signals-error (sxhash nil nil) program-error) t) gcl27-2.7.0/ansi-tests/symbol-function.lsp000066400000000000000000000017411454061450500204070ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jul 13 07:38:43 2004 ;;;; Contains: Tests of SYMBOL-FUNCTION (in-package :cl-test) (deftest symbol-function.1 (let ((sym (gensym)) (f #'(lambda () (values 1 2 3)))) (values (eqt (setf (symbol-function sym) f) f) (multiple-value-list (eval (list sym))))) t (1 2 3)) ;;; Error cases (deftest symbol-function.error.1 (signals-error (symbol-function) program-error) t) (deftest symbol-function.error.2 (signals-error (symbol-function 'cons nil) program-error) t) (deftest symbol-function.error.3 (check-type-error #'symbol-function #'symbolp) nil) (deftest symbol-function.error.4 (check-type-error #'(lambda (x) (setf (symbol-function x) #'identity)) #'symbolp) nil) (deftest symbol-function.error.5 (let ((sym (gensym))) (handler-case (progn (symbol-function sym) nil) (undefined-function (c) (assert (eq (cell-error-name c) sym)) :good))) :good) gcl27-2.7.0/ansi-tests/symbol-macrolet.lsp000066400000000000000000000034651454061450500203750ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 8 05:58:53 2005 ;;;; Contains: Tests of SYMBOL-MACROLET (in-package :cl-test) (deftest symbol-macrolet.1 (loop for s in *cl-non-variable-constant-symbols* for form = `(ignore-errors (symbol-macrolet ((,s 17)) ,s)) unless (eql (eval form) 17) collect s) nil) (deftest symbol-macrolet.2 (symbol-macrolet ()) nil) (deftest symbol-macrolet.3 (symbol-macrolet () (declare (optimize))) nil) (deftest symbol-macrolet.4 (symbol-macrolet ((x 1)) (symbol-macrolet ((x 2)) x)) 2) (deftest symbol-macrolet.5 (let ((x 10)) (symbol-macrolet ((y x)) (list x y (let ((x 20)) x) (let ((y 30)) x) (let ((y 50)) y) x y))) (10 10 20 10 50 10 10)) (deftest symbol-macrolet.6 (symbol-macrolet () (values))) (deftest symbol-macrolet.7 (symbol-macrolet () (values 'a 'b 'c 'd 'e)) a b c d e) (deftest symbol-macrolet.8 (let ((x :good)) (declare (special x)) (let ((x :bad)) (symbol-macrolet () (declare (special x)) x))) :good) ;;; Error tests (deftest symbol-macrolet.error.1 (signals-error (symbol-macrolet ((x 10)) (declare (special x)) 20) program-error) t) (defconstant constant-for-symbol-macrolet.error.2 nil) (deftest symbol-macrolet.error.2 (signals-error (symbol-macrolet ((constant-for-symbol-macrolet.error.2 'a)) constant-for-symbol-macrolet.error.2) program-error) t) (deftest symbol-macrolet.error.3 (signals-error (symbol-macrolet ((*pathnames* 19)) *pathnames*) program-error) t) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest symbol-macrolet.9 (macrolet ((%m (z) z)) (symbol-macrolet () (expand-in-current-env (%m :good)))) :good) gcl27-2.7.0/ansi-tests/symbol-name.lsp000066400000000000000000000011461454061450500175010ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jun 14 05:45:55 2003 ;;;; Contains: Tests of SYMBOL-NAME (in-package :cl-test) (deftest symbol-name.1 (symbol-name '|ABCD|) "ABCD") (deftest symbol-name.2 (symbol-name '|1234abcdABCD|) "1234abcdABCD") (deftest symbol-name.3 (symbol-name :|abcdefg|) "abcdefg") ;;; Error tests (deftest symbol-name.error.1 (signals-error (symbol-name) program-error) t) (deftest symbol-name.error.2 (signals-error (symbol-name 'a 'b) program-error) t) (deftest symbol-name.error.3 (check-type-error #'symbol-name #'symbolp) nil) gcl27-2.7.0/ansi-tests/symbolp.lsp000066400000000000000000000010431454061450500167370ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jun 22 08:59:12 2003 ;;;; Contains: Tests for SYMBOLP (in-package :cl-test) (deftest symbolp.1 (notnot-mv (symbolp nil)) t) (deftest symbolp.2 (check-predicate #'symbolp nil *symbols*) nil) (deftest symbolp.3 (check-predicate (complement #'symbolp) #'(lambda (x) (member x *symbols*))) nil) ;;; Error cases (deftest symbolp.error.1 (signals-error (symbolp) program-error) t) (deftest symbolp.error.2 (signals-error (symbolp nil nil) program-error) t) gcl27-2.7.0/ansi-tests/synonym-stream-symbol.lsp000066400000000000000000000010271454061450500215640ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jan 29 21:21:06 2004 ;;;; Contains: Tests of SYNONYM-STREAM-SYMBOL (in-package :cl-test) (deftest synonym-stream-symbol.1 (synonym-stream-symbol (make-synonym-stream '*standard-input*)) *standard-input*) (deftest synonym-stream-symbol.error.1 (signals-error (synonym-stream-symbol) program-error) t) (deftest synonym-stream-symbol.error.2 (signals-error (synonym-stream-symbol (make-synonym-stream '*terminal-io*) nil) program-error) t) gcl27-2.7.0/ansi-tests/syntax-tokens.lsp000066400000000000000000000063111454061450500201040ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Jan 14 07:43:24 2005 ;;;; Contains: Tests of reading of tokens (in-package :cl-test) (compile-and-load "reader-aux.lsp") ;; Erroneous numbers (def-syntax-test syntax.number-token.error.1 (signals-error (read-from-string "1/0") reader-error) t) #| (def-syntax-test syntax.number-token.error.2 (loop for f in (list most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float) for c across "sfdl" for r = (float-radix f) for x = (nth-value 1 (decode-float f)) for n = (1+ (ceiling (* (log r 10) x))) for s = (format nil "1.0~C~D" c n) for vals = (multiple-value-list (eval `(signals-error (read-from-string ,s) reader-error))) unless (equal vals '(t)) collect (list f c r x n s vals)) nil) |# (def-syntax-test syntax.number-token.3 (loop for tp in '(short-float single-float double-float long-float) for c across "sfdl" for s = (concatenate 'string "1.0" (make-string 1000 :initial-element #\0) "1" (string c) "0") for n = (read-from-string s) unless (and (typep n tp) (<= 1 n) (< n 2)) collect (list c tp s n)) nil) (def-syntax-test syntax.number-token.4 (loop for type in '(short-float single-float double-float long-float) nconc (let* ((*read-default-float-format* type) (s (concatenate 'string "1." (make-string 1000 :initial-element #\0) "1")) (n (read-from-string s))) (unless (and (typep n type) (<= 1 n) (< n 2)) (list (list type s n))))) nil) ;;; Dot tokens (def-syntax-test syntax.dot-token.1 (read-from-string "\\.") |.| 2) (def-syntax-test syntax.dot-token.2 (read-from-string ".\\.") |..| 3) (def-syntax-test syntax.dot-token.3 (read-from-string "\\..") |..| 3) (def-syntax-test syntax.dot-token.4 (read-from-string "..\\.") |...| 4) (def-syntax-test syntax.dot-token.5 (read-from-string ".\\..") |...| 4) (def-syntax-test syntax.dot-token.6 (read-from-string "\\...") |...| 4) (def-syntax-test syntax.dot-token.7 (read-from-string ".||") |.| 3) (def-syntax-test syntax.dot-token.8 (read-from-string "..||") |..| 4) (def-syntax-test syntax.dot-error.1 (signals-error (read-from-string ".") reader-error) t) (def-syntax-test syntax.dot-error.2 (signals-error (read-from-string "..") reader-error) t) (def-syntax-test syntax.dot-error.3 (signals-error (read-from-string "...") reader-error) t) (def-syntax-test syntax.dot-error.4 (signals-error (read-from-string "( . 1)") reader-error) t) (def-syntax-test syntax.dot-error.5 (signals-error (read-from-string "(1 ..)") reader-error) t) (def-syntax-test syntax.dot-error.6 (signals-error (read-from-string "(1 .. 2)") reader-error) t) (def-syntax-test syntax.dot-error.7 (signals-error (read-from-string "#(1 . 2)") reader-error) t) ;;; right paren (def-syntax-test syntax.right-paren-error.1 (signals-error (read-from-string ")") reader-error) t) (def-syntax-test syntax.comma-error.1 (signals-error (read-from-string ",") reader-error) t) (def-syntax-test syntax.comma-error.2 (signals-error (read-from-string ",1") reader-error) t) gcl27-2.7.0/ansi-tests/syntax.lsp000066400000000000000000000737331454061450500166170ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 2 08:12:51 2005 ;;;; Contains: Tests of standard syntax (in-package :cl-test) (compile-and-load "reader-aux.lsp") (def-syntax-test syntax.whitespace.1 ;; Check that various standard or semistandard characters are whitespace[2] (let ((names '("Tab" "Newline" "Linefeed" "Space" "Return" "Page"))) (loop for name in names for c = (name-char name) nconc (when c (let* ((s (concatenate 'string (string c) "123")) (val (read-from-string s))) (unless (eql val 123) (list (list name c s val))))))) nil) (def-syntax-test syntax.constituent.1 ;; Tests of various characters that they are constituent characters, ;; and parse to symbols (let ((chars (concatenate 'string "!$%&*<=>?@[]^_-{}+/" "abcdefghijklmnopqrstuvwxyz" "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))) (loop for c across chars for s = (string c) for sym = (read-from-string s) unless (string= (symbol-name sym) (string-upcase s)) collect (list c sym))) nil) ;;; Backspace is an invalid constituent character (def-syntax-test syntax.backspace.invalid (let ((c (name-char "Backspace"))) (if (not c) t (eval `(signals-error (read-from-string (string ,c)) reader-error)))) t) ;;; Rubout is an invalid constituent character (def-syntax-test syntax.rubout.invalid (let ((c (name-char "Rubout"))) (if (not c) t (eval `(signals-error (read-from-string (string ,c)) reader-error)))) t) ;;; Digits are alphabetic if >= the read base (def-syntax-test syntax.digits.alphabetic.1 (loop for base from 2 to 9 nconc (let ((*read-base* base)) (loop for digit-val from base to 9 for c = (elt "0123456789" digit-val) for s = (string c) for val = (read-from-string s) unless (and (symbolp val) (string= s (symbol-name val))) collect (list base digit-val c s val)))) nil) ;;; Reading escaped characters (def-syntax-test syntax.escaped.1 (loop for c across +standard-chars+ for s0 = (string c) for s = (concatenate 'string "\\" s0) for sym = (read-from-string s) unless (and (symbolp sym) (string= (symbol-name sym) s0)) collect (list c s0 s sym)) nil) (def-syntax-test syntax.escaped.2 (let ((count 0)) (loop for i from 0 below (min 65536 char-code-limit) for c = (code-char i) for s0 = (and c (string c)) for s = (and c (concatenate 'string "\\" s0)) for sym = (and c (read-from-string s)) unless (or (not c) (and (symbolp sym) (string= (symbol-name sym) s0))) collect (progn (when (> (incf count) 100) (loop-finish)) (list i c s0 s sym)))) nil) (def-syntax-test syntax.escaped.3 (loop for i = (random (min char-code-limit (ash 1 24))) for c = (code-char i) for s0 = (and c (string c)) for s = (and c (concatenate 'string "\\" s0)) for sym = (and c (read-from-string s)) repeat 1000 unless (or (not c) (and (symbolp sym) (string= (symbol-name sym) s0))) collect (list i c s0 s sym)) nil) (def-syntax-test syntax.escaped.4 (loop for c across +standard-chars+ for bad = (find c "\\|") for s0 = (string c) for s = (concatenate 'string "|" s0 "|") for sym = (and (not bad) (read-from-string s)) unless (or bad (and (symbolp sym) (string= (symbol-name sym) s0))) collect (list c s0 s sym)) nil) (def-syntax-test syntax.escaped.5 (let ((count 0)) (loop for i from 0 below (min 65536 char-code-limit) for c = (code-char i) for bad = (or (not c) (find c "\\|")) for s0 = (and c (string c)) for s = (and c (concatenate 'string "|" s0 "|")) for sym = (and c (not bad) (read-from-string s)) unless (or bad (and (symbolp sym) (string= (symbol-name sym) s0))) collect (progn (when (> (incf count) 100) (loop-finish)) (list c s0 s sym)))) nil) (def-syntax-test syntax.escaped.6 (loop for i = (random (min char-code-limit (ash 1 24))) for c = (code-char i) for bad = (or (not c) (find c "\\|")) for s0 = (and c (string c)) for s = (and c (concatenate 'string "|" s0 "|")) for sym = (and (not bad) (read-from-string s)) repeat 1000 unless (or bad (and (symbolp sym) (string= (symbol-name sym) s0))) collect (list c s0 s sym)) nil) (def-syntax-test syntax.escape.whitespace.1 (let ((names '("Tab" "Newline" "Linefeed" "Space" "Return" "Page" "Rubout" "Backspace"))) (loop for name in names for c = (name-char name) nconc (when c (let* ((s (concatenate 'string "\\" (string c))) (val (read-from-string s))) (unless (eql val (intern (string c))) (list (list name c s val))))))) nil) ;;; ;;; CLtS appears to be inconsistent on the next test. ;;; Compare the definition of 'invalid' with the specification ;;; of the token reading algorithm. ;;; (def-syntax-test syntax.escape.whitespace.2 (let ((names '("Tab" "Newline" "Linefeed" "Space" "Return" "Page"))) (loop for name in names for c = (name-char name) nconc (when c (let* ((s (concatenate 'string "|" (string c) "|")) (val (read-from-string s))) (unless (eql val (intern (string c))) (list (list name c s val))))))) nil) #| (def-syntax-test syntax.multiple-escape.invalid.backspace (let ((c (name-char "Backspace"))) (or (not c) (let ((s (concatenate 'string "|" (string c) "|"))) (eval `(signals-error (read-from-string ',s) reader-error))))) t) (def-syntax-test syntax.multiple-escape.invalid.rubout (let ((c (name-char "Rubout"))) (or (not c) (let ((s (concatenate 'string "|" (string c) "|"))) (eval `(signals-error (read-from-string ',s) reader-error))))) t) |# ;;; Tests of #\ (def-syntax-test syntax.sharp-backslash.1 (loop for c across +standard-chars+ for s = (concatenate 'string "#\\" (string c)) for c2 = (read-from-string s) unless (eql c c2) collect (list c s c2)) nil) (def-syntax-test syntax.sharp-backslash.2 (let ((count 0)) (loop for i below (min 65536 char-code-limit) for c = (code-char i) for s = (and c (concatenate 'string "#\\" (string c))) for c2 = (and c (read-from-string s)) unless (eql c c2) collect (progn (when (> (incf count) 100) (loop-finish)) (list c s c2)))) nil) (def-syntax-test syntax.sharp-backslash.3 (loop for i = (random (min (ash 1 24) char-code-limit)) for c = (code-char i) for s = (and c (concatenate 'string "#\\" (string c))) for c2 = (and c (read-from-string s)) repeat 1000 unless (eql c c2) collect (list i c s c2)) nil) (def-syntax-test syntax.sharp-backslash.4 (flet ((%f (s) (read-from-string (concatenate 'string "#\\" s)))) (loop for s in '("SPACE" "NEWLINE" "TAB" "RUBOUT" "BACKSPACE" "PAGE" "LINEFEED" "RETURN") for c = (name-char s) unless (or (null c) (and (eql (%f s) c) (eql (%f (string-downcase s)) c) (eql (%f (string-capitalize s)) c))) collect (list s c))) nil) (def-syntax-test syntax.sharp-backslash.5 (flet ((%f (s) (read-from-string (concatenate 'string "#\\" s)))) (let ((good-chars (concatenate 'string +alphanumeric-chars+ "<,.>\"':/?[]{}~`!@#$%^&*_-+="))) (loop for c across +standard-chars+ for name = (char-name c) unless (or (null name) (string/= "" (string-trim good-chars name)) (and (eql (%f name) c) (eql (%f (string-downcase name)) c) (eql (%f (string-upcase name)) c) (eql (%f (string-capitalize name)) c))) collect (list c name)))) nil) (def-syntax-test syntax.sharp-backslash.6 (flet ((%f (s) (read-from-string (concatenate 'string "#\\" s)))) (let ((good-chars (concatenate 'string +alphanumeric-chars+ "<,.>\"':/?[]{}~`!@#$%^&*_-+="))) (loop for i below (min 65536 char-code-limit) for c = (code-char i) for name = (and c (char-name c)) unless (or (null name) (string/= "" (string-trim good-chars name)) (and (eql (%f name) c) (eql (%f (string-downcase name)) c) (eql (%f (string-upcase name)) c) (eql (%f (string-capitalize name)) c))) collect (list i c name)))) nil) (def-syntax-test syntax.sharp-backslash.7 (flet ((%f (s) (read-from-string (concatenate 'string "#\\" s)))) (let ((good-chars (concatenate 'string +alphanumeric-chars+ "<,.>\"':/?[]{}~`!@#$%^&*_-+="))) (loop for i = (random (min (ash 1 24) char-code-limit)) for c = (code-char i) for name = (and c (char-name c)) repeat 1000 unless (or (null name) (string/= "" (string-trim good-chars name)) (and (eql (%f name) c) (eql (%f (string-downcase name)) c) (eql (%f (string-upcase name)) c) (eql (%f (string-capitalize name)) c))) collect (list i c name)))) nil) ;;; Tests of #' (def-syntax-test syntax.sharp-quote.1 (read-from-string "#'X") (function |X|) 3) (def-syntax-test syntax.sharp-quote.2 (read-from-string "#':X") (function :|X|) 4) (def-syntax-test syntax.sharp-quote.3 (read-from-string "#'17") (function 17) 4) (def-syntax-test syntax.sharp-quote.error.1 (signals-error (read-from-string "#'") end-of-file) t) (def-syntax-test syntax.sharp-quote.error.2 (signals-error (read-from-string "(#'" nil nil) end-of-file) t) ;;; Tess of #(...) (def-syntax-vector-test syntax.sharp-left-paren.1 "#()") (def-syntax-vector-test syntax.sharp-left-paren.2 "#0()") (def-syntax-vector-test syntax.sharp-left-paren.3 "#(a)" a) (def-syntax-vector-test syntax.sharp-left-paren.4 "#(a b c)" a b c) (def-syntax-vector-test syntax.sharp-left-paren.5 "#2(a)" a a) (def-syntax-vector-test syntax.sharp-left-paren.6 "#5(a b)" a b b b b) (def-syntax-vector-test syntax.sharp-left-paren.7 "#5(a b c d e)" a b c d e) (def-syntax-vector-test syntax.sharp-left-paren.8 "#9(a b c d e)" a b c d e e e e e) (def-syntax-test syntax.sharp-left-paren.9 (let ((*read-base* 2)) (read-from-string "#10(a)")) #(a a a a a a a a a a) 6) (def-syntax-test syntax.sharp-left-paren.error.1 (signals-error (read-from-string "#(") end-of-file) t) (def-syntax-test syntax.sharp-left-paren.error.2 (signals-error (read-from-string "(#(" nil nil) end-of-file) t) ;;; Tests of #* (def-syntax-bit-vector-test syntax.sharp-asterisk.1 "#*") (def-syntax-bit-vector-test syntax.sharp-asterisk.2 "#0*") (def-syntax-bit-vector-test syntax.sharp-asterisk.3 "#1*0" 0) (def-syntax-bit-vector-test syntax.sharp-asterisk.4 "#1*1" 1) (def-syntax-bit-vector-test syntax.sharp-asterisk.5 "#2*1" 1 1) (def-syntax-bit-vector-test syntax.sharp-asterisk.6 "#2*0" 0 0) (def-syntax-bit-vector-test syntax.sharp-asterisk.7 "#5*010" 0 1 0 0 0) (def-syntax-bit-vector-test syntax.sharp-asterisk.8 "#7*0101" 0 1 0 1 1 1 1) (def-syntax-bit-vector-test syntax.sharp-asterisk.9 "#10*01010" 0 1 0 1 0 0 0 0 0 0) (def-syntax-test syntax.sharp-asterisk.10 (let ((*read-base* 3)) (read-from-string "#10*01")) #*0111111111 6) (def-syntax-test syntax.sharp-asterisk.11 (let ((*read-suppress* t)) (values (read-from-string "#1* "))) nil) (def-syntax-test syntax.sharp-asterisk.12 (let ((*read-suppress* t)) (values (read-from-string "#1*00"))) nil) (def-syntax-test syntax.sharp-asterisk.13 (let ((*read-suppress* t)) (values (read-from-string "#*012"))) nil) (def-syntax-test syntax.sharp-asterisk.error.1 (signals-error (read-from-string "#1* X") reader-error) t) (def-syntax-test syntax.sharp-asterisk.error.2 (signals-error (read-from-string "#2*011") reader-error) t) (def-syntax-test syntax.sharp-asterisk.error.3 (signals-error (read-from-string "#*012") reader-error) t) ;;; Tests of #: ... ; (def-syntax-unintern-test syntax.sharp-colon.1 "") ; (def-syntax-unintern-test syntax.sharp-colon.2 "#") (def-syntax-unintern-test syntax.sharp-colon.3 "a") (def-syntax-unintern-test syntax.sharp-colon.4 "A") (def-syntax-unintern-test syntax.sharp-colon.5 "NIL") (def-syntax-unintern-test syntax.sharp-colon.6 "T") (def-syntax-unintern-test syntax.sharp-colon.7 ".") ;;; Tests of #. (def-syntax-test syntax.sharp-dot.1 (read-from-string "#.(+ 1 2)") 3 9) (def-syntax-test syntax.sharp-dot.2 (read-from-string "#.'X") X 4) (def-syntax-test syntax.sharp-dot.error.1 (signals-error (read-from-string "#.") end-of-file) t) (def-syntax-test syntax.sharp-dot.error.2 (signals-error (read-from-string "(#." nil nil) end-of-file) t) (def-syntax-test syntax.sharp-dot.error.3 (signals-error (let ((*read-eval* nil)) (read-from-string "#.1")) reader-error) t) ;;; Tests of #B (def-syntax-test syntax.sharp-b.1 (read-from-string "#b0") 0 3) (def-syntax-test syntax.sharp-b.2 (read-from-string "#B1") 1 3) (def-syntax-test syntax.sharp-b.3 (read-from-string "#b101101") 45 8) (def-syntax-test syntax.sharp-b.4 (read-from-string "#B101101") 45 8) (def-syntax-test syntax.sharp-b.5 (read-from-string "#b010001/100") 17/4 12) (def-syntax-test syntax.sharp-b.6 (read-from-string "#b-10011") -19 8) (def-syntax-test syntax.sharp-b.7 (read-from-string "#B-1/10") -1/2 7) (def-syntax-test syntax.sharp-b.8 (read-from-string "#B-0/10") 0 7) (def-syntax-test syntax.sharp-b.9 (read-from-string "#b0/111") 0 7) (def-syntax-test syntax.sharp-b.10 (let ((*read-eval* nil)) (read-from-string "#b-10/11")) -2/3 8) ;;; Tests of #O (def-syntax-test syntax.sharp-o.1 (read-from-string "#o0") 0 3) (def-syntax-test syntax.sharp-o.2 (read-from-string "#O7") 7 3) (def-syntax-test syntax.sharp-o.3 (read-from-string "#o10") 8 4) (def-syntax-test syntax.sharp-o.4 (read-from-string "#O011") 9 5) (def-syntax-test syntax.sharp-o.5 (read-from-string "#o-0") 0 4) (def-syntax-test syntax.sharp-o.6 (read-from-string "#O-1") -1 4) (def-syntax-test syntax.sharp-o.7 (read-from-string "#O11/10") 9/8 7) (def-syntax-test syntax.sharp-o.8 (read-from-string "#o-1/10") -1/8 7) (def-syntax-test syntax.sharp-o.9 (read-from-string "#O0/10") 0 6) (def-syntax-test syntax.sharp-o.10 (let ((*read-eval* nil)) (read-from-string "#o-10/11")) -8/9 8) ;;; Tests of #X (def-syntax-test syntax.sharp-x.1 (read-from-string "#x0") 0 3) (def-syntax-test syntax.sharp-x.2 (read-from-string "#X1") 1 3) (def-syntax-test syntax.sharp-x.3 (read-from-string "#xa") 10 3) (def-syntax-test syntax.sharp-x.4 (read-from-string "#Xb") 11 3) (def-syntax-test syntax.sharp-x.5 (read-from-string "#XC") 12 3) (def-syntax-test syntax.sharp-x.6 (read-from-string "#xD") 13 3) (def-syntax-test syntax.sharp-x.7 (read-from-string "#xe") 14 3) (def-syntax-test syntax.sharp-x.8 (read-from-string "#Xf") 15 3) (def-syntax-test syntax.sharp-x.9 (read-from-string "#x10") 16 4) (def-syntax-test syntax.sharp-x.10 (read-from-string "#X1ab") 427 5) (def-syntax-test syntax.sharp-x.11 (read-from-string "#x-1") -1 4) (def-syntax-test syntax.sharp-x.12 (read-from-string "#X-0") 0 4) (def-syntax-test syntax.sharp-x.13 (read-from-string "#xa/B") 10/11 5) (def-syntax-test syntax.sharp-x.14 (read-from-string "#X-1/1c") -1/28 7) (def-syntax-test syntax.sharp-x.15 (let ((*read-eval* nil)) (read-from-string "#x-10/11")) -16/17 8) ;;; Tests of #nR (def-syntax-test syntax.sharp-r.1 (loop for i = (random (ash 1 (+ 2 (random 32)))) for base = (+ 2 (random 35)) for s = (write-to-string i :radix nil :base base :readably nil) for c = (random-from-seq "rR") for s2 = (format nil "#~d~c~a" base c s) for s3 = (rcase (1 (string-upcase s2)) (1 (string-downcase s2)) (1 (string-capitalize s2)) (1 s2)) for base2 = (+ 2 (random 35)) for vals = (let ((*read-base* base2)) (multiple-value-list (read-from-string s3))) repeat 1000 unless (equal vals (list i (length s3) )) collect (list i base s c s2 s3 base2 vals)) nil) (def-syntax-test syntax.sharp-r.2 (read-from-string "#2r0") 0 4) (def-syntax-test syntax.sharp-r.3 (read-from-string "#36r0") 0 5) (def-syntax-test syntax.sharp-r.4 (read-from-string "#29R-0") 0 6) (def-syntax-test syntax.sharp-r.5 (read-from-string "#23r-1") -1 6) (def-syntax-test syntax.sharp-r.6 (read-from-string "#17r11") 18 6) (def-syntax-test syntax.sharp-t.7 (read-from-string "#3r10/11") 3/4 8) (def-syntax-test syntax.sharp-t.8 (read-from-string "#5R-10/11") -5/6 9) ;;; Tests of #c (def-syntax-test syntax.sharp-c.1 (read-from-string "#c(1 1)") #.(complex 1 1) 7) (def-syntax-test syntax.sharp-c.2 (read-from-string "#C(1 0)") 1 7) (def-syntax-test syntax.sharp-c.3 (read-from-string "#c(0 1)") #.(complex 0 1) 7) (def-syntax-test syntax.sharp-c.4 (read-from-string "#c(-1/2 1)") #.(complex -1/2 1) 10) (def-syntax-test syntax.sharp-c.5 (read-from-string "#c (1 1)") #.(complex 1 1) 8) (def-syntax-test syntax.sharp-c.6 (loop for format in '(short-float single-float double-float long-float) for c = (let ((*read-default-float-format* format)) (read-from-string "#c(1.0 0.0)")) unless (eql c (complex (coerce 1 format) (coerce 0 format))) collect (list format c)) nil) (def-syntax-test syntax.sharp-c.7 (loop for format in '(short-float single-float double-float long-float) for c = (let ((*read-default-float-format* format)) (read-from-string "#C(0.0 1.0)")) unless (eql c (complex (coerce 0 format) (coerce 1 format))) collect (list format c)) nil) ;;; Tests of #a (def-syntax-array-test syntax.sharp-a.1 "#0anil" (make-array nil :initial-element nil)) (def-syntax-array-test syntax.sharp-a.2 "#0a1" (make-array nil :initial-element 1)) (def-syntax-array-test syntax.sharp-a.3 "#1a(1 2 3 5)" (make-array '(4) :initial-contents '(1 2 3 5))) (def-syntax-array-test syntax.sharp-a.4 "#1a\"abcd\"" (make-array '(4) :initial-contents '(#\a #\b #\c #\d))) (def-syntax-array-test syntax.sharp-a.5 "#1a#1a(:a :b :c)" (make-array '(3) :initial-contents '(:a :b :c))) (def-syntax-array-test syntax.sharp-a.6 "#1a#.(coerce \"abcd\" 'simple-base-string)" (make-array '(4) :initial-contents '(#\a #\b #\c #\d))) (def-syntax-array-test syntax.sharp-a.7 "#1a#*000110" (make-array '(6) :initial-contents '(0 0 0 1 1 0))) (def-syntax-array-test syntax.sharp-a.8 "#1a#.(make-array 4 :element-type '(unsigned-byte 8) :initial-contents '(1 2 3 5))" (make-array '(4) :initial-contents '(1 2 3 5))) (def-syntax-array-test syntax.sharp-a.9 "#1a#.(make-array 4 :element-type '(unsigned-byte 4) :initial-contents '(1 2 3 5))" (make-array '(4) :initial-contents '(1 2 3 5))) (def-syntax-array-test syntax.sharp-a.10 "#1a#.(make-array 4 :element-type '(signed-byte 4) :initial-contents '(1 2 3 5))" (make-array '(4) :initial-contents '(1 2 3 5))) (def-syntax-array-test syntax.sharp-a.11 "#1a#.(make-array 4 :element-type '(signed-byte 8) :initial-contents '(1 2 3 5))" (make-array '(4) :initial-contents '(1 2 3 5))) (def-syntax-array-test syntax.sharp-a.12 "#1a#.(make-array 4 :element-type '(unsigned-byte 16) :initial-contents '(1 2 3 5))" (make-array '(4) :initial-contents '(1 2 3 5))) (def-syntax-array-test syntax.sharp-a.13 "#1a#.(make-array 4 :element-type '(signed-byte 16) :initial-contents '(1 2 3 5))" (make-array '(4) :initial-contents '(1 2 3 5))) (def-syntax-array-test syntax.sharp-a.14 "#1a#.(make-array 4 :element-type '(unsigned-byte 32) :initial-contents '(1 2 3 5))" (make-array '(4) :initial-contents '(1 2 3 5))) (def-syntax-array-test syntax.sharp-a.15 "#1a#.(make-array 4 :element-type '(signed-byte 32) :initial-contents '(1 2 3 5))" (make-array '(4) :initial-contents '(1 2 3 5))) (def-syntax-array-test syntax.sharp-a.16 "#1a#.(make-array 4 :element-type 'fixnum :initial-contents '(1 2 3 5))" (make-array '(4) :initial-contents '(1 2 3 5))) (def-syntax-array-test syntax.sharp-a.17 "#1anil" (make-array '(0))) (def-syntax-array-test syntax.sharp-a.18 "#2anil" (make-array '(0 0))) (def-syntax-array-test syntax.sharp-a.19 "#2a((2))" (make-array '(1 1) :initial-element 2)) (def-syntax-array-test syntax.sharp-a.20 "#2a((1 2 3)(4 5 6))" (make-array '(2 3) :initial-contents #(#(1 2 3) #(4 5 6)))) (def-syntax-array-test syntax.sharp-a.21 "#2a#(#(1 2 3)#(4 5 6))" (make-array '(2 3) :initial-contents '((1 2 3) (4 5 6)))) (def-syntax-array-test syntax.sharp-a.22 "#2a\"\"" (make-array '(0 0))) (def-syntax-array-test syntax.sharp-a.23 "#2a#*" (make-array '(0 0))) (def-syntax-array-test syntax.sharp-a.24 "#1a#.(make-array '(10) :fill-pointer 5 :initial-element 17)" (make-array '(5) :initial-contents '(17 17 17 17 17))) (def-syntax-array-test syntax.sharp-a.25 "#1a#.(make-array '(5) :adjustable t :initial-element 17)" (make-array '(5) :initial-contents '(17 17 17 17 17))) (def-syntax-array-test syntax.sharp-a.26 "#1A#.(let ((x (make-array '(10) :adjustable t :initial-contents '(1 2 3 4 5 6 7 8 9 10)))) (make-array '(5) :displaced-to x :displaced-index-offset 2))" (make-array '(5) :initial-contents '(3 4 5 6 7))) ;;; Tests of #S (unless (find-class 'syntax-test-struct-1 nil) (defstruct syntax-test-struct-1 a b c)) (def-syntax-test syntax.sharp-s.1 (let ((v (read-from-string "#s(syntax-test-struct-1)"))) (values (notnot (typep v 'syntax-test-struct-1)) (syntax-test-struct-1-a v) (syntax-test-struct-1-b v) (syntax-test-struct-1-c v))) t nil nil nil) (def-syntax-test syntax.sharp-s.2 (let ((v (read-from-string "#S(syntax-test-struct-1 :a x :c y :b z)"))) (values (notnot (typep v 'syntax-test-struct-1)) (syntax-test-struct-1-a v) (syntax-test-struct-1-b v) (syntax-test-struct-1-c v))) t x z y) (def-syntax-test syntax.sharp-s.3 (let ((v (read-from-string "#s(syntax-test-struct-1 \"A\" x)"))) (values (notnot (typep v 'syntax-test-struct-1)) (syntax-test-struct-1-a v) (syntax-test-struct-1-b v) (syntax-test-struct-1-c v))) t x nil nil) (def-syntax-test syntax.sharp-s.4 (let ((v (read-from-string "#S(syntax-test-struct-1 #\\A x)"))) (values (notnot (typep v 'syntax-test-struct-1)) (syntax-test-struct-1-a v) (syntax-test-struct-1-b v) (syntax-test-struct-1-c v))) t x nil nil) (def-syntax-test syntax.sharp-s.5 (let ((v (read-from-string "#s(syntax-test-struct-1 :a x :a y)"))) (values (notnot (typep v 'syntax-test-struct-1)) (syntax-test-struct-1-a v) (syntax-test-struct-1-b v) (syntax-test-struct-1-c v))) t x nil nil) (def-syntax-test syntax.sharp-s.6 (let ((v (read-from-string "#S(syntax-test-struct-1 :a x :allow-other-keys 1)"))) (values (notnot (typep v 'syntax-test-struct-1)) (syntax-test-struct-1-a v) (syntax-test-struct-1-b v) (syntax-test-struct-1-c v))) t x nil nil) (def-syntax-test syntax.sharp-s.7 (let ((v (read-from-string "#s(syntax-test-struct-1 :b z :allow-other-keys nil)"))) (values (notnot (typep v 'syntax-test-struct-1)) (syntax-test-struct-1-a v) (syntax-test-struct-1-b v) (syntax-test-struct-1-c v))) t nil z nil) (def-syntax-test syntax.sharp-s.8 (let ((v (read-from-string "#S(syntax-test-struct-1 :b z :allow-other-keys t :a x :foo bar)"))) (values (notnot (typep v 'syntax-test-struct-1)) (syntax-test-struct-1-a v) (syntax-test-struct-1-b v) (syntax-test-struct-1-c v))) t x z nil) (def-syntax-test syntax.sharp-s.9 (let ((v (read-from-string "#s(syntax-test-struct-1 a x c y b z :a :bad :b bad2 :c bad3)"))) (values (notnot (typep v 'syntax-test-struct-1)) (syntax-test-struct-1-a v) (syntax-test-struct-1-b v) (syntax-test-struct-1-c v))) t x z y) (def-syntax-test syntax.sharp-s.10 (let ((v (read-from-string "#S(syntax-test-struct-1 #:a x #:c y #:b z)"))) (values (notnot (typep v 'syntax-test-struct-1)) (syntax-test-struct-1-a v) (syntax-test-struct-1-b v) (syntax-test-struct-1-c v))) t x z y) ;; (Put more tests of this in the structure tests) ;;; Tests of #P (def-syntax-test syntax.sharp-p.1 (read-from-string "#p\"\"") #.(parse-namestring "") 4) (def-syntax-test syntax.sharp-p.2 (read-from-string "#P\"syntax.lsp\"") #.(parse-namestring "syntax.lsp") 14) (def-syntax-test syntax.sharp-p.3 (read-from-string "#P \"syntax.lsp\"") #.(parse-namestring "syntax.lsp") 15) (def-syntax-test syntax.sharp-p.4 (let ((*read-eval* nil)) (read-from-string "#p\"syntax.lsp\"")) #.(parse-namestring "syntax.lsp") 14) (def-syntax-test syntax.sharp-p.5 (read-from-string "#P#.(make-array '(10) :initial-contents \"syntax.lsp\" :element-type 'base-char)") #.(parse-namestring "syntax.lsp") 78) ;;; ## and #= (def-syntax-test syntax.sharp-circle.1 (let ((x (read-from-string "(#1=(17) #1#)"))) (assert (eq (car x) (cadr x))) x) ((17) (17))) (def-syntax-test syntax.sharp-circle.2 (let ((x (read-from-string "(#0=(17) #0#)"))) (assert (eq (car x) (cadr x))) x) ((17) (17))) (def-syntax-test syntax.sharp-circle.3 (let ((x (read-from-string "(#123456789123456789=(17) #123456789123456789#)"))) (assert (eq (car x) (cadr x))) x) ((17) (17))) (def-syntax-test syntax.sharp-circle.4 (let ((x (read-from-string "#1=(A B . #1#)"))) (assert (eq (cddr x) x)) (values (car x) (cadr x))) a b) (def-syntax-test syntax.sharp-circle.5 (let ((x (read-from-string "#1=#(A B #1#)"))) (assert (typep x '(simple-vector 3))) (assert (eq (elt x 2) x)) (values (elt x 0) (elt x 1))) a b) (def-syntax-test syntax.sharp-circle.6 (let ((x (read-from-string "((#1=(17)) #1#)"))) (assert (eq (caar x) (cadr x))) x) (((17)) (17))) (def-syntax-test syntax.sharp-circle.7 (let ((x (read-from-string "((#1=#2=(:x)) #1# #2#)"))) (assert (eq (caar x) (cadr x))) (assert (eq (caar x) (caddr x))) x) (((:x)) (:x) (:x))) ;;; #+ (def-syntax-test syntax.sharp-plus.1 (let ((*features* nil)) (read-from-string "#+X :bad :good")) :good 14) (def-syntax-test syntax.sharp-plus.2 (let ((*features* '(:a :x :b))) (read-from-string "#+X :good :bad")) :good 10) (def-syntax-test syntax.sharp-plus.3 (let ((*features* '(:a :x :b))) (read-from-string "#+:x :good :bad")) :good 11) (def-syntax-test syntax.sharp-plus.4 (let ((*features* '(:a :x :b))) (read-from-string "#+(and):good :bad")) :good 13) (def-syntax-test syntax.sharp-plus.5 (let ((*features* '(:a :x :b))) (read-from-string "#+(:and):good :bad")) :good 14) (def-syntax-test syntax.sharp-plus.6 (let ((*features* '(:a :x :b))) (read-from-string "#+(or) :bad :good")) :good 17) (def-syntax-test syntax.sharp-plus.7 (let ((*features* '(:a :x :b))) (read-from-string "#+(:or) :bad :good")) :good 18) (def-syntax-test syntax.sharp-plus.8 (let ((*features* '(x))) (read-from-string "#+X :bad :good")) :good 14) (def-syntax-test syntax.sharp-plus.9 (let ((*features* '(x))) (read-from-string "#+CL-TEST::X :good :bad")) :good 19) (def-syntax-test syntax.sharp-plus.10 (let ((*features* nil)) (read-from-string "#+(not x) :good :bad")) :good 16) (def-syntax-test syntax.sharp-plus.11 (let ((*features* '(:x))) (read-from-string "#+(not x) :bad :good")) :good 20) (def-syntax-test syntax.sharp-plus.12 (let ((*features* nil)) (read-from-string "#+(:not :x) :good :bad")) :good 18) (def-syntax-test syntax.sharp-plus.13 (let ((*features* '(:a :x :b))) (read-from-string "#+(and a b) :good :bad")) :good 18) (def-syntax-test syntax.sharp-plus.14 (let ((*features* '(:a :x :b))) (read-from-string "#+(and a c) :bad :good")) :good 22) (def-syntax-test syntax.sharp-plus.15 (let ((*features* '(:a :x :b))) (read-from-string "#+(or c b) :good :bad")) :good 17) (def-syntax-test syntax.sharp-plus.16 (let ((*features* '(:a :x :b))) (read-from-string "#+(or c d) :bad :good")) :good 21) ;;; Tests of #| |# (def-syntax-test syntax.sharp-bar.1 (read-from-string "#||#1") 1 5) (def-syntax-test syntax.sharp-bar.2 (read-from-string "1#||#2") |1##2| 6) (def-syntax-test syntax.sharp-bar.3 (read-from-string "#| #| |# |#1") 1 12) (def-syntax-test syntax.sharp-bar.4 (read-from-string "#| ; |#1") 1 8) (def-syntax-test syntax.sharp-bar.5 (read-from-string "#| ( |#1") 1 8) (def-syntax-test syntax.sharp-bar.6 (read-from-string "#| # |#1") 1 8) (def-syntax-test syntax.sharp-bar.7 (read-from-string "#| .. |#1") 1 9) (def-syntax-test syntax.sharp-bar.8 (loop for c across +standard-chars+ for s = (concatenate 'string "\#| " (string c) " |\#1") for vals = (multiple-value-list (read-from-string s)) unless (equal vals '(1 8)) collect (list c s vals)) nil) (def-syntax-test syntax.sharp-bar.9 (loop for i below (min (ash 1 16) char-code-limit) for c = (code-char i) for s = (and c (concatenate 'string "\#| " (string c) " |\#1")) for vals = (and c (multiple-value-list (read-from-string s))) unless (or (not c) (equal vals '(1 8))) collect (list i c s vals)) nil) (def-syntax-test syntax.sharp-bar.10 (loop for i = (random (min (ash 1 24) char-code-limit)) for c = (code-char i) for s = (and c (concatenate 'string "\#| " (string c) " |\#1")) for vals = (and c (multiple-value-list (read-from-string s))) repeat 1000 unless (or (not c) (equal vals '(1 8))) collect (list i c s vals)) nil) ;;;; Various error cases (def-syntax-test syntax.sharp-whitespace.1 (let ((names '("Tab" "Newline" "Linefeed" "Space" "Return" "Page"))) (loop for name in names for c = (name-char name) when c nconc (let* ((form `(signals-error (read-from-string ,(concatenate 'string "#" (string c))) reader-error)) (vals (multiple-value-list (eval form)))) (unless (equal vals '(t)) (list (list name c form vals)))))) nil) (def-syntax-test syntax.sharp-less-than.1 (signals-error (read-from-string "#<" nil nil) reader-error) t) (def-syntax-test syntax.sharp-close-paren.1 (signals-error (read-from-string "#)" nil nil) reader-error) t) (def-syntax-test syntax.single-escape-eof.1 (signals-error (read-from-string "\\") end-of-file) t) (def-syntax-test syntax.single-escape-eof.2 (signals-error (read-from-string "\\" nil nil) end-of-file) t) (def-syntax-test syntax.multiple-escape-eof.1 (signals-error (read-from-string "|") end-of-file) t) (def-syntax-test syntax.multiple-escape-eof.2 (signals-error (read-from-string "|" nil nil) end-of-file) t) gcl27-2.7.0/ansi-tests/t.lsp000066400000000000000000000006021454061450500155150ustar00rootroot00000000000000;-*- 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 gcl27-2.7.0/ansi-tests/tagbody.lsp000066400000000000000000000055061454061450500167130ustar00rootroot00000000000000;-*- 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) ;;; Check that macros are not expanded before finding tags ;;; Test for issue TAGBODY-TAG-EXPANSION (deftest tagbody.17 (block done (tagbody (macrolet ((foo () 'tag)) (let (tag) (tagbody (go tag) (foo) (return-from done :bad)))) tag (return-from done :good))) :good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest tagbody.18 (macrolet ((%m (z) z)) (tagbody (expand-in-current-env (%m :foo)))) nil) gcl27-2.7.0/ansi-tests/tailp.lsp000066400000000000000000000040631454061450500163700ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:47:26 2003 ;;;; Contains: Tests of TAILP (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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 (signals-error (tailp) program-error) t) (deftest tailp.error.6 (signals-error (tailp nil) program-error) t) (deftest tailp.error.7 (signals-error (tailp nil nil nil) program-error) t) ;; 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) gcl27-2.7.0/ansi-tests/tan.lsp000066400000000000000000000056351454061450500160470ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Feb 9 20:55:40 2004 ;;;; Contains: Tests of TAN (in-package :cl-test) (deftest tan.1 (loop for i from -1000 to 1000 for rlist = (multiple-value-list (tan i)) for y = (car rlist) always (and (null (cdr rlist)) (or (rationalp y) (typep y 'single-float)))) t) (deftest tan.2 (loop for x = (- (random 2000.0s0) 1000.0s0) for y = (safe-tan x 0.0s0) repeat 1000 always (typep y 'short-float)) t) (deftest tan.3 (loop for x = (- (random 2000.0f0) 1000.0f0) for y = (safe-tan x 0.0) repeat 1000 always (typep y 'single-float)) t) (deftest tan.4 (loop for x = (- (random 2000.0d0) 1000.0d0) for y = (safe-tan x 0.0d0) repeat 1000 always (typep y 'double-float)) t) (deftest tan.5 (loop for x = (- (random 2000.0l0) 1000.0l0) for y = (safe-tan 0.0l0) repeat 1000 always (typep y 'long-float)) t) (deftest tan.6 (let ((r (tan 0))) (or (eqlt r 0) (eqlt r 0.0))) t) (deftest tan.7 (tan 0.0s0) 0.0s0) (deftest tan.8 (tan 0.0) 0.0) (deftest tan.9 (tan 0.0d0) 0.0d0) (deftest tan.10 (tan 0.0l0) 0.0l0) (deftest tan.11 (loop for i from 1 to 100 unless (approx= (tan i) (tan (coerce i 'single-float))) collect i) nil) (deftest tan.12 (approx= (tan (coerce (/ pi 4) 'single-float)) 1.0) t) (deftest tan.13 (approx= (tan (coerce (/ pi -4) 'single-float)) -1.0) t) (deftest tan.14 (approx= (tan (coerce (/ pi 4) 'short-float)) 1s0) t) (deftest tan.15 (approx= (tan (coerce (/ pi -4) 'short-float)) -1s0) t) (deftest tan.16 (approx= (tan (coerce (/ pi 4) 'double-float)) 1d0) t) (deftest tan.17 (approx= (tan (coerce (/ pi -4) 'double-float)) -1d0) t) (deftest tan.18 (approx= (tan (coerce (/ pi 4) 'long-float)) 1l0) t) (deftest tan.19 (approx= (tan (coerce (/ pi -4) 'long-float)) -1l0) t) (deftest tan.20 (loop for r = (- (random 2000) 1000) for i = (- (random 20) 10) for y = (safe-tan (complex r i)) repeat 1000 always (numberp y)) t) (deftest tan.21 (loop for r = (- (random 2000.0s0) 1000.0s0) for i = (- (random 20.0s0) 10.0s0) for y = (safe-tan (complex r i)) repeat 1000 always (numberp y)) t) (deftest tan.22 (loop for r = (- (random 2000.0f0) 1000.0f0) for i = (- (random 20.0f0) 10.0f0) for y = (safe-tan (complex r i)) repeat 1000 always (numberp y)) t) (deftest tan.23 (loop for r = (- (random 2000.0d0) 1000.0d0) for i = (- (random 20.0d0) 10.0d0) for y = (safe-tan (complex r i)) repeat 1000 always (numberp y)) t) (deftest tan.24 (loop for r = (- (random 2000.0l0) 1000.0l0) for i = (- (random 20.0l0) 10.0l0) for y = (safe-tan (complex r i)) repeat 1000 always (numberp y)) t) ;;; FIXME ;;; More accuracy tests here ;;; Error tests (deftest tan.error.1 (signals-error (tan) program-error) t) (deftest tan.error.2 (signals-error (tan 0.0 0.0) program-error) t) (deftest tan.error.3 (check-type-error #'tan #'numberp) nil) gcl27-2.7.0/ansi-tests/tanh.lsp000066400000000000000000000035651454061450500162170ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Feb 11 19:16:35 2004 ;;;; Contains: Tests of TANH (in-package :cl-test) (deftest tanh.1 (let ((result (tanh 0))) (or (eqlt result 0) (eqlt result 0.0))) t) (deftest tanh.2 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 type) unless (equal (multiple-value-list (tanh zero)) (list zero)) collect type) nil) (deftest tanh.3 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 `(complex ,type)) unless (equal (multiple-value-list (tanh zero)) (list zero)) collect type) nil) (deftest tanh.4 (loop for den = (1+ (random 10000)) for num = (random (* 10 den)) for x = (/ num den) for rlist = (multiple-value-list (tanh x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (numberp y)) collect (list x rlist)) nil) (deftest tanh.5 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x = (- (random (coerce 20 type)) 10) for rlist = (multiple-value-list (tanh x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y type)) collect (list x rlist))) nil) (deftest tanh.6 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x1 = (- (random (coerce 20 type)) 10) for x2 = (- (random (coerce 20 type)) 10) for rlist = (multiple-value-list (tanh (complex x1 x2))) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y `(complex ,type))) collect (list x1 x2 rlist))) nil) ;;; FIXME ;;; Add accuracy tests here ;;; Error tests (deftest tanh.error.1 (signals-error (tanh) program-error) t) (deftest tanh.error.2 (signals-error (tanh 1.0 1.0) program-error) t) (deftest tanh.error.3 (check-type-error #'tanh #'numberp) nil) gcl27-2.7.0/ansi-tests/terpri.lsp000066400000000000000000000023121454061450500165570ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 18 20:35:57 2004 ;;;; Contains: Tests of TERPRI (in-package :cl-test) (deftest terpri.1 (let (result) (values (with-output-to-string (*standard-output*) (write-char #\a) (setq result (terpri))) result)) #.(concatenate 'string "a" (string #\Newline)) nil) (deftest terpri.2 (let (result) (values (with-output-to-string (s) (write-char #\a s) (setq result (terpri s))) result)) #.(concatenate 'string "a" (string #\Newline)) nil) (deftest terpri.3 (with-output-to-string (s) (write-char #\x s) (terpri s) (terpri s) (write-char #\y s)) #.(concatenate 'string "x" (string #\Newline) (string #\Newline) "y")) (deftest terpri.4 (with-output-to-string (os) (let ((*terminal-io* (make-two-way-stream *standard-input* os))) (terpri t) (finish-output t))) #.(string #\Newline)) (deftest terpri.5 (with-output-to-string (*standard-output*) (terpri nil)) #.(string #\Newline)) ;;; Error tests (deftest terpri.error.1 (signals-error (with-output-to-string (s) (terpri s nil)) program-error) t) gcl27-2.7.0/ansi-tests/the.lsp000066400000000000000000000063771454061450500160510ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue May 6 06:48:48 2003 ;;;; Contains: Tests of THE (in-package :cl-test) (deftest the.1 (the (values) (values))) (deftest the.2 (the (values) 'a) a) (deftest the.3 (check-predicate #'(lambda (e) (let ((x (multiple-value-list (eval `(the (values) (quote ,e)))))) (and x (not (cdr x)) (eql (car x) e))))) nil) (deftest the.4 (check-predicate #'(lambda (e) (let ((x (multiple-value-list (eval `(the ,(type-of e) (quote ,e)))))) (and x (not (cdr x)) (eql (car x) e))))) nil) (deftest the.5 (check-predicate #'(lambda (e) (let ((x (multiple-value-list (eval `(the (values ,(type-of e)) (quote ,e)))))) (and x (not (cdr x)) (eql (car x) e))))) nil) (deftest the.6 (check-predicate #'(lambda (e) (let ((x (multiple-value-list (eval `(the (values ,(type-of e) t) (quote ,e)))))) (and x (not (cdr x)) (eql (car x) e))))) nil) (deftest the.7 (check-predicate #'(lambda (e) (let ((x (multiple-value-list (eval `(the (values ,(type-of e)) (values (quote ,e) :ignored)))))) (and (eql (length x) 2) (eql (car x) e) (eql (cadr x) :ignored))))) nil) (deftest the.8 (check-predicate #'(lambda (e) (or (not (constantp e)) (eql (eval `(the ,(type-of e) ,e)) e)))) nil) (deftest the.9 (check-predicate #'(lambda (e) (or (not (constantp e)) (eql (eval `(the ,(class-of e) ,e)) e)))) nil) (deftest the.10 (check-predicate #'(lambda (e) (eql (eval `(the ,(class-of e) ',e)) e))) nil) (deftest the.11 (check-predicate #'(lambda (e) (let* ((type (type-of e)) (x (multiple-value-list (eval `(the ,type (the ,type (quote ,e))))))) (and x (not (cdr x)) (eql (car x) e))))) nil) (deftest the.12 (let ((lexpr `(lambda () (and ,@(loop for e in *mini-universe* for type = (type-of e) collect `(eqlt (quote ,e) (the ,type (quote ,e)))))))) (funcall (compile nil lexpr))) t) (deftest the.13 (let ((x 0)) (values (the (or symbol integer) (incf x)) x)) 1 1) (deftest the.14 (the (values &rest t) (values 'a 'b)) a b) (deftest the.15 (the (values &rest symbol) (values 'a 'b)) a b) (deftest the.16 (the (values &rest null) (values))) (deftest the.17 (the (values symbol integer &rest null) (values 'a 1)) a 1) (deftest the.18 (the (values symbol integer &rest t) (values 'a 1 'foo '(x y))) a 1 foo (x y)) (deftest the.19 (let () (list (the (values) (eval '(values))))) (nil)) ;;; This is from SBCL bug 261 (deftest the.20 (let () (list (the (values &optional fixnum) (eval '(values))))) (nil)) (deftest the.21 (let () (list (the (values &rest t) (eval '(values))))) (nil)) (deftest the.22 (the (values symbol integer &rest t) (eval '(values 'a 1 'foo '(x y)))) a 1 foo (x y)) (deftest the.23 (multiple-value-list (the (values symbol integer &optional fixnum) (eval '(values 'a 1)))) (a 1)) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest the.24 (macrolet ((%m (z) z)) (the (integer 0 10) (expand-in-current-env (%m 4)))) 4) (deftest the.25 (macrolet ((%m (z) z)) (the (values t t) (expand-in-current-env (%m (values 1 2))))) 1 2) gcl27-2.7.0/ansi-tests/time.lsp000066400000000000000000000035461454061450500162220ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Dec 12 09:43:47 2004 ;;;; Contains: Tests of TIME (in-package :cl-test) (deftest time.1 (let ((s (with-output-to-string (*trace-output*) (assert (null (time nil)))))) (= (length s) 0)) nil) (deftest time.2 (let ((s (with-output-to-string (*trace-output*) (let ((x (cons 'a 'b))) (assert (eq (time x) x)))))) (= (length s) 0)) nil) (deftest time.3 (let ((s (with-output-to-string (*trace-output*) (let ((x (cons 'a 'b))) (flet ((%f () x)) (assert (eq (time (%f)) x))))))) (= (length s) 0)) nil) (deftest time.4 (let ((s (with-output-to-string (*trace-output*) (assert (null (multiple-value-list (time (values)))))))) (= (length s) 0)) nil) (deftest time.5 (let ((s (with-output-to-string (*trace-output*) (assert (equal '(a b c d) (multiple-value-list (time (values 'a 'b 'c 'd)))))))) (= (length s) 0)) nil) (deftest time.6 (let ((fn (compile nil '(lambda () (time nil))))) (let ((s (with-output-to-string (*trace-output*) (assert (null (funcall fn)))))) (= (length s) 0))) nil) (deftest time.7 (flet ((%f () (time nil))) (let ((s (with-output-to-string (*trace-output*) (assert (null (%f)))))) (= (length s) 0))) nil) (deftest time.8 (let ((s (with-output-to-string (*trace-output*) (macrolet ((%m () 1)) (assert (eql (time (%m)) 1)))))) (= (length s) 0)) nil) ;;; The TIME definition is weasely, so strenuous complaints from ;;; implementors about specific tests lead me to remove them. ;;; Someone didn't like this one at all. #| (deftest time.9 (let ((s (with-output-to-string (*trace-output*) (block done (time (return-from done nil)))))) (= (length s) 0)) nil) |# gcl27-2.7.0/ansi-tests/times-aux.lsp000066400000000000000000000012541454061450500171720ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Aug 28 11:23:40 2003 ;;;; Contains: Auxiliary functions for testing the multiplication operator * (in-package :cl-test) (defun integer-times (x y) (assert (integerp x)) (assert (integerp y)) (let (neg) (when (< x 0) (setq neg t x (- x))) (let ((result (nat-times x y))) (if neg (- result) result)))) (defun nat-times (x y) ;; Assumes x >= 0 (if (= x 0) 0 (let ((lo (if (oddp x) y 0)) (hi (nat-times (ash x -1) y))) (+ lo (+ hi hi))))) (defun rat-times (x y) (/ (integer-times (numerator x) (numerator y)) (integer-times (denominator x) (denominator y)))) gcl27-2.7.0/ansi-tests/times.lsp000066400000000000000000000236241454061450500164040ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Aug 28 10:41:34 2003 ;;;; Contains: Tests of the multiplication function * (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "times-aux.lsp") (deftest *.1 (*) 1) (deftest *.2 (loop for x in *numbers* unless (eql x (* x)) collect x) nil) (deftest *.3 (loop for x in *numbers* for x1 = (* x 1) for x2 = (* 1 x) unless (and (eql x x1) (eql x x2) (eql x1 x2)) collect (list x x1 x2)) nil) (deftest *.4 (loop for x in *numbers* for x1 = (* x 0) for x2 = (* 0 x) unless (and (= x1 0) (= x2 0)) collect (list x x1 x2)) nil) (deftest *.5 (loop for bound in '(1.0s0 1.0f0 1.0d0 1.0l0) nconc (loop for x = (random bound) for x1 = (* x -1) for x2 = (* -1 x) for x3 = (* x bound) for x4 = (* bound x) repeat 1000 unless (and (eql (- x) x1) (eql (- x) x2) (eql x x3) (eql x x4)) collect (list x x1 x2 x3 x4))) nil) (deftest *.6 (let* ((upper-bound (* 1000 1000 1000 1000)) (lower-bound (- upper-bound)) (spread (1+ (- upper-bound lower-bound)))) (loop for x = (random-from-interval upper-bound) for y = (random-from-interval upper-bound) for prod = (* x y) for prod2 = (integer-times x y) repeat 1000 unless (eql prod prod2) collect (list x y prod prod2))) nil) (deftest *.7 (let* ((upper-bound (* 1000 1000 1000)) (lower-bound (- upper-bound)) (spread (1+ (- upper-bound lower-bound)))) (loop for x = (+ (rational (random (float spread 1.0f0))) lower-bound) for y = (+ (rational (random (float spread 1.0f0))) lower-bound) for prod = (* x y) for prod2 = (rat-times x y) repeat 1000 unless (eql prod prod2) collect (list x y prod prod2))) nil) ;; Testing of multiplication by integer constants (deftest *.8 (let ((bound (isqrt most-positive-fixnum))) (loop for x = (random bound) for y = (random bound) for f = (eval `(function (lambda (z) (declare (optimize (speed 3) (safety 0))) (declare (type (integer 0 (,bound)) z)) (* ,x z)))) for prod = (funcall f y) repeat 100 unless (and (eql prod (* x y)) (eql prod (integer-times x y))) collect (progn (format t "Failed on ~A~%" (list x y prod)) (list x y prod (* x y) (integer-times x y))))) nil) (deftest *.9 (let* ((upper-bound (* 1000 1000 1000 1000))) (flet ((%r () (random-from-interval upper-bound))) (loop for xr = (%r) for xc = (%r) for x = (complex xr xc) for yr = (%r) for yc = (%r) for y = (complex yr yc) for prod = (* x y) repeat 1000 unless (and (eql (realpart prod) (- (integer-times xr yr) (integer-times xc yc))) (eql (imagpart prod) (+ (integer-times xr yc) (integer-times xc yr)))) collect (list x y prod)))) nil) (deftest *.10 (let* ((upper-bound (* 1000 1000 1000 1000)) (lower-bound (- upper-bound)) (spread (1+ (- upper-bound lower-bound)))) (flet ((%r () (+ (rational (random (float spread 1.0f0))) lower-bound))) (loop for xr = (%r) for xc = (%r) for x = (complex xr xc) for yr = (%r) for yc = (%r) for y = (complex yr yc) for prod = (* x y) repeat 1000 unless (and (eql (realpart prod) (- (rat-times xr yr) (rat-times xc yc))) (eql (imagpart prod) (+ (rat-times xr yc) (rat-times xc yr)))) collect (list x y prod)))) nil) (deftest *.11 (let ((prod 1) (args nil)) (loop for i from 1 to (min 256 (1- call-arguments-limit)) do (push i args) do (setq prod (* prod i)) always (eql (apply #'* args) prod))) t) (deftest *.12 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for radix = (float-radix x) for (k eps-r eps-f) = (multiple-value-list (find-epsilon x)) nconc (loop for i from 1 to k for y = (+ x (expt radix (- i))) nconc (loop for j from 1 to (- k i) for z = (+ x (expt radix (- j))) unless (eql (* y z) (+ x (expt radix (- i)) (expt radix (- j)) (expt radix (- (+ i j))))) collect (list x i j)))) nil) (deftest *.13 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for radix = (float-radix x) for (k eps-r eps-f) = (multiple-value-list (find-epsilon x)) nconc (loop for i from 1 to k for y = (- x (expt radix (- i))) nconc (loop for j from 1 to (- k i) for z = (- x (expt radix (- j))) unless (eql (* y z) (+ x (- (expt radix (- i))) (- (expt radix (- j))) (expt radix (- (+ i j))))) collect (list x i j)))) nil) ;;; Float contagion (deftest *.14 (let ((bound (- (sqrt most-positive-short-float) 1))) (loop for x = (random-from-interval bound) for y = (random-from-interval bound) for p = (* x y) repeat 1000 unless (and (eql p (* y x)) (typep p 'short-float)) collect (list x y p))) nil) (deftest *.15 (let ((bound (- (sqrt most-positive-single-float) 1))) (loop for x = (random-from-interval bound) for y = (random-from-interval bound) for p = (* x y) repeat 1000 unless (and (eql p (* y x)) (typep p 'single-float)) collect (list x y p))) nil) (deftest *.16 (let ((bound (- (sqrt most-positive-double-float) 1))) (loop for x = (random-from-interval bound) for y = (random-from-interval bound) for p = (* x y) repeat 1000 unless (and (eql p (* y x)) (typep p 'double-float)) collect (list x y p))) nil) (deftest *.17 (let ((bound (- (sqrt most-positive-long-float) 1))) (loop for x = (random-from-interval bound) for y = (random-from-interval bound) for p = (* x y) repeat 1000 unless (and (eql p (* y x)) (typep p 'long-float)) collect (list x y p))) nil) (deftest *.18 (let ((bound (- (sqrt most-positive-short-float) 1)) (bound2 (- (sqrt most-positive-single-float) 1))) (loop for x = (random-from-interval bound) for y = (random-from-interval bound2) for p = (* x y) repeat 1000 unless (and (eql p (* y x)) (typep p 'single-float)) collect (list x y p))) nil) (deftest *.19 (let ((bound (- (sqrt most-positive-short-float) 1)) (bound2 (- (sqrt most-positive-double-float) 1))) (loop for x = (random-from-interval bound) for y = (random-from-interval bound2) for p = (* x y) repeat 1000 unless (and (eql p (* y x)) (typep p 'double-float)) collect (list x y p))) nil) (deftest *.20 (let ((bound (- (sqrt most-positive-short-float) 1)) (bound2 (- (sqrt most-positive-long-float) 1))) (loop for x = (random-from-interval bound) for y = (random-from-interval bound2) for p = (* x y) repeat 1000 unless (and (eql p (* y x)) (typep p 'long-float)) collect (list x y p))) nil) (deftest *.21 (let ((bound (- (sqrt most-positive-single-float) 1)) (bound2 (- (sqrt most-positive-double-float) 1))) (loop for x = (random-from-interval bound) for y = (random-from-interval bound2) for p = (* x y) repeat 1000 unless (and (eql p (* y x)) (typep p 'double-float)) collect (list x y p))) nil) (deftest *.22 (let ((bound (- (sqrt most-positive-single-float) 1)) (bound2 (- (sqrt most-positive-long-float) 1))) (loop for x = (random-from-interval bound) for y = (random-from-interval bound2) for p = (* x y) repeat 1000 unless (and (eql p (* y x)) (typep p 'long-float)) collect (list x y p))) nil) (deftest *.23 (let ((bound (- (sqrt most-positive-double-float) 1)) (bound2 (- (sqrt most-positive-long-float) 1))) (loop for x = (random-from-interval bound) for y = (random-from-interval bound2) for p = (* x y) repeat 1000 unless (and (eql p (* y x)) (typep p 'long-float)) collect (list x y p))) nil) (deftest *.24 (loop for type in '(short-float single-float double-float long-float) for bits in '(13 24 50 50) for bound = (ash 1 (floor bits 2)) nconc (loop for i = (random bound) for x = (coerce i type) for j = (random bound) for y = (coerce j type) for prod = (* x y) repeat 1000 unless (and (eql prod (coerce (* i j) type)) (eql prod (* y x))) collect (list i j x y (* x y) (coerce (* i j) type)))) nil) (deftest *.25 (loop for type in '(short-float single-float double-float long-float) for bits in '(13 24 50 50) for bound = (ash 1 (- bits 2)) when (= (float-radix (coerce 1.0 type)) 2) nconc (loop for i = (random bound) for x = (coerce i type) for j = (* i 2) for y = (coerce j type) repeat 1000 unless (eql (* 2 x) y) collect (list i j x (* 2 x) y))) nil) ;;; Shows a compiler bug in sbcl/cmucl (deftest *.26 (eqlt (funcall (compile nil '(lambda (x y) (declare (type (single-float -10.0 10.0) x) (type (double-float -1.0d100 1.0d100) y)) (* x y))) 1.0f0 1.0d0) 1.0d0) t) (deftest *.27 (loop for type in '(short-float single-float double-float long-float) for bits in '(13 24 50 50) for bound = (ash 1 (floor bits 2)) nconc (loop for i = (random bound) for x = (coerce i type) for j = (random bound) for y = (coerce j type) for one = (coerce 1.0 type) for cx = (complex one x) for cy = (complex one y) for prod = (* cx cy) repeat 1000 unless (and (eql prod (complex (coerce (- 1 (* i j)) type) (coerce (+ i j) type))) (eql prod (* cy cx))) collect (list type i j x y (* cx cy)))) nil) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest *.28 (macrolet ((%m (z) z)) (values (* (expand-in-current-env (%m 2))) (* (expand-in-current-env (%m 3)) 4) (* 5 (expand-in-current-env (%m 3))))) 2 12 15) ;;; Order of evaluation tests (deftest times.order.1 (let ((i 0) x y) (values (* (progn (setf x (incf i)) 2) (progn (setf y (incf i)) 3)) i x y)) 6 2 1 2) (deftest times.order.2 (let ((i 0) x y z) (values (* (progn (setf x (incf i)) 2) (progn (setf y (incf i)) 3) (progn (setf z (incf i)) 5)) i x y z)) 30 3 1 2 3) gcl27-2.7.0/ansi-tests/trace.lsp000066400000000000000000000112201454061450500163460ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Dec 12 19:53:11 2004 ;;;; Contains: Tests of TRACE, UNTRACE (in-package :cl-test) (defun function-to-trace (x) (car x)) (defun another-function-to-trace (x) (cdr x)) (defun (setf function-to-trace) (val arg) (setf (car arg) val)) (declaim (notinline function-to-trace another-function-to-trace (setf function-to-trace))) (deftest trace.1 (progn (untrace) ;; ensure it's not traced (with-output-to-string (*trace-output*) (assert (eql (function-to-trace '(a)) 'a)))) "") (deftest trace.2 (progn (trace function-to-trace) (equal "" (with-output-to-string (*trace-output*) (assert (eql (function-to-trace '(b)) 'b))))) nil) (deftest trace.3 (progn (untrace) (trace function-to-trace) (prog1 (trace) (untrace) (assert (null (trace))))) (function-to-trace)) (deftest trace.4 (progn (untrace) (trace function-to-trace) (handler-bind ((warning #'muffle-warning)) (trace function-to-trace)) (prog1 (trace) (untrace) (assert (null (trace))))) (function-to-trace)) (deftest trace.5 (progn (untrace) (trace (setf function-to-trace)) (prog1 (trace) (untrace) (assert (null (trace))))) ((setf function-to-trace))) (deftest trace.6 (progn (untrace) (trace (setf function-to-trace)) (handler-bind ((warning #'muffle-warning)) (trace (setf function-to-trace))) (prog1 (trace) (untrace) (assert (null (trace))))) ((setf function-to-trace))) (deftest trace.7 (progn (untrace) (with-output-to-string (*trace-output*) (let ((x (list nil))) (assert (eql (setf (function-to-trace x) 'a) 'a)) (assert (equal x '(a)))))) "") (deftest trace.8 (progn (untrace) (trace (setf function-to-trace)) (equal "" (with-output-to-string (*trace-output*) (let ((x (list nil))) (assert (eql (setf (function-to-trace x) 'a) 'a)) (assert (equal x '(a))))))) nil) (deftest trace.9 (progn (untrace) (trace function-to-trace another-function-to-trace) (assert (not (equal "" (with-output-to-string (*trace-output*) (assert (eql (function-to-trace '(b)) 'b)))))) (assert (not (equal "" (with-output-to-string (*trace-output*) (assert (eql (another-function-to-trace '(c . d)) 'd)))))) (prog1 (sort (copy-list (trace)) #'(lambda (k1 k2) (string< (symbol-name k1) (symbol-name k2)))) (untrace))) (another-function-to-trace function-to-trace)) (deftest trace.10 (progn (untrace) (assert (null (trace))) (trace function-to-trace) (untrace function-to-trace) (assert (null (trace))) (handler-bind ((warning #'muffle-warning)) (untrace function-to-trace)) (assert (null (trace))) nil) nil) (deftest trace.11 (progn (untrace) (trace function-to-trace another-function-to-trace) (untrace function-to-trace another-function-to-trace) (trace)) nil) ;;; Tracing a generic function (declaim (notinline generic-function-to-trace)) (deftest trace.12 (progn (untrace) (eval '(defgeneric generic-function-to-trace (x y))) (trace generic-function-to-trace) (prog1 (trace) (untrace))) (generic-function-to-trace)) (deftest trace.13 (progn (untrace) (eval '(defgeneric generic-function-to-trace (x y))) (trace generic-function-to-trace) (eval '(defmethod generic-function-to-trace ((x t)(y t)) nil)) (prog1 (trace) (untrace))) (generic-function-to-trace)) (deftest trace.14 (progn (untrace) (eval '(defgeneric generic-function-to-trace (x y))) (trace generic-function-to-trace) (eval '(defmethod generic-function-to-trace ((x t)(y t)) nil)) (assert (not (equal (with-output-to-string (*trace-output*) (assert (null (generic-function-to-trace 'a 'b)))) ""))) (prog1 (trace) (untrace generic-function-to-trace) (assert (null (trace))))) (generic-function-to-trace)) (declaim (notinline generic-function-to-trace2)) (deftest trace.15 (progn (untrace) (let* ((gf (eval '(defgeneric generic-function-to-trace2 (x y)))) (m (eval '(defmethod generic-function-to-trace2 ((x integer)(y integer)) :foo)))) (eval '(defmethod generic-function-to-trace2 ((x symbol)(y symbol)) :bar)) (assert (eql (generic-function-to-trace2 1 2) :foo)) (assert (eql (generic-function-to-trace2 'a 'b) :bar)) (trace generic-function-to-trace2) (assert (equal (trace) '(generic-function-to-trace2))) (remove-method gf m) (prog1 (trace) (untrace)))) (generic-function-to-trace2)) gcl27-2.7.0/ansi-tests/translate-logical-pathname.lsp000066400000000000000000000022671454061450500224630ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Dec 29 14:45:50 2003 ;;;; Contains: Tests for TRANSLATE-LOGICAL-PATHNAME (in-package :cl-test) ;; On physical pathnames, t-l-p returns the pathname itself ;;; Every physical pathname is converted to itself (deftest translate-logical-pathname.1 (loop for p in *pathnames* unless (or (typep p 'logical-pathname) (eq p (translate-logical-pathname p))) collect p) nil) ;;; &key arguments are allowed (deftest translate-logical-pathname.2 (loop for p in *pathnames* unless (or (typep p 'logical-pathname) (eq p (translate-logical-pathname p :allow-other-keys t))) collect p) nil) (deftest translate-logical-pathname.3 (loop for p in *pathnames* unless (or (typep p 'logical-pathname) (eq p (translate-logical-pathname p :allow-other-keys nil))) collect p) nil) (deftest translate-logical-pathname.4 (loop for p in *pathnames* unless (or (typep p 'logical-pathname) (eq p (translate-logical-pathname p :foo 1 :allow-other-keys t :bar 2))) collect p) nil) ;;; errors (deftest translate-logical-pathname.error.1 (signals-error (translate-logical-pathname) program-error) t) gcl27-2.7.0/ansi-tests/translate-pathname.lsp000066400000000000000000000071541454061450500210530ustar00rootroot00000000000000;-*- Mode: Lisp -*- (in-package :cl-test) (deftest translate-pathname.1 (translate-pathname "foobar" "foobar" "foobar") #P"foobar") (deftest translate-pathname.2 (translate-pathname "foobar" "foobar" "foo*") #P"foo") (deftest translate-pathname.3 (translate-pathname "foobar" "foobar" "*") #P"foobar") (deftest translate-pathname.4 (translate-pathname "foobar" "foobar" "") #P"foobar") (deftest translate-pathname.5 (translate-pathname "foobar" "foo*r" "foobar") #P"foobar") (deftest translate-pathname.6 (translate-pathname "foobar" "foo*r" "foo*") #P"fooba") (deftest translate-pathname.7 (translate-pathname "foobar" "foo*r" "*") #P"foobar") (deftest translate-pathname.8 (translate-pathname "foobar" "foo*r" "") #P"foobar") (deftest translate-pathname.9 (translate-pathname "foobar" "*" "foobar") #P"foobar") (deftest translate-pathname.10 (translate-pathname "foobar" "*" "foo*") #P"foofoobar") (deftest translate-pathname.11 (translate-pathname "foobar" "*" "*") #P"foobar") (deftest translate-pathname.12 (translate-pathname "foobar" "*" "") #P"foobar") (deftest translate-pathname.13 (translate-pathname "foobar" "" "foobar") #P"foobar") (deftest translate-pathname.14 (translate-pathname "foobar" "" "foo*") #P"foofoobar") (deftest translate-pathname.15 (translate-pathname "foobar" "" "*") #P"foobar") (deftest translate-pathname.16 (translate-pathname "foobar" "" "") #P"foobar") (deftest translate-pathname.17 (translate-pathname "/a/bbfb/c/d/" "/a/bbfb/c/d/" "/a/qc/c/d/") #P"/a/qc/c/d/") (deftest translate-pathname.18 (translate-pathname "/a/bbfb/c/d/" "/a/bbfb/c/d/" "/a/q*c*/c/d/") #P"/a/qc/c/d/") (deftest translate-pathname.19 (translate-pathname "/a/bbfb/c/d/" "/a/bbfb/c/d/" "/a/*/c/d/") #P"/a/c/d/") (deftest translate-pathname.20 (translate-pathname "/a/bbfb/c/d/" "/a/bbfb/c/d/" "/a/**/d/") #P"/a/d/") (deftest translate-pathname.21 (translate-pathname "/a/bbfb/c/d/" "/a/b*f*/c/d/" "/a/qc/c/d/") #P"/a/qc/c/d/") (deftest translate-pathname.22 (translate-pathname "/a/bbfb/c/d/" "/a/b*f*/c/d/" "/a/q*c*/c/d/") #P"/a/qbcb/c/d/") (deftest translate-pathname.23 (translate-pathname "/a/bbfb/c/d/" "/a/b*f*/c/d/" "/a/*/c/d/") #P"/a/bbfb/c/d/") (deftest translate-pathname.24 (translate-pathname "/a/bbfb/c/d/" "/a/b*f*/c/d/" "/a/**/d/") #P"/a/bbfb/d/") (deftest translate-pathname.25 (translate-pathname "/a/bbfb/c/d/" "/a/**/d/" "/a/qc/c/d/") #P"/a/qc/c/d/") (deftest translate-pathname.26 (translate-pathname "/a/bbfb/c/d/" "/a/**/d/" "/a/q*c*/c/d/") #P"/a/qc/c/d/") (deftest translate-pathname.27 (translate-pathname "/a/bbfb/c/d/" "/a/**/d/" "/a/*/d/") #P"/a/bbfb/d/") (deftest translate-pathname.28 (translate-pathname "/a/bbfb/c/d/" "/a/**/d/" "/a/**/d/") #P"/a/bbfb/c/d/") (deftest translate-pathname.29 (translate-pathname "/a/bbfb/c/d/" "/a/**/d/" "a/qc/c/d/") #P"a/qc/c/d/") (deftest translate-pathname.30 (translate-pathname "/a/bbfb/c/d/" "/a/**/d/" "a/q*c*/c/d/") #P"a/qc/c/d/") (deftest translate-pathname.31 (translate-pathname "/a/bbfb/c/d/" "/a/**/d/" "a/*/d/") #P"a/bbfb/d/") (deftest translate-pathname.32 (translate-pathname "/a/bbfb/c/d/" "/a/**/d/" "a/**/d/") #P"a/bbfb/c/d/") (deftest translate-pathname.33 (translate-pathname "/a/bbfb/c/d/" "/a/bbfb/c/d/" "a") #P"/a/bbfb/c/d/a") (deftest translate-pathname.34 (translate-pathname "/a/bbfb/c/d/" "/a/b*f*/c/d/" "a") #P"/a/bbfb/c/d/a") (deftest translate-pathname.35 (translate-pathname "/a/bbfb/c/d/" "/a/*/c/d/" "a") #P"/a/bbfb/c/d/a") (deftest translate-pathname.36 (translate-pathname "/a/bbfb/c/d/" "/a/**/d/" "a") #P"/a/bbfb/c/d/a") gcl27-2.7.0/ansi-tests/tree-equal.lsp000066400000000000000000000057241454061450500173300ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jun 14 07:23:03 2003 ;;;; Contains: Tests of TREE-EQUAL (in-package :cl-test) (compile-and-load "cons-aux.lsp") (deftest tree-equal.1 (notnot-mv (tree-equal 'a 'a)) t) (deftest tree-equal.2 (tree-equal 'a 'b) nil) (deftest tree-equal.3 (notnot-mv (tree-equal (list 'a 'b (list 'c 'd)) (list 'a 'b (list 'c 'd)))) t) (deftest tree-equal.4 (tree-equal '(a b c d) '(a b c e)) nil) (deftest tree-equal.5 (notnot-mv (tree-equal 1 2 :test #'<)) t) (deftest tree-equal.6 (notnot-mv (tree-equal 1 2 :test #'(lambda (x y) (values (< x y) t)))) t) (deftest tree-equal.7 (tree-equal 1 2 :test #'>) nil) (deftest tree-equal.8 (tree-equal (list 1) 2 :test (constantly t)) nil) (deftest tree-equal.9 (tree-equal (list 1) (list 2) :test #'(lambda (x y) (or (and (consp x) (consp y)) (eql x y)))) nil) (deftest tree-equal.10 (notnot-mv (tree-equal '(10 20 . 30) '(11 22 . 34) :test #'<)) t) (deftest tree-equal.11 (let* ((x (list 'a 'b)) (y (list x x)) (z (list (list 'a 'b) (list 'a 'b)))) (notnot-mv (tree-equal y z))) t) (deftest tree-equal.12 (tree-equal 'a '(a b)) nil) (deftest tree-equal.13 (tree-equal '(a) '(a b)) nil) (deftest tree-equal.14 (tree-equal '(a b) '(a)) nil) (deftest tree-equal.15 (let ((x (vector 'a 'b 'c)) (y (vector 'a' 'b 'c))) (tree-equal x y)) nil) (deftest tree-equal.16 (let ((x (copy-seq "")) (y (copy-seq ""))) (tree-equal x y)) nil) (defharmless tree-equal.test-and-test-not.1 (tree-equal '(a b) '(a b) :test #'eql :test-not #'eql)) (defharmless tree-equal.test-and-test-not.2 (tree-equal '(a b) '(a b) :test-not #'eql :test #'eql)) ;;; Keywords tests (deftest tree-equal.allow-other-keys.1 (notnot-mv (tree-equal '(a b) (list 'a 'b) :allow-other-keys nil)) t) (deftest tree-equal.allow-other-keys.2 (tree-equal '(a b) (list 'a 'c) :allow-other-keys nil :test #'eql) nil) (deftest tree-equal.allow-other-keys.3 (tree-equal '(a b) (list 'a 'z) :allow-other-keys t :foo t) nil) (deftest tree-equal.allow-other-keys.4 (notnot-mv (tree-equal '(a b) (list 'a 'b) :allow-other-keys t :allow-other-keys nil :foo t)) t) (deftest tree-equal.keywords.1 (notnot-mv (tree-equal '(a . b) '(b . a) :test (complement #'eql) :test #'eql)) t) ;;; Error tests (deftest tree-equal.error.1 (signals-error (tree-equal) program-error) t) (deftest tree-equal.error.2 (signals-error (tree-equal '(a b)) program-error) t) (deftest tree-equal.error.3 (signals-error (tree-equal '(a b) '(a b) (gensym) t) program-error) t) (deftest tree-equal.error.4 (signals-error (tree-equal '(a b) '(a b) (gensym) t :allow-other-keys nil) program-error) t) (deftest tree-equal.error.5 (signals-error (tree-equal '(a b) '(a b) :test #'identity) program-error) t) (deftest tree-equal.error.6 (signals-error (tree-equal '(a b) '(a b) :test #'(lambda (x y z) (eq x y))) program-error) t) gcl27-2.7.0/ansi-tests/truename.lsp000066400000000000000000000052461454061450500171030ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 6 05:32:37 2004 ;;;; Contains: Tests of TRUENAME (in-package :cl-test) (deftest truename.1 (let* ((pn #p"truename.lsp") (tn (truename pn))) (values (notnot (pathnamep pn)) (typep pn 'logical-pathname) (equalt (pathname-name pn) (pathname-name tn)) (equalt (pathname-type pn) (pathname-type tn)) )) t nil t t) (deftest truename.2 (let* ((name "truename.lsp") (pn (pathname name)) (tn (truename name))) (values (notnot (pathnamep pn)) (typep pn 'logical-pathname) (equalt (pathname-name pn) (pathname-name tn)) (equalt (pathname-type pn) (pathname-type tn)) )) t nil t t) (deftest truename.3 (let* ((pn #p"truename.lsp")) (with-open-file (s pn :direction :input) (let ((tn (truename s))) (values (notnot (pathnamep pn)) (typep pn 'logical-pathname) (equalt (pathname-name pn) (pathname-name tn)) (equalt (pathname-type pn) (pathname-type tn)) )))) t nil t t) (deftest truename.4 (let* ((pn #p"truename.lsp")) (let ((s (open pn :direction :input))) (close s) (let ((tn (truename s))) (values (notnot (pathnamep pn)) (typep pn 'logical-pathname) (equalt (pathname-name pn) (pathname-name tn)) (equalt (pathname-type pn) (pathname-type tn)) )))) t nil t t) (deftest truename.5 (let* ((lpn "CLTEST:FOO.TXT") (pn (translate-logical-pathname lpn))) (unless (probe-file lpn) (with-open-file (s lpn :direction :output) (format s "Stuff~%"))) (let ((tn (truename lpn))) (values (notnot (pathnamep pn)) (if (equalt (pathname-name pn) (pathname-name tn)) t (list (pathname-name pn) (pathname-name tn))) (if (equalt (pathname-type pn) (pathname-type tn)) t (list (pathname-type pn) (pathname-type tn))) ))) t t t) ;;; Specialized string tests (deftest truename.6 (do-special-strings (s "truename.lsp" nil) (assert (equalp (truename s) (truename "truename.lsp")))) nil) ;;; Error tests (deftest truename.error.1 (signals-error (truename) program-error) t) (deftest truename.error.2 (signals-error (truename "truename.lsp" nil) program-error) t) (deftest truename.error.3 (signals-error-always (truename "nonexistent") file-error) t t) (deftest truename.error.4 (signals-error-always (truename #p"nonexistent") file-error) t t) (deftest truename.error.5 (signals-error-always (truename (logical-pathname "CLTESTROOT:NONEXISTENT")) file-error) t t) (deftest truename.error.6 (signals-error-always (let ((pn (make-pathname :name :wild :defaults *default-pathname-defaults*))) (truename pn)) file-error) t t) gcl27-2.7.0/ansi-tests/truncate-aux.lsp000066400000000000000000000054331454061450500177010ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 20 05:15:17 2003 ;;;; Contains: Aux. functions associated with tests of TRUNCATE (in-package :cl-test) (defun truncate.1-fn () (loop for n = (- (random 2000000000) 1000000000) for d = (1+ (random 10000)) for vals = (multiple-value-list (truncate n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (= n n2) (integerp r) (if (>= n 0) (< -1 r d) (< (- d) r 1))) collect (list n d q r n2))) (defun truncate.2-fn () (loop for num = (random 1000000000) for denom = (1+ (random 1000)) for n = (/ num denom) for d = (1+ (random 10000)) for vals = (multiple-value-list (truncate n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (<= 0 r) (< r d) (= n n2)) collect (list n d q r n2))) (defun truncate.3-fn (width) (loop for n = (- (random width) (/ width 2)) for vals = (multiple-value-list (truncate n)) for (q r) = vals for n2 = (+ q r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (= n n2) (if (>= n 0) (and (<= 0 r) (< r 1)) (and (< -1 r) (<= r 0))) ) collect (list n q r n2))) (defun truncate.7-fn () (loop for numerator = (- (random 10000000000) 5000000000) for denominator = (1+ (random 100000)) for n = (/ numerator denominator) for vals = (multiple-value-list (truncate n)) for (q r) = vals for n2 = (+ q r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (rationalp r) (= n n2) (if (>= n 0) (and (<= 0 r) (< r 1)) (and (< -1 r) (<= r 0))) ) collect (list n q r n2))) (defun truncate.8-fn () (loop for num1 = (- (random 10000000000) 5000000000) for den1 = (1+ (random 100000)) for n = (/ num1 den1) for num2 = (- (1+ (random 1000000))) for den2 = (1+ (random 1000000)) for d = (/ num2 den2) for vals = (multiple-value-list (truncate n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (rationalp r) (if (> n 0) (and (<= 0 r) (< r (- d))) (and (>= 0 r) (> r d))) (= n n2)) collect (list n q d r n2))) (defun truncate.9-fn () (loop for num1 = (- (random 1000000000000000) 500000000000000) for den1 = (1+ (random 10000000000)) for n = (/ num1 den1) for num2 = (- (1+ (random 1000000000))) for den2 = (1+ (random 10000000)) for d = (/ num2 den2) for vals = (multiple-value-list (truncate n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (rationalp r) (if (> n 0) (and (<= 0 r) (< r (- d))) (and (>= 0 r) (> r d))) (= n n2)) collect (list n q d r n2))) gcl27-2.7.0/ansi-tests/truncate.lsp000066400000000000000000000071601454061450500171050ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 20 05:13:26 2003 ;;;; Contains: Tests of TRUNCATE (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "truncate-aux.lsp") (deftest truncate.error.1 (signals-error (truncate) program-error) t) (deftest truncate.error.2 (signals-error (truncate 1.0 1 nil) program-error) t) ;;; (deftest truncate.1 (truncate.1-fn) nil) (deftest truncate.2 (truncate.2-fn) nil) (deftest truncate.3 (truncate.3-fn 2.0s4) nil) (deftest truncate.4 (truncate.3-fn 2.0f4) nil) (deftest truncate.5 (truncate.3-fn 2.0d4) nil) (deftest truncate.6 (truncate.3-fn 2.0l4) nil) (deftest truncate.7 (truncate.7-fn) nil) (deftest truncate.8 (truncate.8-fn) nil) (deftest truncate.9 (truncate.9-fn) nil) (deftest truncate.10 (loop for x in (remove-if #'zerop *reals*) for (q r) = (multiple-value-list (truncate x x)) unless (and (eql q 1) (zerop r) (if (rationalp x) (eql r 0) (eql r (float 0 x)))) collect x) nil) (deftest truncate.11 (loop for x in (remove-if #'zerop *reals*) for (q r) = (multiple-value-list (truncate (- x) x)) unless (and (eql q -1) (zerop r) (if (rationalp x) (eql r 0) (eql r (float 0 x)))) collect x) nil) (deftest truncate.12 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (truncate x)) unless (and (eql q i) (eql r rrad)) collect (list i x q r))) nil) (deftest truncate.13 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (truncate x)) unless (and (eql q (1- i)) (eql r rrad)) collect (list i x q r))) nil) (deftest truncate.14 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (truncate x)) unless (and (eql q i) (eql r rrad)) collect (list i x q r))) nil) (deftest truncate.15 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (truncate x)) unless (and (eql q (1- i)) (eql r rrad)) collect (list i x q r))) nil) (deftest truncate.16 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (truncate x)) unless (and (eql q i) (eql r rrad)) collect (list i x q r))) nil) (deftest truncate.17 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (truncate x)) unless (and (eql q (1- i)) (eql r rrad)) collect (list i x q r))) nil) (deftest truncate.18 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (truncate x)) unless (and (eql q i) (eql r rrad)) collect (list i x q r))) nil) (deftest truncate.19 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (truncate x)) unless (and (eql q (1- i)) (eql r rrad)) collect (list i x q r))) nil) gcl27-2.7.0/ansi-tests/two-way-stream-input-stream.lsp000066400000000000000000000014001454061450500225750ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Feb 12 04:22:50 2004 ;;;; Contains: Tests of TWO-WAY-STREAM-INPUT-STREAM (in-package :cl-test) (deftest two-way-stream-input-stream.1 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (equalt (multiple-value-list (two-way-stream-input-stream s)) (list is))) t) (deftest two-way-stream-input-stream.error.1 (signals-error (two-way-stream-input-stream) program-error) t) (deftest two-way-stream-input-stream.error.2 (signals-error (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (two-way-stream-input-stream s nil)) program-error) t) gcl27-2.7.0/ansi-tests/two-way-stream-output-stream.lsp000066400000000000000000000014101454061450500227770ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Feb 12 04:25:59 2004 ;;;; Contains: Tests off TWO-WAY-STREAM-OUTPUT-STREAM (in-package :cl-test) (deftest two-way-stream-output-stream.1 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (equalt (multiple-value-list (two-way-stream-output-stream s)) (list os))) t) (deftest two-way-stream-output-stream.error.1 (signals-error (two-way-stream-output-stream) program-error) t) (deftest two-way-stream-output-stream.error.2 (signals-error (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (two-way-stream-output-stream s nil)) program-error) t) gcl27-2.7.0/ansi-tests/type-of.lsp000066400000000000000000000060711454061450500166430ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jun 4 21:15:05 2003 ;;;; Contains: Tests of TYPE-OF (in-package :cl-test) ;;; It turns out I left out an important test of type-of: ;;; (type-of x) must be a recognizable subtype of every builtin type ;;; of which x is a member. (deftest type-of.1 :notes :type-of/strict-builtins (loop for x in *universe* for tp = (type-of x) for failures = (loop for tp2 in *cl-all-type-symbols* when (and (typep x tp2) (not (subtypep tp tp2))) collect tp2) when failures collect (list x failures)) nil) ;;; Some have objected to that (in type-of.1) interpretation ;;; of req. 1.a in the TYPE-OF page, saying that it need hold ;;; for only *one* builtin type that the object is an element of. ;;; This test tests the relaxed requirement. (deftest type-of.1-relaxed (loop for x in *universe* for builtins = (remove x *cl-all-type-symbols* :test (complement #'typep)) for tp = (type-of x) when (and builtins (not (loop for tp2 in builtins thereis (subtypep tp tp2)))) collect x) nil) ;;; 1. For any object that is an element of some built-in type: ;;; b. the type returned does not involve and, eql, member, not, ;;; or, satisfies, or values. ;;; ;;; Since every object is an element of the built-in type T, this ;;; applies universally. (deftest type-of.2 (loop for x in *universe* for tp = (type-of x) when (and (consp tp) (member (car tp) '(and eql member not or satisfies values function))) collect x) nil) (deftest type-of.3 (loop for x in *universe* unless (typep x (type-of x)) collect x) nil) (deftest type-of.4 (loop for x in *universe* for tp = (type-of x) for class = (class-of x) unless (equal (multiple-value-list (subtypep* tp class)) '(t t)) collect x) nil) (deftest type-of.5 (loop for x in *cl-condition-type-symbols* for cnd = (make-condition x) for tp = (type-of cnd) unless (eq x tp) collect x) nil) (defstruct type-of.example-struct a b c) (deftest type-of.6 (type-of (make-type-of.example-struct)) type-of.example-struct) (defclass type-of.example-class () ()) (deftest type-of.7 (type-of (make-instance 'type-of.example-class)) type-of.example-class) (deftest type-of.8 (let ((class (eval '(defclass type-of.example-class-2 () ((a) (b) (c)))))) (setf (class-name class) nil) (eqt (type-of (make-instance class)) class)) t) (deftest type-of.9 (let ((class (eval '(defclass type-of.example-class-3 () ((a) (b) (c)))))) (setf (find-class 'type-of.example-class-3) nil) (eqt (type-of (make-instance class)) class)) t) (deftest type-of.10 (let* ((class (eval '(defclass type-of.example-class-4 () ((a) (b) (c))))) (obj (make-instance class))) (setf (class-name class) nil) (notnot-mv (typep obj class))) t) (deftest type-of.11 (let* ((c #c(-1 1/2)) (type (type-of c))) (notnot (typep c type))) t) ;;; Error tests (deftest type-of.error.1 (signals-error (type-of) program-error) t) (deftest type-of.error.2 (signals-error (type-of nil nil) program-error) t) gcl27-2.7.0/ansi-tests/type.lsp000066400000000000000000000026211454061450500162360ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 29 08:25:46 2005 ;;;; Contains: Tests of TYPE declarations (in-package :cl-test) ;;; Also of implicit type declarations (deftest type.1 (let ((x 1)) (declare (type (integer 0 1) x)) (values x (setq x 0) (1+ x))) 1 0 1) (deftest type.2 (let ((x 1)) (declare (type (integer -1 1) x)) (locally (declare (type (integer 0 2) x)) (values x (setq x 0) (1+ x)))) 1 0 1) (deftest type.3 (loop for x in *mini-universe* for tp = (type-of x) for form = `(let ((y ',x)) (declare (type ,tp y)) y) for val = (eval form) unless (eql val x) collect (list x tp form val)) nil) (deftest type.4 (loop for x in *mini-universe* for tp = (type-of x) for form = `(let ((y ',x)) (declare (,tp y)) y) for val = (eval form) unless (eql val x) collect (list x tp form val)) nil) (deftest type.5 (loop for x in *mini-universe* for class = (class-of x) for form = `(let ((y ',x)) (declare (,class y)) y) for val = (eval form) unless (eql val x) collect (list x class form val)) nil) ;;; Free TYPE declaration ;;; It should not apply to the occurence of X in the form ;;; whose value is being bound to Y. (deftest type.6 (let ((x 2)) (let ((y (+ (decf x) 2))) (declare (type (integer 0 1) x)) (values x y))) 1 3) gcl27-2.7.0/ansi-tests/typecase.lsp000066400000000000000000000062441454061450500170770ustar00rootroot00000000000000;-*- 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) (deftest typecase.16 (block done (tagbody (typecase 'a (symbol (go 10) 10 (return-from done 'bad))) 10 (return-from done 'good))) good) (deftest typecase.17 (block done (tagbody (typecase 'a (integer 'bad) (t (go 10) 10 (return-from done 'bad))) 10 (return-from done 'good))) good) (deftest typecase.18 (loop for x in '(a 1 1.4 "c") collect (typecase x (t :good) (otherwise :bad))) (:good :good :good :good)) ;;; A randomized test (deftest typecase.19 (let* ((u (coerce *universe* 'vector)) (len1 (length u)) (types (coerce *cl-all-type-symbols* 'vector)) (len2 (length types))) (loop for n = (random 10) for my-types = (loop repeat n collect (elt types (random len2))) for val = (elt u (random len1)) for i = (position val my-types :test #'typep) for form = `(typecase ',val ,@(loop for i from 0 for type in my-types collect `(,type ,i)) (otherwise nil)) for j = (eval form) repeat 1000 unless (eql i j) collect (list n my-types val i form j))) nil) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest typecase.20 (macrolet ((%m (z) z)) (typecase (expand-in-current-env (%m 2)) ((integer 0 1) :bad1) ((integer 2 10) :good) (t :bad2))) :good) (deftest typecase.21 (macrolet ((%m (z) z)) (typecase 2 ((integer 0 1) (expand-in-current-env (%m :bad1))) ((integer 2 10) (expand-in-current-env (%m :good))) (t (expand-in-current-env (%m :bad2))))) :good) ;;; Error cases (deftest typecase.error.1 (signals-error (funcall (macro-function 'typecase)) program-error) t) (deftest typecase.error.2 (signals-error (funcall (macro-function 'typecase) '(typecase t)) program-error) t) (deftest typecase.error.3 (signals-error (funcall (macro-function 'typecase) '(typecase t) nil nil) program-error) t) gcl27-2.7.0/ansi-tests/typep.lsp000066400000000000000000000065371454061450500164300ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon May 23 07:13:32 2005 ;;;; Contains: Tests of TYPEP (in-package :cl-test) (deftest typep.error.1 (signals-error (typep) program-error) t) (deftest typep.error.2 (signals-error (typep nil) program-error) t) (deftest typep.error.3 (signals-error (typep nil t nil nil) program-error) t) (deftest typep.error.4 (signals-error-always (typep nil 'values) error) t t) (deftest typep.error.5 (signals-error-always (typep nil '(values)) error) t t) (deftest typep.error.6 (signals-error-always (typep nil '(values t t t t)) error) t t) (deftest typep.error.7 (signals-error-always (typep nil '(function () t)) error) t t) ;;; Non-error tests ;;; Many more tests use typep when testing other functions (deftest typep-nil-null (notnot-mv (typep nil 'null)) t) (deftest typep-t-null (typep t 'null) nil) ;;; 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) (deftest typep.18 (let ((i 0)) (values (notnot (typep (incf i) '(and (integer 0 10) (integer -5 6)))) i)) t 1) (defun typep.19-fn (reps &optional (prob .5)) (let* ((vec "abcdefghijklmnopqrstuvwxyz")) (flet ((%make-random-type () `(and character (member ,@(loop for e across vec when (< (random 1.0) prob) collect e))))) (loop for t1 = (%make-random-type) for t2 = (%make-random-type) for t3 = `(and ,t1 ,t2) for result1 = (loop for e across vec when (if (typep e t3) (or (not (typep e t1)) (not (typep e t2))) (and (typep e t1) (typep e t2))) collect e) repeat reps when result1 nconc (list result1 t1 t2 t3))))) (eval-when (:load-toplevel) (compile 'typep.19-fn)) (deftest typep.19 (typep.19-fn 1000) nil) gcl27-2.7.0/ansi-tests/types-and-class-2.lsp000066400000000000000000000101601454061450500204200ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Feb 5 21:20:05 2003 ;;;; Contains: More tests of types and classes (in-package :cl-test) (compile-and-load "types-aux.lsp") ;;; 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) gcl27-2.7.0/ansi-tests/types-and-class.lsp000066400000000000000000000175141454061450500202730ustar00rootroot00000000000000;-*- 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) (compile-and-load "types-aux.lsp") (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) nil) (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) (deftest all-classes-are-type-equivalent-to-their-names.2 (loop for x in *universe* for cl = (class-of x) for name = (class-name cl) when name append (check-equivalence name cl)) 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-standard-classes-are-subtypes-of-standard-object.2 (loop for x in *universe* for class = (class-of x) when (and (typep class 'standard-class) (not (subtypep class 'standard-object))) collect x) 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) (deftest all-structure-classes-are-subtypes-of-structure-object.2 (loop for x in *universe* for cl = (class-of x) when (and (typep cl 'structure-class) (not (subtypep cl 'structure-object))) collect x) 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) ;; 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) ;;; TYPE-ERROR accessors (deftest type-error-datum.1 (let ((c (make-condition 'type-error :datum 'a :expected-type 'integer))) (type-error-datum c)) a) (deftest type-error-expected-type.1 (let ((c (make-condition 'type-error :datum 'a :expected-type 'integer))) (type-error-expected-type c)) integer) ;;; Error checking of type-related functions (deftest type-error-datum.error.1 (signals-error (type-error-datum) program-error) t) (deftest type-error-datum.error.2 (signals-error (let ((c (make-condition 'type-error :datum nil :expected-type t))) (type-error-datum c nil)) program-error) t) (deftest type-error-expected-type.error.1 (signals-error (type-error-expected-type) program-error) t) (deftest type-error-expected-type.error.2 (signals-error (let ((c (make-condition 'type-error :datum nil :expected-type t))) (type-error-expected-type c nil)) program-error) t) gcl27-2.7.0/ansi-tests/types-aux.lsp000066400000000000000000000137241454061450500172220ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jun 21 20:14:38 2004 ;;;; Contains: Aux. functions for types tests (in-package :cl-test) (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) (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 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) :==> ,sub ,valid)) nil))) ;;; 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 subtypep-and-contrapositive-are-consistent (t1 t2) (multiple-value-bind (sub1 success1) (subtypep* t1 t2) (multiple-value-bind (sub2 success2) (subtypep* `(not ,t2) `(not ,t1)) (or (not success1) (not success2) (eqlt sub1 sub2))))) ;;; For use in deftype tests (deftype even-array (&optional type size) `(and (array ,type ,size) (satisfies even-size-p))) gcl27-2.7.0/ansi-tests/unbound-slot.lsp000066400000000000000000000014351454061450500177100ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jun 4 20:14:26 2003 ;;;; Contains: Tests for UNBOUND-SLOT, UNBOUND-SLOT-INSTANCE (in-package :cl-test) (defclass ubs-class-01 () ((a :initarg :a))) (deftest unbound-slot.1 (let ((obj (make-instance 'ubs-class-01))) (handler-case (slot-value obj 'a) (unbound-slot (c) (values (typep* c 'cell-error) (eqt (unbound-slot-instance c) obj) (cell-error-name c))))) t t a) (defclass ubs-class-02 () ((b :allocation :class))) (deftest unbound-slot.2 (let ((obj (make-instance 'ubs-class-02))) (handler-case (slot-value obj 'b) (unbound-slot (c) (values (typep* c 'cell-error) (eqt (unbound-slot-instance c) obj) (cell-error-name c))))) t t b) gcl27-2.7.0/ansi-tests/unexport.lsp000066400000000000000000000117021454061450500171410ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:04:19 1998 ;;;; Contains: Tests of UNEXPORT (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 (signals-error (progn (when (find-package "X") (delete-package "X")) (unexport 'a (make-package "X" :use nil)) nil) package-error) t) ;; 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) ;;; Specialized sequence tests (defmacro def-unexport-test (test-name name-form) `(deftest ,test-name (let ((name ,name-form)) (safely-delete-package name) (let* ((p (make-package name :use nil)) (r (export (intern "X" p) p))) (multiple-value-bind* (sym1 access1) (find-symbol "X" p) (unexport (list sym1) name) (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)) (def-unexport-test unexport.7 (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) (def-unexport-test unexport.8 (make-array 10 :initial-contents "TEST1ABCDE" :fill-pointer 5 :element-type 'base-char)) (def-unexport-test unexport.9 (make-array 10 :initial-contents "TEST1ABCDE" :fill-pointer 5 :element-type 'character)) (def-unexport-test unexport.10 (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'base-char)) (def-unexport-test unexport.11 (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'character)) (def-unexport-test unexport.12 (let* ((etype 'base-char) (name0 (make-array 10 :element-type etype :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 5))) (def-unexport-test unexport.13 (let* ((etype 'character) (name0 (make-array 10 :element-type etype :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 5))) ;;; Error tests (deftest unexport.error.1 (signals-error (unexport) program-error) t) (deftest unexport.error.2 (signals-error (unexport 'xyz "CL-TEST" nil) program-error) t) gcl27-2.7.0/ansi-tests/unintern.lsp000066400000000000000000000201071454061450500171160ustar00rootroot00000000000000();-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:04:56 1998 ;;;; Contains: Tests of UNINTERN (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" :use nil)) (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" :use nil))) (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" :use nil))) (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" :use nil))) (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" :use nil))) (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" :use nil) (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" :use nil)) (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" :use nil)) (pg2 (make-package "G2" :use nil)) (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" :use nil)) (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) ;;; Specialized sequence tests (defmacro def-unintern-test (test-name name-form) `(deftest ,test-name (let ((name ,name-form)) (safely-delete-package name) (prog1 (let ((p (make-package name :use nil))) (intern "FOO" p) (multiple-value-bind* (sym access) (find-symbol "FOO" p) (and (eqt access :internal) (unintern sym name) (null (symbol-package sym)) (not (find-symbol "FOO" p))))) (safely-delete-package name))) t)) (def-unintern-test unintern.10 (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) (def-unintern-test unintern.11 (make-array 10 :initial-contents "TEST1ABCDE" :fill-pointer 5 :element-type 'base-char)) (def-unintern-test unintern.12 (make-array 10 :initial-contents "TEST1ABCDE" :fill-pointer 5 :element-type 'character)) (def-unintern-test unintern.13 (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'base-char)) (def-unintern-test unintern.14 (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'character)) (def-unintern-test unintern.15 (let* ((etype 'base-char) (name0 (make-array 10 :element-type etype :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 5))) (def-unintern-test unintern.16 (let* ((etype 'character) (name0 (make-array 10 :element-type etype :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 5))) (deftest unintern.error.1 (signals-error (unintern) program-error) t) (deftest unintern.error.2 (signals-error (unintern '#:x "CL-TEST" nil) program-error) t) gcl27-2.7.0/ansi-tests/union.lsp000066400000000000000000000242121454061450500164050ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:41:24 2003 ;;;; Contains: Tests of UNION (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) (defharmless union.test-and-test-not.1 (union (list 1 4 8 10) (list 1 2 3 9 10 13) :test #'eql :test-not #'eql)) (defharmless union.test-and-test-not.2 (union (list 1 4 8 10) (list 1 2 3 9 10 13) :test-not #'eql :test #'eql)) ;;; 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)) (def-fold-test union.fold.1 (union '(a b c d e) '(d x y a w c))) ;;; Error tests (deftest union.error.1 (signals-error (union) program-error) t) (deftest union.error.2 (signals-error (union nil) program-error) t) (deftest union.error.3 (signals-error (union nil nil :bad t) program-error) t) (deftest union.error.4 (signals-error (union nil nil :key) program-error) t) (deftest union.error.5 (signals-error (union nil nil 1 2) program-error) t) (deftest union.error.6 (signals-error (union nil nil :bad t :allow-other-keys nil) program-error) t) (deftest union.error.7 (signals-error (union (list 1 2) (list 3 4) :test #'identity) program-error) t) (deftest union.error.8 (signals-error (union (list 1 2) (list 3 4) :test-not #'identity) program-error) t) (deftest union.error.9 (signals-error (union (list 1 2) (list 3 4) :key #'cons) program-error) t) (deftest union.error.10 (signals-error (union (list 1 2) (list 3 4) :key #'car) type-error) t) (deftest union.error.11 (signals-error (union (list 1 2 3) (list* 4 5 6)) type-error) t) (deftest union.error.12 (signals-error (union (list* 1 2 3) (list 4 5 6)) type-error) t) ;;; The next two tests used to check for union with NIL, but arguably ;;; that goes beyond the 'be prepared to signal an error' requirement, ;;; since a union algorithm doesn't have to traverse one argument ;;; if the other is the empty list. (deftest union.error.13 (check-type-error #'(lambda (x) (union x '(1 2))) #'listp) nil) (deftest union.error.14 (check-type-error #'(lambda (x) (union '(1 2) x)) #'listp) nil) gcl27-2.7.0/ansi-tests/universe.lsp000066400000000000000000000345601454061450500171240ustar00rootroot00000000000000;-*- 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) (defparameter *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)) (defparameter *condition-objects* (locally (declare (optimize safety)) (loop for tp in *condition-types* append (handler-case (list (make-condition tp)) (error () nil))))) (defparameter *standard-package-names* '("COMMON-LISP" "COMMON-LISP-USER" "KEYWORD")) (defparameter *package-objects* (locally (declare (optimize safety)) (loop for pname in *standard-package-names* append (handler-case (let ((pkg (find-package pname))) (and pkg (list pkg))) (error () nil))))) (defparameter *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))) (defparameter *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))) (defparameter *ratios* '(1/3 1/1000 1/1000000000000000 -10/3 -1000/7 -987129387912381/13612986912361 189729874978126783786123/1234678123487612347896123467851234671234)) (defparameter *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) #C(10.0s0 20.0s0) #C(100.0l0 200.0l0) #C(1.0s0 2.0f0) #C(1.0s0 3.0d0) #C(1.0s0 4.0l0) #C(1.0f0 5.0d0) #C(1.0f0 6.0l0) #C(1.0d0 7.0l0) #C(1.0f0 2.0s0) #C(1.0d0 3.0s0) #C(1.0l0 4.0s0) #C(1.0d0 5.0f0) #C(1.0l0 6.0f0) #C(1.0l0 7.0d0) #C(1/2 1/3) )) (defparameter *numbers* (append *integers* *floats* *ratios* *complexes*)) (defparameter *reals* (append *integers* *floats* *ratios*)) (defparameter *rationals* (append *integers* *ratios*)) (defun try-to-read-chars (&rest namelist) (declare (optimize safety)) (loop for name in namelist append (handler-case (list (read-from-string (concatenate 'string "\#\\" name))) (error () nil)))) (defparameter *characters* (remove-duplicates `(#\Newline #\Space ,@(try-to-read-chars "Rubout" "Page" "Tab" "Backspace" "Return" "Linefeed" "Null") #\a #\A #\0 #\9 #\. #\( #\) #\[ #\] ))) (defparameter *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) ;; Specialized strings (make-array 3 :element-type 'character :displaced-to (make-array 5 :element-type 'character :initial-contents "abcde") :displaced-index-offset 1) (make-array 10 :initial-element #\x :fill-pointer 5 :element-type 'character) (make-array 10 :initial-element #\x :element-type 'base-char) (make-array 3 :initial-element #\y :adjustable t :element-type 'base-char) ))) (defparameter *conses* (list (list 'a 'b) (list nil) (list 1 2 3 4 5 6))) (defparameter *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)))) (defparameter *booleans* '(nil t)) (defparameter *keywords* '(:a :b :|| :|a| :|1234|)) (defparameter *uninterned-symbols* (list '#:nil '#:t '#:foo '#:||)) (defparameter *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)))) )) (defparameter *cl-user-symbols* '(cl-user::foo cl-user::x cl-user::cons cl-user::lambda cl-user::*print-readably* cl-user::push)) (defparameter *symbols* (append *booleans* *keywords* *uninterned-symbols* *cl-test-symbols* *cl-user-symbols*)) (defparameter *array-dimensions* (loop for i from 0 to 8 collect (loop for j from 1 to i collect 2))) (defparameter *default-array-target* (make-array '(300))) (defparameter *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)) for element in '(18 16.0f0 0 #\x #\y 127 200) append (loop for d in *array-dimensions* collect (make-array d :element-type tp :initial-element element))) ;; More typed arrays (loop for i from 1 to 64 append (list (make-array 10 :element-type `(unsigned-byte ,i) :initial-element 1) (make-array 10 :element-type `(signed-byte ,i) :initial-element 0))) ;; 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 (make-array 10 :element-type 'bit :initial-contents '(0 1 1 0 1 1 1 1 0 1) :fill-pointer 8) (make-array 5 :element-type 'bit :displaced-to #*0111000110 :displaced-index-offset 3) (make-array 10 :element-type 'bit :initial-contents '(1 1 0 0 1 1 1 0 1 1) :adjustable t) ) ;; 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)) ) ;; The ever-popular NIL array (locally (declare (optimize safety)) (handler-case (list (make-array '(0) :element-type nil)) (error () nil))) ;; more kinds of arrays here later? )) (defparameter *hash-tables* (list (make-hash-table) (make-hash-table :test #'eq) (make-hash-table :test #'eql) (make-hash-table :test #'equal) #-(or CMU ECL) (make-hash-table :test #'equalp) )) (defparameter *pathnames* (locally (declare (optimize safety)) (loop for form in '((make-pathname :name "foo") (make-pathname :name "FOO" :case :common) (make-pathname :name "bar") (make-pathname :name "foo" :type "txt") (make-pathname :name "bar" :type "txt") (make-pathname :name "XYZ" :type "TXT" :case :common) (make-pathname :name nil) (make-pathname :name :wild) (make-pathname :name nil :type "txt") (make-pathname :name :wild :type "txt") (make-pathname :name :wild :type "TXT" :case :common) (make-pathname :name :wild :type "abc" :case :common) (make-pathname :directory :wild) (make-pathname :type :wild) (make-pathname :version :wild) (make-pathname :version :newest)) append (ignore-errors (eval `(list ,form)))))) (eval-when (:compile-toplevel :load-toplevel :execute) (locally (declare (optimize safety)) (ignore-errors (setf (logical-pathname-translations "CLTESTROOT") `(("**;*.*.*" ,(make-pathname :directory '(:absolute :wild-inferiors) :name :wild :type :wild))))) (ignore-errors (setf (logical-pathname-translations "CLTEST") `(("**;*.*.*" ,(make-pathname :directory (append (pathname-directory (truename (make-pathname))) '(:wild-inferiors)) :name :wild :type :wild))))) )) (defparameter *logical-pathnames* (locally (declare (optimize safety)) (append (ignore-errors (list (logical-pathname "CLTESTROOT:"))) ))) (defparameter *streams* (remove-duplicates (remove-if #'null (list *debug-io* *error-output* *query-io* *standard-input* *standard-output* *terminal-io* *trace-output*)))) (defparameter *readtables* (list *readtable* (copy-readtable))) (defstruct foo-structure x y z) (defstruct bar-structure x y z) (defparameter *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) )) (defun meaningless-user-function-for-universe (x y z) (list (+ x 1) (+ y 2) (+ z 3))) (defgeneric meaningless-user-generic-function-for-universe (x y z) #+(or (not :gcl) :ansi-cl) (:method ((x integer) (y integer) (z integer)) (+ x y z))) (eval-when (:load-toplevel :execute) (compile 'meaningless-user-function-for-universe) ;; Conditionalize to avoid a cmucl bug #-(or cmu gcl ecl) (compile 'meaningless-user-generic-function-for-universe) ) (defparameter *functions* (list #'cons #'car #'append #'values (macro-function 'cond) #'meaningless-user-function-for-universe #'meaningless-user-generic-function-for-universe #'(lambda (x) x) (compile nil '(lambda (x) x)))) (defparameter *methods* (list #+(or (not :gcl) :ansi-cl ) (find-method #'meaningless-user-generic-function-for-universe nil (mapcar #'find-class '(integer integer integer))) ;; Add more methods here )) (defparameter *random-states* (list (make-random-state))) (defparameter *universe* (remove-duplicates (append *symbols* *numbers* *characters* (mapcar #'copy-seq *strings*) *conses* *condition-objects* *package-objects* *arrays* *hash-tables* *pathnames* *logical-pathnames* *streams* *readtables* *structures* *functions* *random-states* *methods* nil))) (defparameter *mini-universe* (remove-duplicates (append (mapcar #'first (list *symbols* *numbers* *characters* (list (copy-seq (first *strings*))) *conses* *condition-objects* *package-objects* *arrays* *hash-tables* *pathnames* *logical-pathnames* *streams* *readtables* *structures* *functions* *random-states* *methods*)) '(;;; Others to fill in gaps 1.2s0 1.3f0 1.5d0 1.8l0 3/5 10000000000000000000000)))) (defparameter *classes* (remove-duplicates (mapcar #'class-of *universe*))) (defparameter *built-in-classes* (remove-if-not #'(lambda (x) (typep x 'built-in-class)) *classes*)) gcl27-2.7.0/ansi-tests/unless.lsp000066400000000000000000000031331454061450500165650ustar00rootroot00000000000000;-*- 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) ;;; No implicit tagbody (deftest unless.10 (block done (tagbody (unless nil (go 10) 10 (return-from done 'bad)) 10 (return-from done 'good))) good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest unless.11 (macrolet ((%m (z) z)) (unless (expand-in-current-env (%m nil)) :good)) :good) (deftest unless.12 (macrolet ((%m (z) z)) (unless (expand-in-current-env (%m t)) :bad)) nil) (deftest unless.13 (macrolet ((%m (z) z)) (let ((x 1) (p nil)) (values (unless p (expand-in-current-env (%m (incf x)))) x))) 2 2) (deftest unless.error.1 (signals-error (funcall (macro-function 'unless)) program-error) t) (deftest unless.error.2 (signals-error (funcall (macro-function 'unless) '(unless t)) program-error) t) (deftest unless.error.3 (signals-error (funcall (macro-function 'unless) '(unless t) nil nil) program-error) t) gcl27-2.7.0/ansi-tests/unread-char.lsp000066400000000000000000000034221454061450500174460ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 18 20:05:36 2004 ;;;; Contains: Tests of UNREAD-CHAR (in-package :cl-test) (deftest unread-char.1 (with-input-from-string (*standard-input* "abc") (values (read-char) (unread-char #\a) (read-char) (read-char) (unread-char #\b) (read-char) (read-char))) #\a nil #\a #\b nil #\b #\c) (deftest unread-char.2 (with-input-from-string (s "abc") (values (read-char s) (unread-char #\a s) (read-char s) (read-char s) (unread-char #\b s) (read-char s) (read-char s))) #\a nil #\a #\b nil #\b #\c) (deftest unread-char.3 (with-input-from-string (is "abc") (with-output-to-string (os) (let ((s (make-echo-stream is os))) (read-char s) (unread-char #\a s) (read-char s) (read-char s) (read-char s) (unread-char #\c s) (read-char s)))) "abc") (deftest unread-char.4 (with-input-from-string (*standard-input* "abc") (values (read-char) (unread-char #\a nil) (read-char) (read-char) (unread-char #\b nil) (read-char) (read-char))) #\a nil #\a #\b nil #\b #\c) (deftest unread-char.5 (with-input-from-string (is "abc") (let ((*terminal-io* (make-two-way-stream is (make-string-output-stream)))) (values (read-char t) (unread-char #\a t) (read-char t) (read-char t) (unread-char #\b t) (read-char t) (read-char t)))) #\a nil #\a #\b nil #\b #\c) ;;; Error tests (deftest unread-char.error.1 (signals-error (unread-char) program-error) t) (deftest unread-char.error.2 (signals-error (with-input-from-string (s "abc") (read-char s) (unread-char #\a s nil)) program-error) t) gcl27-2.7.0/ansi-tests/unuse-package.lsp000066400000000000000000000217341454061450500200130ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:06:48 1998 ;;;; Contains: Tests of UNUSE-PACKAGE (in-package :cl-test) (compile-and-load "package-aux.lsp") (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) ;;; Specialized sequences (defmacro def-unuse-package-test (test-name &key (user "H") (used "G")) `(deftest ,test-name (let ((user-name ,user) (used-name ,used)) (safely-delete-package user-name) (safely-delete-package used-name) (let* ((pused (make-package used-name :use nil)) (puser (make-package user-name :use (list used-name)))) (prog1 (and (equal (package-use-list puser) (list pused)) (equal (package-used-by-list pused) (list puser)) (unuse-package (list used-name) user-name) (equal (package-use-list puser) nil) (null (package-used-by-list pused))) (safely-delete-package user-name) (safely-delete-package used-name)))) t)) ;;; Specialized user package designator (def-unuse-package-test unuse-package.10 :user (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) (def-unuse-package-test unuse-package.11 :user (make-array 10 :initial-contents "TEST1ABCDE" :fill-pointer 5 :element-type 'base-char)) (def-unuse-package-test unuse-package.12 :user (make-array 10 :initial-contents "TEST1ABCDE" :fill-pointer 5 :element-type 'character)) (def-unuse-package-test unuse-package.13 :user (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'base-char)) (def-unuse-package-test unuse-package.14 :user (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'character)) (def-unuse-package-test unuse-package.15 :user (let* ((etype 'base-char) (name0 (make-array 10 :element-type etype :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 5))) (def-unuse-package-test unuse-package.16 :user (let* ((etype 'character) (name0 (make-array 10 :element-type etype :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 5))) ;;; Specialed used package designator (def-unuse-package-test unuse-package.17 :used (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) (def-unuse-package-test unuse-package.18 :used (make-array 10 :initial-contents "TEST1ABCDE" :fill-pointer 5 :element-type 'base-char)) (def-unuse-package-test unuse-package.19 :used (make-array 10 :initial-contents "TEST1ABCDE" :fill-pointer 5 :element-type 'character)) (def-unuse-package-test unuse-package.20 :used (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'base-char)) (def-unuse-package-test unuse-package.21 :used (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'character)) (def-unuse-package-test unuse-package.22 :used (let* ((etype 'base-char) (name0 (make-array 10 :element-type etype :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 5))) (def-unuse-package-test unuse-package.23 :used (let* ((etype 'character) (name0 (make-array 10 :element-type etype :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 5))) ;;; Error tests (deftest unuse-package.error.1 (signals-error (unuse-package) program-error) t) (deftest unuse-package.error.2 (progn (safely-delete-package "UPE2A") (safely-delete-package "UPE2") (make-package "UPE2" :use ()) (make-package "UPE2A" :use '("UPE2")) (signals-error (unuse-package "UPE2" "UPE2A" nil) program-error)) t) gcl27-2.7.0/ansi-tests/unwind-protect.lsp000066400000000000000000000046321454061450500202430ustar00rootroot00000000000000;-*- 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)) ;;; No implicit tagbody (deftest unwind-protect.10 (block done (tagbody (unwind-protect 'foo (go 10) 10 (return-from done 'bad)) 10 (return-from done 'good))) good) ;;; Executes all forms of the implicit progn (deftest unwind-protect.11 (let ((x nil) (y nil)) (values (block nil (unwind-protect (return 'a) (setf y 'c) (setf x 'b))) x y)) a b c) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest unwind-protect.12 (macrolet ((%m (z) z)) (unwind-protect (expand-in-current-env (%m :good)) :bad)) :good) (deftest unwind-protect.13 (macrolet ((%m (z) z)) (unwind-protect :good (expand-in-current-env (%m :bad)))) :good) gcl27-2.7.0/ansi-tests/update-instance-for-different-class.lsp000066400000000000000000000074001454061450500241740ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon May 5 19:32:56 2003 ;;;; Contains: Tests for UPDATE-INSTANCE-FOR-DIFFERENT-CLASS (in-package :cl-test) (defclass uifdc-class-01a () ((a :initarg :a) (b :initarg :b))) (defclass uifdc-class-01b () (a b)) (declaim (special *uifdc-01-obj*)) (defmethod update-instance-for-different-class ((from-obj uifdc-class-01a) (to-obj uifdc-class-01b) &rest initargs &key &allow-other-keys) (declare (ignore initargs)) (assert (not (eq *uifdc-01-obj* from-obj))) (assert (eq *uifdc-01-obj* to-obj)) (if (slot-boundp from-obj 'a) (setf (slot-value to-obj 'b) (slot-value from-obj 'a)) (slot-makunbound to-obj 'b)) (if (slot-boundp from-obj 'b) (setf (slot-value to-obj 'a) (slot-value from-obj 'b)) (slot-makunbound to-obj 'a)) to-obj) (deftest update-instance-for-different-class.1 (let* ((obj (make-instance 'uifdc-class-01a)) (new-class (find-class 'uifdc-class-01b)) (*uifdc-01-obj* obj)) (values (map-slot-boundp* obj '(a b)) (eqt obj (change-class obj new-class)) (typep* obj new-class) (map-slot-boundp* obj '(a b)))) (nil nil) t t (nil nil)) (deftest update-instance-for-different-class.2 (let* ((obj (make-instance 'uifdc-class-01a :a 1)) (new-class (find-class 'uifdc-class-01b)) (*uifdc-01-obj* obj)) (values (map-slot-boundp* obj '(a b)) (eqt obj (change-class obj new-class)) (typep* obj new-class) (map-slot-boundp* obj '(a b)) (slot-value obj 'b))) (t nil) t t (nil t) 1) (deftest update-instance-for-different-class.3 (let* ((obj (make-instance 'uifdc-class-01a :b 1)) (new-class (find-class 'uifdc-class-01b)) (*uifdc-01-obj* obj)) (values (map-slot-boundp* obj '(a b)) (eqt obj (change-class obj new-class)) (typep* obj new-class) (map-slot-boundp* obj '(a b)) (slot-value obj 'a))) (nil t) t t (t nil) 1) (deftest update-instance-for-different-class.4 (let* ((obj (make-instance 'uifdc-class-01a :a 1 :b 2)) (new-class (find-class 'uifdc-class-01b)) (*uifdc-01-obj* obj)) (values (map-slot-boundp* obj '(a b)) (eqt obj (change-class obj new-class)) (typep* obj new-class) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) (t t) t t (t t) 2 1) ;;; after method (defclass uifdc-class-02 () ((a :initform 'x :initarg :a) (b :initarg :b))) (defmethod update-instance-for-different-class :after ((from-obj uifdc-class-01a) (to-obj uifdc-class-02) &rest initargs &key &allow-other-keys) (declare (ignore initargs)) (setf (slot-value to-obj 'a) 100) to-obj) (deftest update-instance-for-different-class.5 (let* ((obj (make-instance 'uifdc-class-01a)) (class (find-class 'uifdc-class-02))) (values (eqt obj (change-class obj class)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a))) t (t nil) 100) (deftest update-instance-for-different-class.6 (let* ((obj (make-instance 'uifdc-class-01a :a 1)) (class (find-class 'uifdc-class-02))) (values (eqt obj (change-class obj class)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a))) t (t nil) 100) (deftest update-instance-for-different-class.7 (let* ((obj (make-instance 'uifdc-class-01a :b 17)) (class (find-class 'uifdc-class-02))) (values (eqt obj (change-class obj class)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) t (t t) 100 17) (deftest update-instance-for-different-class.8 (let* ((obj (make-instance 'uifdc-class-01a :b 17 :a 4)) (class (find-class 'uifdc-class-02))) (values (eqt obj (change-class obj class)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) t (t t) 100 17) gcl27-2.7.0/ansi-tests/upgraded-array-element-type.lsp000066400000000000000000000072341454061450500225770ustar00rootroot00000000000000;-*- 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 `(eql ,(ash 1 i))) ,@(loop for i from 0 to 32 collect `(eql ,(1- (ash 1 i)))) (eql -1) ,@(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) unless (empirical-subtypep type upgraded-type) collect (list type upgraded-type)) nil) ;; 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) unless (empirical-subtypep type upgraded-type) collect (list type upgraded-type)) nil) (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 that if Tx is a subtype of Ty, then UAET(Tx) is a subtype ;;; of UAET(Ty) (see section 15.1.2.1, paragraph 3) (deftest upgraded-array-element-type.8 (let ((upgraded-types (mapcar #'upgraded-array-element-type *upgraded-array-types-to-check*))) (loop for type1 in *upgraded-array-types-to-check* for uaet1 in upgraded-types append (loop for type2 in *upgraded-array-types-to-check* for uaet2 in upgraded-types when (and (subtypep type1 type2) (not (empirical-subtypep uaet1 uaet2))) collect (list type1 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))) (check-predicate (typef `(not ,uaet-nil)))) nil) ;;; Error tests (deftest upgraded-array-element-type.error.1 (signals-error (upgraded-array-element-type) program-error) t) (deftest upgraded-array-element-type.error.2 (signals-error (upgraded-array-element-type 'bit nil nil) program-error) t) gcl27-2.7.0/ansi-tests/upgraded-complex-part-type.lsp000066400000000000000000000064541454061450500224500ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Nov 27 21:15:46 2004 ;;;; Contains: Tests of UPGRADE-COMPLEX-PART-TYPE (in-package :cl-test) (compile-and-load "types-aux.lsp") (defmacro def-ucpt-test (name types) `(deftest ,name (loop for type in (remove-duplicates ,types) for upgraded-type = (upgraded-complex-part-type type) for result = (append (check-all-subtypep type upgraded-type) (check-all-subtypep type 'real) (check-all-subtypep `(complex ,type) 'complex) (check-all-subtypep `(complex ,upgraded-type) 'complex) (check-all-subtypep `(complex ,type) `(complex ,upgraded-type))) when result collect result) nil)) (def-ucpt-test upgraded-complex-part-type.1 '(real integer rational ratio float short-float single-float double-float long-float fixnum bignum bit unsigned-byte signed-byte)) (def-ucpt-test upgraded-complex-part-type.2 (mapcar #'find-class '(real float integer rational ratio))) (def-ucpt-test upgraded-complex-part-type.3 (mapcar #'class-of '(1.0s0 1.0f0 1.0d0 1.0l0))) (def-ucpt-test upgraded-complex-part-type.4 (loop for i from 1 to 100 collect `(unsigned-byte ,i))) (def-ucpt-test upgraded-complex-part-type.5 (loop for i from 1 to 100 collect `(signed-byte ,i))) (def-ucpt-test upgraded-complex-part-type.6 (loop for i = 1 then (* i 2) repeat 100 collect (class-of i))) ;;; environment argument (deftest upgraded-complex-part-type.7 (loop for type in '(real integer rational float short-float single-float double-float long-float fixnum bignum bit unsigned-byte signed-byte) for ut1 = (upgraded-complex-part-type type) for ut2 = (upgraded-complex-part-type type nil) unless (equal ut1 ut2) collect (list type ut1 ut2)) nil) (deftest upgraded-complex-part-type.8 (loop for type in '(real integer rational float short-float single-float double-float long-float fixnum bignum bit unsigned-byte signed-byte) for ut1 = (upgraded-complex-part-type type) for ut2 = (eval `(macrolet ((%m (&environment env) (list 'quote (upgraded-complex-part-type ',type env)))) (%m))) unless (equal ut1 ut2) collect (list type ut1 ut2)) nil) ;;; Subtype constraint (deftest upgraded-complex-part-type.9 (let* ((types `(nil integer fixnum bignum float short-float single-float double-float long-float rational #-sbcl ratio real ,@(remove-duplicates (mapcar #'class-of '(0.0s0 0.0f0 0.0d0 0.0l0 0 100000000000000000))) ,@(mapcar #'(lambda (x) `(eql ,x)) (remove-duplicates '(0.0s0 0.0f0 0.0d0 0.0l0 0 1.0s0 1.0f0 1.0d0 1.0l0 1 100000000000000000))))) (utypes (mapcar #'upgraded-complex-part-type types))) (loop for sublist on types for usublist on utypes for tp1 = (car sublist) for utp1 = (car usublist) nconc (loop for tp2 in (cdr sublist) for utp2 in (cdr usublist) nconc (and (subtypep tp1 tp2) (let ((result (check-all-subtypep utp1 utp2))) (and result (list (list tp1 tp2 result)))))))) nil) ;;; Error tests (deftest upgraded-complex-part-type.error.1 (signals-error (upgraded-complex-part-type) program-error) t) (deftest upgraded-complex-part-type.error.2 (signals-error (upgraded-complex-part-type 'real nil nil) program-error) t) gcl27-2.7.0/ansi-tests/use-package.lsp000066400000000000000000000245741454061450500174550ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:08:41 1998 ;;;; Contains: Tests of USE-PACKAGE (in-package :cl-test) (compile-and-load "package-aux.lsp") (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) ;; Check that *PACKAGE* is used as a default (deftest use-package.7 (let ((user-name "H") (used-name "G")) (safely-delete-package user-name) (safely-delete-package used-name) (let* ((pused (make-package used-name :use nil)) (puser (make-package user-name :use nil)) (sym1 (intern "FOO" pused))) (and (eqt (export sym1 pused) t) (null (package-used-by-list pused)) (null (package-used-by-list puser)) (null (package-use-list pused)) (null (package-use-list puser)) (eqt (let ((*package* puser)) (use-package pused)) t) ;; user will use used (multiple-value-bind (sym2 access) (find-symbol "FOO" puser) (and (eqt access :inherited) (eqt sym1 sym2))) (equal (package-use-list puser) (list pused)) (equal (package-used-by-list pused) (list puser)) (null (package-use-list pused)) (null (package-used-by-list puser)) (eqt (unuse-package pused puser) t) (null (find-symbol "FOO" puser))))) t) ;;; Tests for specialized sequence arguments (defmacro def-use-package-test (test-name &key (user "H") (used "G")) `(deftest ,test-name (let ((user-name ,user) (used-name ,used)) (safely-delete-package user-name) (safely-delete-package used-name) (let* ((pused (make-package used-name :use nil)) (puser (make-package user-name :use nil)) (sym1 (intern "FOO" pused))) (and (eqt (export sym1 pused) t) (null (package-used-by-list pused)) (null (package-used-by-list puser)) (null (package-use-list pused)) (null (package-use-list puser)) (eqt (let ((*package* puser)) (use-package pused)) t) ;; user will use used (multiple-value-bind (sym2 access) (find-symbol "FOO" puser) (and (eqt access :inherited) (eqt sym1 sym2))) (equal (package-use-list puser) (list pused)) (equal (package-used-by-list pused) (list puser)) (null (package-use-list pused)) (null (package-used-by-list puser)) (eqt (unuse-package pused puser) t) (null (find-symbol "FOO" puser))))) t)) ;;; Specialized user package designator (def-use-package-test use-package.10 :user (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) (def-use-package-test use-package.11 :user (make-array 10 :initial-contents "TEST1ABCDE" :fill-pointer 5 :element-type 'base-char)) (def-use-package-test use-package.12 :user (make-array 10 :initial-contents "TEST1ABCDE" :fill-pointer 5 :element-type 'character)) (def-use-package-test use-package.13 :user (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'base-char)) (def-use-package-test use-package.14 :user (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'character)) (def-use-package-test use-package.15 :user (let* ((etype 'base-char) (name0 (make-array 10 :element-type etype :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 5))) (def-use-package-test use-package.16 :user (let* ((etype 'character) (name0 (make-array 10 :element-type etype :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 5))) ;;; Specialed used package designator (def-use-package-test use-package.17 :used (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) (def-use-package-test use-package.18 :used (make-array 10 :initial-contents "TEST1ABCDE" :fill-pointer 5 :element-type 'base-char)) (def-use-package-test use-package.19 :used (make-array 10 :initial-contents "TEST1ABCDE" :fill-pointer 5 :element-type 'character)) (def-use-package-test use-package.20 :used (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'base-char)) (def-use-package-test use-package.21 :used (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'character)) (def-use-package-test use-package.22 :used (let* ((etype 'base-char) (name0 (make-array 10 :element-type etype :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 5))) (def-use-package-test use-package.23 :used (let* ((etype 'character) (name0 (make-array 10 :element-type etype :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 5))) (deftest use-package.error.1 (signals-error (use-package) program-error) t) (deftest use-package.error.2 (progn (safely-delete-package "UPE2A") (safely-delete-package "UPE2") (make-package "UPE2" :use ()) (make-package "UPE2A" :use ()) (signals-error (use-package "UPE2" "UPE2A" nil) program-error)) t) gcl27-2.7.0/ansi-tests/use-value.lsp000066400000000000000000000023331454061450500171630ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 23 09:13:59 2003 ;;;; Contains: Tests for USE-VALUE restart and function (in-package :cl-test) (deftest use-value.1 (restart-case (progn (use-value 10) 'bad) (use-value (x) (list x 'good))) (10 good)) (deftest use-value.2 (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 (list (first (compute-restarts))) (use-value 17 c2)) (use-value (x) (list x 'bad)) (use-value (x) (list x 'good)))) (17 good)) (deftest use-value.3 (restart-case (progn (use-value 11 nil) 'bad) (use-value (x) (list x 'good))) (11 good)) (deftest use-value.4 (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 (list (first (compute-restarts))) (use-value 18 nil)) (use-value (x) (list x 'good)) (use-value (x) (list x 'bad)))) (18 good)) (deftest use-value.5 (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (with-condition-restarts c1 (compute-restarts) ;; All conditions are now associated with c1 (use-value 21 c2))) nil) gcl27-2.7.0/ansi-tests/user-homedir-pathname.lsp000066400000000000000000000022561454061450500214570ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Dec 11 22:26:24 2004 ;;;; Contains: Tests of USER-HOMEDIR-PATHNAME (in-package :cl-test) (deftest user-homedir-pathname.1 (let ((pn (user-homedir-pathname))) (notnot pn)) t) (deftest user-homedir-pathname.2 (let* ((pn-list (multiple-value-list (user-homedir-pathname))) (pn (first pn-list))) (values (length pn-list) (notnot-mv (pathnamep pn)))) 1 t) (deftest user-homedir-pathname.3 (let ((pn (user-homedir-pathname))) (pathname-name pn)) nil) (deftest user-homedir-pathname.4 (let ((pn (user-homedir-pathname))) (pathname-type pn)) nil) (deftest user-homedir-pathname.5 (let ((pn (user-homedir-pathname))) (pathname-version pn)) nil) ;; (deftest user-homedir-pathname.6 ;; (let* ((pn (user-homedir-pathname)) ;; (host (pathname-host pn))) ;; (or (not host) ;; (equalt pn (user-homedir-pathname host)))) ;; t) (deftest user-homedir-pathname.7 (let* ((pn (user-homedir-pathname :unspecific))) (or (null pn) (notnot (pathnamep pn)))) t) (deftest user-homedir-pathname.error.1 (signals-error (user-homedir-pathname :unspecific nil) program-error) t) gcl27-2.7.0/ansi-tests/values-list.lsp000066400000000000000000000016661454061450500175350ustar00rootroot00000000000000;-*- 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 (signals-error (values-list) program-error) t) (deftest values-list.error.2 (signals-error (values-list nil nil) program-error) t) (deftest values-list.error.3 (check-type-error #'values-list #'list) nil) (deftest values-list.error.4 (signals-error (values-list '(a b c . d)) type-error) t) (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) gcl27-2.7.0/ansi-tests/values.lsp000066400000000000000000000030071454061450500165530ustar00rootroot00000000000000;-*- 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.20 (let ((a t) (b t) (c t) (d t) (e t) (f t)) (setf (values a (values b c) (values d) (values e f)) (values 0 1 2 3 4 5 6)) (list a b c d e f)) (0 1 nil 2 3 nil)) (deftest values.21 (let (a b c d e f) (setf (values a (values b c) (values d) (values e f)) (values 0 1 2 3 4 5 6))) 0 1 2 3) (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) gcl27-2.7.0/ansi-tests/vector-pop.lsp000066400000000000000000000020141454061450500173470ustar00rootroot00000000000000;-*- 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 (signals-error (let ((v (vector 1 2 3))) (if (array-has-fill-pointer-p v) (error 'type-error :datum v :expected-type nil) (vector-pop v))) type-error) t) (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 (signals-error (vector-pop) program-error) t) (deftest vector-pop.error.4 (signals-error (let ((v (make-array '(5) :fill-pointer t :initial-element 'x))) (vector-pop v nil)) program-error) t) gcl27-2.7.0/ansi-tests/vector-push-extend.lsp000066400000000000000000000373601454061450500210310ustar00rootroot00000000000000;-*- 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)) ;;; Tests on displaced arrays (deftest vector-push-extend.21 (let* ((a1 (make-array 10 :initial-element nil)) (a2 (make-array 6 :displaced-to a1 :displaced-index-offset 2 :fill-pointer 0))) (values (fill-pointer a2) (map 'list #'identity a2) (vector-push-extend 'foo a2) (fill-pointer a2) (map 'list #'identity a2) (map 'list #'identity a1))) 0 () 0 1 (foo) (nil nil foo nil nil nil nil nil nil nil)) (deftest vector-push-extend.22 (let* ((a1 (make-array 6 :initial-element nil)) (a2 (make-array 0 :displaced-to a1 :displaced-index-offset 2 :adjustable t :fill-pointer 0))) (values (fill-pointer a2) (map 'list #'identity a2) (vector-push-extend 'foo a2) (fill-pointer a2) (map 'list #'identity a2) (map 'list #'identity a1) (notnot (adjustable-array-p a2)) (multiple-value-list (array-displacement a2)) )) 0 () 0 1 (foo) (nil nil nil nil nil nil) t (nil 0)) (deftest vector-push-extend.23 (let* ((a1 (make-array 10 :initial-element nil)) (a2 (make-array 6 :displaced-to a1 :displaced-index-offset 2 :adjustable t :fill-pointer 1))) (values (fill-pointer a2) (map 'list #'identity a2) (vector-push-extend 'foo a2) (fill-pointer a2) (map 'list #'identity a2) (map 'list #'identity a1) (notnot (adjustable-array-p a2)) (eqt (array-displacement a2) a1) (nth-value 1 (array-displacement a2)) )) 1 (nil) 1 2 (nil foo) (nil nil nil foo nil nil nil nil nil nil) t t 2) (deftest vector-push-extend.24 (let* ((a1 (make-array 4 :initial-element nil)) (a2 (make-array 2 :displaced-to a1 :displaced-index-offset 2 :adjustable t :fill-pointer 2))) (values (map 'list #'identity a1) (map 'list #'identity a2) (vector-push-extend 'foo a2 7) (fill-pointer a2) (map 'list #'identity a1) (map 'list #'identity a2) (array-dimension a2 0) (notnot (adjustable-array-p a2)) (multiple-value-list (array-displacement a2)))) (nil nil nil nil) (nil nil) 2 3 (nil nil nil nil) (nil nil foo) 9 t (nil 0)) ;;; Integer vectors (deftest vector-push-extend.25 (loop for adj in '(nil t) nconc (loop for bits from 1 to 64 for etype = `(unsigned-byte ,bits) for a1 = (make-array 10 :initial-element 0 :element-type etype) for a2 =(make-array 6 :element-type etype :displaced-to a1 :displaced-index-offset 2 :adjustable adj :fill-pointer 0) for result = (list (fill-pointer a2) (map 'list #'identity a2) (vector-push-extend 1 a2) (fill-pointer a2) (map 'list #'identity a2) (map 'list #'identity a1)) unless (equal result '(0 () 0 1 (1) (0 0 1 0 0 0 0 0 0 0))) collect (list etype adj result))) nil) (deftest vector-push-extend.26 (loop for bits from 1 to 64 for etype = `(unsigned-byte ,bits) for a1 = (make-array 8 :initial-element 0 :element-type etype) for a2 = (make-array 6 :element-type etype :displaced-to a1 :displaced-index-offset 2 :adjustable t :fill-pointer 6) for result = (list (fill-pointer a2) (map 'list #'identity a2) (vector-push-extend 1 a2) (fill-pointer a2) (map 'list #'identity a2) (map 'list #'identity a1) (notnot (adjustable-array-p a2)) (multiple-value-list (array-displacement a1))) unless (equal result '(6 (0 0 0 0 0 0) 6 7 (0 0 0 0 0 0 1) (0 0 0 0 0 0 0 0) t (nil 0))) collect (list etype result)) nil) ;;; strings (deftest vector-push-extend.27 (loop for adj in '(nil t) nconc (loop for etype in '(character base-char standard-char) for a1 = (make-array 10 :initial-element #\a :element-type etype) for a2 =(make-array 6 :element-type etype :displaced-to a1 :displaced-index-offset 2 :adjustable adj :fill-pointer 0) for result = (list (fill-pointer a2) (map 'list #'identity a2) (vector-push-extend #\b a2) (fill-pointer a2) (map 'list #'identity a2) (map 'list #'identity a1)) unless (equal result '(0 () 0 1 (#\b) (#\a #\a #\b #\a #\a #\a #\a #\a #\a #\a))) collect (list etype adj result))) nil) (deftest vector-push-extend.28 (loop for etype in '(character base-char standard-char) for a1 = (make-array 8 :initial-element #\a :element-type etype) for a2 = (make-array 6 :element-type etype :displaced-to a1 :displaced-index-offset 2 :adjustable t :fill-pointer 6) for result = (list (fill-pointer a2) (map 'list #'identity a2) (vector-push-extend #\b a2) (fill-pointer a2) (map 'list #'identity a2) (map 'list #'identity a1) (notnot (adjustable-array-p a2)) (multiple-value-list (array-displacement a1))) unless (equal result '(6 #.(coerce "aaaaaa" 'list) 6 7 #.(coerce "aaaaaab" 'list) #.(coerce "aaaaaaaa" 'list) t (nil 0))) collect (list etype result)) nil) ;;; float tests (deftest vector-push-extend.29 (loop for adj in '(nil t) nconc (loop for etype in '(short-float single-float double-float long-float) for zero in '(0.0s0 0.0f0 0.0d0 0.0l0) for one in '(1.0s0 1.0f0 1.0d0 1.0l0) for a1 = (make-array 10 :initial-element zero :element-type etype) for a2 =(make-array 6 :element-type etype :displaced-to a1 :displaced-index-offset 2 :adjustable adj :fill-pointer 0) for result = (list (fill-pointer a2) (map 'list #'identity a2) (vector-push-extend one a2) (fill-pointer a2) (map 'list #'identity a2) (map 'list #'identity a1)) unless (equal result `(0 () 0 1 (,one) (,zero ,zero ,one ,zero ,zero ,zero ,zero ,zero ,zero ,zero))) collect (list etype adj result))) nil) (deftest vector-push-extend.30 (loop for etype in '(short-float single-float double-float long-float) for zero in '(0.0s0 0.0f0 0.0d0 0.0l0) for one in '(1.0s0 1.0f0 1.0d0 1.0l0) for a1 = (make-array 8 :initial-element zero :element-type etype) for a2 = (make-array 6 :element-type etype :displaced-to a1 :displaced-index-offset 2 :adjustable t :fill-pointer 6) for result = (list (fill-pointer a2) (map 'list #'identity a2) (vector-push-extend one a2) (fill-pointer a2) (map 'list #'identity a2) (map 'list #'identity a1) (notnot (adjustable-array-p a2)) (multiple-value-list (array-displacement a1))) unless (equal result `(6 (,zero ,zero ,zero ,zero ,zero ,zero) 6 7 (,zero ,zero ,zero ,zero ,zero ,zero ,one) (,zero ,zero ,zero ,zero ,zero ,zero ,zero ,zero) t (nil 0))) collect (list etype result)) nil) ;;; 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 (signals-error (vector-push-extend) program-error) t) (deftest vector-push-extend.error.15 (signals-error (vector-push-extend (vector 1 2 3)) program-error) t) (deftest vector-push-extend.error.16 (signals-error (vector-push-extend (vector 1 2 3) 4 1 nil) program-error) t) (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) gcl27-2.7.0/ansi-tests/vector-push.lsp000066400000000000000000000166241454061450500175440ustar00rootroot00000000000000;-*- 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 (signals-error (vector-push) program-error) t) (deftest vector-push.error.15 (signals-error (vector-push (vector 1 2 3)) program-error) t) (deftest vector-push.error.16 (signals-error (vector-push (vector 1 2 3) 4 nil) program-error) t) gcl27-2.7.0/ansi-tests/vector.lsp000066400000000000000000000145121454061450500165610ustar00rootroot00000000000000;-*- 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) gcl27-2.7.0/ansi-tests/vectorp.lsp000066400000000000000000000021241454061450500167350ustar00rootroot00000000000000;-*- 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 (signals-error (vectorp) program-error) t) (deftest vectorp.error.2 (signals-error (vectorp #() #()) program-error) t) gcl27-2.7.0/ansi-tests/warn.lsp000066400000000000000000000075621454061450500162350ustar00rootroot00000000000000;-*- 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 (signals-error (warn 'condition) type-error) t) (deftest warn.13 (signals-error (warn 'simple-condition) type-error) t) (deftest warn.14 (signals-error (warn (make-condition 'simple-warning) :format-control "Foo") type-error) t) (deftest warn.15 (signals-error (warn) program-error) t) (deftest warn.16 (signals-error (warn (make-condition 'condition)) type-error) t) (deftest warn.17 (signals-error (warn (make-condition 'simple-condition)) type-error) t) (deftest warn.18 (signals-error (warn (make-condition 'simple-error)) type-error) t) (deftest warn.19 (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 (formatter "Foo!")))) warned))) (nil) t)gcl27-2.7.0/ansi-tests/when.lsp000066400000000000000000000027011454061450500162150ustar00rootroot00000000000000;-*- 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) ;;; No implicit tagbody (deftest when.8 (block done (tagbody (when t (go 10) 10 (return-from done 'bad)) 10 (return-from done 'good))) good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest when.9 (macrolet ((%m (z) z)) (when (expand-in-current-env (%m t)) :good)) :good) (deftest when.10 (macrolet ((%m (z) z)) (when (expand-in-current-env (%m nil)) :bad)) nil) (deftest when.11 (macrolet ((%m (z) z)) (let ((x t)) (values (when x (expand-in-current-env (%m (setf x 'foo)))) x))) foo foo) ;;; Error tests (deftest when.error.1 (signals-error (funcall (macro-function 'when)) program-error) t) (deftest when.error.2 (signals-error (funcall (macro-function 'when) '(when t)) program-error) t) (deftest when.error.3 (signals-error (funcall (macro-function 'when) '(when t) nil nil) program-error) t) gcl27-2.7.0/ansi-tests/wild-pathname-p.lsp000066400000000000000000000126501454061450500202470ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Dec 31 16:54:55 2003 ;;;; Contains: Tests of WILD-PATHNAME-P (in-package :cl-test) (compile-and-load "pathnames-aux.lsp") (deftest wild-pathname-p.1 (wild-pathname-p (make-pathname)) nil) (deftest wild-pathname-p.2 (loop for key in '(:host :device :directory :name :type :version nil) when (wild-pathname-p (make-pathname) key) collect key) nil) (deftest wild-pathname-p.3 (let ((p (make-pathname :directory :wild))) (notnot-mv (wild-pathname-p p))) t) (deftest wild-pathname-p.4 (let ((p (make-pathname :directory :wild))) (notnot-mv (wild-pathname-p p nil))) t) (deftest wild-pathname-p.5 (let ((p (make-pathname :directory :wild))) (notnot-mv (wild-pathname-p p :directory))) t) (deftest wild-pathname-p.6 (let ((p (make-pathname :directory :wild))) (loop for key in '(:host :device :name :type :version) when (wild-pathname-p p key) collect key)) nil) (deftest wild-pathname-p.7 (let ((p (make-pathname :directory '(:absolute :wild)))) (notnot-mv (wild-pathname-p p))) t) (deftest wild-pathname-p.8 (let ((p (make-pathname :directory '(:absolute :wild)))) (notnot-mv (wild-pathname-p p nil))) t) (deftest wild-pathname-p.9 (let ((p (make-pathname :directory '(:absolute :wild)))) (notnot-mv (wild-pathname-p p :directory))) t) (deftest wild-pathname-p.10 (let ((p (make-pathname :directory '(:absolute :wild)))) (loop for key in '(:host :device :name :type :version) when (wild-pathname-p p key) collect key)) nil) (deftest wild-pathname-p.11 (let ((p (make-pathname :directory '(:relative :wild)))) (notnot-mv (wild-pathname-p p))) t) (deftest wild-pathname-p.12 (let ((p (make-pathname :directory '(:relative :wild)))) (notnot-mv (wild-pathname-p p nil))) t) (deftest wild-pathname-p.13 (let ((p (make-pathname :directory '(:relative :wild)))) (notnot-mv (wild-pathname-p p :directory))) t) (deftest wild-pathname-p.14 (let ((p (make-pathname :directory '(:relative :wild)))) (loop for key in '(:host :device :name :type :version) when (wild-pathname-p p key) collect key)) nil) ;;; (deftest wild-pathname-p.15 (let ((p (make-pathname :name :wild))) (notnot-mv (wild-pathname-p p))) t) (deftest wild-pathname-p.16 (let ((p (make-pathname :name :wild))) (notnot-mv (wild-pathname-p p nil))) t) (deftest wild-pathname-p.17 (let ((p (make-pathname :name :wild))) (notnot-mv (wild-pathname-p p :name))) t) (deftest wild-pathname-p.18 (let ((p (make-pathname :name :wild))) (loop for key in '(:host :device :directory :type :version) when (wild-pathname-p p key) collect key)) nil) ;;; (deftest wild-pathname-p.19 (let ((p (make-pathname :type :wild))) (notnot-mv (wild-pathname-p p))) t) (deftest wild-pathname-p.20 (let ((p (make-pathname :type :wild))) (notnot-mv (wild-pathname-p p nil))) t) (deftest wild-pathname-p.21 (let ((p (make-pathname :type :wild))) (notnot-mv (wild-pathname-p p :type))) t) (deftest wild-pathname-p.22 (let ((p (make-pathname :type :wild))) (loop for key in '(:host :device :directory :name :version) when (wild-pathname-p p key) collect key)) nil) ;;; (deftest wild-pathname-p.23 (let ((p (make-pathname :version :wild))) (notnot-mv (wild-pathname-p p))) t) (deftest wild-pathname-p.24 (let ((p (make-pathname :version :wild))) (notnot-mv (wild-pathname-p p nil))) t) (deftest wild-pathname-p.25 (let ((p (make-pathname :version :wild))) (notnot-mv (wild-pathname-p p :version))) t) (deftest wild-pathname-p.26 (let ((p (make-pathname :version :wild))) (loop for key in '(:host :device :directory :name :type) when (wild-pathname-p p key) collect key)) nil) ;;; (deftest wild-pathname-p.27 (loop for p in (append *pathnames* *logical-pathnames*) unless (if (wild-pathname-p p) (wild-pathname-p p nil) (not (wild-pathname-p p nil))) collect p) nil) (deftest wild-pathname-p.28 (loop for p in (append *pathnames* *logical-pathnames*) when (and (loop for key in '(:host :device :directory :name :type :version) thereis (wild-pathname-p p key)) (not (wild-pathname-p p))) collect p) nil) ;;; On streams associated with files (deftest wild-pathname-p.29 (with-open-file (s "foo.lsp" :direction :output :if-exists :append :if-does-not-exist :create) (wild-pathname-p s)) nil) (deftest wild-pathname-p.30 (let ((s (open "foo.lsp" :direction :output :if-exists :append :if-does-not-exist :create))) (close s) (wild-pathname-p s)) nil) ;;; logical pathname designators (deftest wild-pathname-p.31 (wild-pathname-p "CLTEST:FOO.LISP") nil) ;;; Odd strings (deftest wild-pathname-p.32 (do-special-strings (s "CLTEST:FOO.LISP" nil) (let ((vals (multiple-value-list (wild-pathname-p s)))) (assert (equal vals '(nil))))) nil) ;;; (deftest wild-pathname-p.error.1 (signals-error (wild-pathname-p) program-error) t) (deftest wild-pathname-p.error.2 (signals-error (wild-pathname-p *default-pathname-defaults* nil nil) program-error) t) (deftest wild-pathname-p.error.3 (check-type-error #'wild-pathname-p (typef '(or pathname string file-stream synonym-stream))) nil) (deftest wild-pathname-p.error.4 (check-type-error #'(lambda (x) (declare (optimize (safety 0))) (wild-pathname-p x)) (typef '(or pathname string file-stream synonym-stream))) nil) gcl27-2.7.0/ansi-tests/with-accessors.lsp000066400000000000000000000067171454061450500202250ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 17 17:07:29 2003 ;;;; Contains: Tests of WITH-ACCESSORS (in-package :cl-test) (deftest with-accessors.1 (with-accessors () nil) nil) (deftest with-accessors.2 (with-accessors () nil (values))) (deftest with-accessors.3 (with-accessors () nil (values 'a 'b 'c 'd 'e 'f)) a b c d e f) (deftest with-accessors.4 (let (x y z) (with-accessors () (setf x 1) (setf y 5) (setf z 12) (values x y z))) 1 5 12) ;; with-accessors defines an implicit progn, not a tagbody (deftest with-accessors.5 (block done (tagbody (with-accessors nil nil (go 10) 10 (return-from done :bad)) 10 (return-from done :good))) :good) (defclass with-accessors-class-01 () ((a :initarg :a :accessor wa-a) (b :initarg :b :accessor wa-b) (c :initarg :c :accessor wa-c))) (deftest with-accessors.6 (let ((obj (make-instance 'with-accessors-class-01 :a 'x :b 'y :c 'z))) (with-accessors ((a wa-a) (b wa-b) (c wa-c)) obj (values a b c))) x y z) (deftest with-accessors.7 (let ((obj (make-instance 'with-accessors-class-01))) (with-accessors ((a wa-a) (b wa-b) (c wa-c)) obj (values (setf a 'x) (setf b 'y) (setf c 'z) (map-slot-value obj '(a b c))))) x y z (x y z)) (deftest with-accessors.8 (let ((obj (make-instance 'with-accessors-class-01))) (with-accessors ((a wa-a) (b wa-b) (c wa-c)) obj (values (setq a 'x) (setq b 'y) (setq c 'z) (map-slot-value obj '(a b c))))) x y z (x y z)) (deftest with-accessors.9 (let ((obj (make-instance 'with-accessors-class-01 :a 5 :b 19 :c 312))) (with-accessors ((a wa-a) (b wa-b) (c wa-c)) obj (values (incf a 4) (incf b 412) (incf c 75) (map-slot-value obj '(a b c))))) 9 431 387 (9 431 387)) (deftest with-accessors.10 (let ((obj (make-instance 'with-accessors-class-01 :a 5 :b 19 :c 312))) (with-accessors ((a wa-a) (b wa-b) (c wa-c)) obj (declare (optimize (speed 3) (safety 3))) (values a b c))) 5 19 312) (deftest with-accessors.11 (let ((obj (make-instance 'with-accessors-class-01 :a 5 :b 19 :c 312))) (with-accessors ((a wa-a) (b wa-b) (c wa-c)) obj (declare (optimize (speed 3) (safety 3))) (declare (special *x*)) ;; not used (values a b c))) 5 19 312) ;;; with-accessors on structure accessors (defstruct (with-accessors-struct-02 (:conc-name "WA-2-")) a b c) (deftest with-accessors.12 (let ((obj (make-with-accessors-struct-02 :a 'x :b 'y :c 'z))) (with-accessors ((a wa-2-a) (b wa-2-b) (c wa-2-c)) obj (values a b c))) x y z) (deftest with-accessors.13 (let ((obj (make-with-accessors-struct-02))) (with-accessors ((a wa-2-a) (b wa-2-b) (c wa-2-c)) obj (values (setf a 'x) (setf b 'y) (setf c 'z) (wa-2-a obj) (wa-2-b obj) (wa-2-c obj)))) x y z x y z) ;;; Free declaration scope test (deftest with-accessors.14 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (with-accessors nil (return-from done x) (declare (special x)))))) :good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest with-accessors.15 (macrolet ((%m (z) z)) (let ((obj (make-with-accessors-struct-02 :a 'x :b 'y :c 'z))) (with-accessors ((a wa-2-a) (b wa-2-b) (c wa-2-c)) (expand-in-current-env (%m obj)) (values a b c)))) x y z) gcl27-2.7.0/ansi-tests/with-compilation-unit.lsp000066400000000000000000000022631454061450500215230ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 30 07:36:26 2005 ;;;; Contains: Tests of WITH-COMPILATION-UNIT ;;; WITH-COMPILATION-UNIT doesn't have much in the way of standardized ;;; semantics, so there's not much to test. (in-package :cl-test) (deftest with-compilation-unit.1 (with-compilation-unit ()) nil) (deftest with-compilation-unit.2 (with-compilation-unit () t) t) (deftest with-compilation-unit.3 (with-compilation-unit () (values))) (deftest with-compilation-unit.4 (with-compilation-unit () (values 1 2 3 4 5)) 1 2 3 4 5) (deftest with-compilation-unit.5 (with-compilation-unit (:override nil) :foo) :foo) (deftest with-compilation-unit.6 (with-compilation-unit (:override t) (values 10 17)) 10 17) (deftest with-compilation-unit.7 (let ((x nil)) (values (block done (with-compilation-unit (:override nil) (setq x 1) (return-from done 2) (setq x 2))) x)) 2 1) ;;; Add a test that (1) checks if the compiler normally delays ;;; warnings until the end of a file and, if so, (2) checks that ;;; with-compilation-unit delays the warnings for more than one ;;; file compilation until the end of the unit. gcl27-2.7.0/ansi-tests/with-condition-restarts.lsp000066400000000000000000000041721454061450500220640ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 23 04:06:06 2003 ;;;; Contains: Tests of WITH-CONDITION-RESTARTS (in-package :cl-test) (deftest with-condition-restarts.1 (let (a b c (i 0)) (values (with-condition-restarts (progn (setf a (incf i)) (make-condition 'error)) (progn (setf b (incf i)) nil) (setf c (incf i))) a b c i)) 3 1 2 3 3) (deftest with-condition-restarts.2 (with-condition-restarts (make-condition 'error) nil (values))) (deftest with-condition-restarts.3 (with-condition-restarts (make-condition 'error) nil (values 'a 'b 'c 'd 'e 'f)) a b c d e f) (deftest with-condition-restarts.4 (block done (tagbody (with-condition-restarts (make-condition 'error) nil (go 10) 10 (return-from done 'bad)) 10 (return-from done 'good))) good) (deftest with-condition-restarts.5 (let ((c (make-condition 'error))) (restart-case (with-condition-restarts c (list (find-restart 'foo)) 'good) (foo () 'bad))) good) (deftest with-condition-restarts.6 (let ((c (make-condition 'error)) (c2 (make-condition 'error))) (handler-bind ((error #'(lambda (c) (invoke-restart (find-restart 'foo c2))))) (restart-case (with-condition-restarts c (list (find-restart 'foo)) (signal c2)) (foo () 'bad) (foo () 'good)))) good) (deftest with-condition-restarts.7 (let ((c (make-condition 'error)) (c2 (make-condition 'error))) (handler-bind ((error #'(lambda (c) (invoke-restart 'foo)))) (restart-case (with-condition-restarts c (list (find-restart 'foo)) (signal c2)) (foo () 'good) (foo () 'bad)))) good) ;;; test that the association of a restart with a condition ;;; has dynamic extent (deftest with-condition-restarts.8 (let ((c (make-condition 'error)) (c2 (make-condition 'error))) (restart-case (progn (with-condition-restarts c (list (find-restart 'foo))) (invoke-restart (find-restart 'foo c2))) (foo () 'good) (foo () 'bad))) good) gcl27-2.7.0/ansi-tests/with-hash-table-iterator.lsp000066400000000000000000000100571454061450500220670ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Nov 28 20:08:43 2003 ;;;; Contains: Tests of WITH-HASH-TABLE-ITERATOR (in-package :cl-test) (deftest with-hash-table-iterator.1 (with-hash-table-iterator (x (make-hash-table))) nil) (deftest with-hash-table-iterator.2 (with-hash-table-iterator (x (make-hash-table)) (values))) (deftest with-hash-table-iterator.3 (with-hash-table-iterator (x (make-hash-table)) (values 'a 'b 'c 'd)) a b c d) (deftest with-hash-table-iterator.4 (with-hash-table-iterator (%x (make-hash-table)) (%x)) nil) (deftest with-hash-table-iterator.5 (let ((table (make-hash-table))) (setf (gethash 'a table) 'b) (with-hash-table-iterator (%x table) (multiple-value-bind (success-p key val) (%x) (values (notnot success-p) key val)))) t a b) (deftest with-hash-table-iterator.6 (let ((table (make-hash-table))) (setf (gethash 'a table) 'b) (with-hash-table-iterator (%x table) (length (multiple-value-list (%x))))) 3) (deftest with-hash-table-iterator.7 (let ((keys '("a" "b" "c" "d" "e"))) (loop for test in '(eq eql equal equalp) for test-fn of-type function = (symbol-function test) collect (let ((table (make-hash-table :test test))) (loop for k in keys for i from 0 do (setf (gethash k table) i)) (let ((count 0) (found-keys)) (with-hash-table-iterator (%x table) (block done (loop (multiple-value-bind (success key val) (%x) (unless success (return-from done nil)) (incf count) (push key found-keys) (assert (= val (position key keys :test test-fn)))))) (and (= count (length keys)) (every test-fn (sort (remove-duplicates found-keys :test test) #'string<) keys) t)))))) (t t t t)) (deftest with-hash-table-iterator.8 (with-hash-table-iterator (%x (make-hash-table)) (declare (optimize))) nil) (deftest with-hash-table-iterator.8a (with-hash-table-iterator (%x (make-hash-table)) (declare (optimize)) (declare (optimize))) nil) (deftest with-hash-table-iterator.9 (with-hash-table-iterator (%x (make-hash-table)) (macrolet ((expand-%x (&environment env) (let ((expanded-form (macroexpand '(%x) env))) (if (equal expanded-form '(%x)) nil t)))) (expand-%x))) t) (deftest with-hash-table-iterator.10 (let ((table (make-hash-table))) (loop for key from 1 to 100 for val from 101 to 200 do (setf (gethash key table) val)) (let ((pairs nil)) (with-hash-table-iterator (%x table) (loop (multiple-value-bind (success key val) (%x) (unless success (return nil)) (remhash key table) (push (cons key val) pairs)))) (assert (eql (length pairs) 100)) (setq pairs (sort pairs #'(lambda (p1 p2) (< (car p1) (car p2))))) (values (hash-table-count table) (loop for (key . val) in pairs for expected-key from 1 for expected-val from 101 always (and (eql key expected-key) (eql val expected-val)))))) 0 t) (deftest with-hash-table-iterator.11 (let ((table (make-hash-table))) (loop for key from 1 to 100 for val from 101 to 200 do (setf (gethash key table) val)) (let ((pairs nil)) (with-hash-table-iterator (%x table) (loop (multiple-value-bind (success key val) (%x) (unless success (return nil)) (setf (gethash key table) (+ 1000 val)) (push (cons key val) pairs)))) (assert (eql (length pairs) 100)) (setq pairs (sort pairs #'(lambda (p1 p2) (< (car p1) (car p2))))) (values (hash-table-count table) (loop for (key . val) in pairs for expected-key from 1 for expected-val from 101 always (and (eql key expected-key) (eql val expected-val) (eql (gethash key table) (+ 1000 val)) ))))) 100 t) ;;; Free declaration scope (deftest with-hash-table-iterator.12 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (with-hash-table-iterator (m (return-from done x)) (declare (special x)))))) :good) gcl27-2.7.0/ansi-tests/with-input-from-string.lsp000066400000000000000000000132151454061450500216330ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 14 20:13:02 2004 ;;;; Contains: Tests of WITH-INPUT-FROM-STRING (in-package :cl-test) (deftest with-input-from-string.1 (with-input-from-string (s "abc") (values (read-char s) (read-char s) (read-char s) (read-char s nil :eof))) #\a #\b #\c :eof) (deftest with-input-from-string.2 (with-input-from-string (s "abc")) nil) (deftest with-input-from-string.3 (with-input-from-string (s "abc") (declare (optimize speed))) nil) (deftest with-input-from-string.3a (with-input-from-string (s "abc") (declare (optimize speed)) (declare (optimize space))) nil) (deftest with-input-from-string.4 (with-input-from-string (s "abc") (declare (optimize safety)) (read-char s) (read-char s)) #\b) (deftest with-input-from-string.5 (let ((i nil)) (values (with-input-from-string (s "abc" :index i)) i)) nil 0) (deftest with-input-from-string.6 (let ((i (list nil))) (values (with-input-from-string (s "abc" :index (car i))) i)) nil (0)) (deftest with-input-from-string.7 (let ((i nil)) (values (with-input-from-string (s "abc" :index i) (list i (read-char s) i (read-char s) i)) i)) (nil #\a nil #\b nil) 2) (deftest with-input-from-string.9 (with-input-from-string (s "abc") (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (notnot (open-stream-p s)) (notnot (input-stream-p s)) (output-stream-p s))) t t t t nil) (deftest with-input-from-string.10 :notes (:nil-vectors-are-strings) (with-input-from-string (s (make-array 0 :element-type nil)) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (notnot (open-stream-p s)) (notnot (input-stream-p s)) (output-stream-p s))) t t t t nil) (deftest with-input-from-string.11 (with-input-from-string (s (make-array 3 :element-type 'character :initial-contents "abc")) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (notnot (open-stream-p s)) (notnot (input-stream-p s)) (output-stream-p s) (read-line s))) t t t t nil "abc") (deftest with-input-from-string.12 (with-input-from-string (s (make-array 3 :element-type 'base-char :initial-contents "abc")) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (notnot (open-stream-p s)) (notnot (input-stream-p s)) (output-stream-p s) (read-line s))) t t t t nil "abc") (deftest with-input-from-string.13 (with-input-from-string (s "abcdef" :start 2) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (notnot (open-stream-p s)) (notnot (input-stream-p s)) (output-stream-p s) (read-line s))) t t t t nil "cdef") (deftest with-input-from-string.14 (with-input-from-string (s "abcdef" :end 3) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (notnot (open-stream-p s)) (notnot (input-stream-p s)) (output-stream-p s) (read-line s))) t t t t nil "abc") (deftest with-input-from-string.15 (with-input-from-string (s "abcdef" :start 1 :end 5) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (notnot (open-stream-p s)) (notnot (input-stream-p s)) (output-stream-p s) (read-line s))) t t t t nil "bcde") (deftest with-input-from-string.16 (with-input-from-string (s "abcdef" :start 1 :end nil) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (notnot (open-stream-p s)) (notnot (input-stream-p s)) (output-stream-p s) (read-line s))) t t t t nil "bcdef") (deftest with-input-from-string.17 (let ((i 2)) (values (with-input-from-string (s "abcdef" :index i :start i) (read-char s)) i)) #\c 3) ;;; Test that there is no implicit tagbody (deftest with-input-from-string.18 (block done (tagbody (with-input-from-string (s "abc") (go 1) 1 (return-from done :bad)) 1 (return-from done :good))) :good) ;;; Free declaration scope (deftest with-input-from-string.19 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (with-input-from-string (s (return-from done x)) (declare (special x)))))) :good) (deftest with-input-from-string.20 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (with-input-from-string (s "abc" :start (return-from done x)) (declare (special x)))))) :good) (deftest with-input-from-string.21 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (with-input-from-string (s "abc" :end (return-from done x)) (declare (special x)))))) :good) ;;; index is not updated if the form exits abnormally (deftest with-input-from-string.22 (let ((i nil)) (values (block done (with-input-from-string (s "abcde" :index i) (return-from done (read-char s)))) i)) #\a nil) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest with-input-from-string.23 (macrolet ((%m (z) z)) (with-input-from-string (s (expand-in-current-env (%m "123"))) (read-char s))) #\1) (deftest with-input-from-string.24 (macrolet ((%m (z) z)) (with-input-from-string (s "123" :start (expand-in-current-env (%m 1))) (read-char s))) #\2) (deftest with-input-from-string.25 (macrolet ((%m (z) z)) (with-input-from-string (s "123" :start 0 :end (expand-in-current-env (%m 0))) (read-char s nil nil))) nil) ;;; FIXME: Add more tests on specialized strings. gcl27-2.7.0/ansi-tests/with-open-file.lsp000066400000000000000000000044761454061450500201160ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 27 20:57:05 2004 ;;;; Contains: Tests of WITH-OPEN-FILE (in-package :cl-test) ;;; For now, omit most of the options combinations, assuming they will ;;; be tested in OPEN. The tests of OPEN should be ported to here at some ;;; point. (deftest with-open-file.1 (let ((pn #p"tmp.dat")) (delete-all-versions pn) (with-open-file (s pn :direction :output))) nil) (deftest with-open-file.2 (let ((pn #p"tmp.dat")) (delete-all-versions pn) (with-open-file (s pn :direction :output) (notnot-mv (output-stream-p s)))) t) (deftest with-open-file.3 (let ((pn #p"tmp.dat")) (delete-all-versions pn) (with-open-file (s pn :direction :output) (values)))) (deftest with-open-file.4 (let ((pn #p"tmp.dat")) (delete-all-versions pn) (with-open-file (s pn :direction :output) (values 1 2 3 4 5 6 7 8))) 1 2 3 4 5 6 7 8) (deftest with-open-file.5 (let ((pn #p"tmp.dat")) (delete-all-versions pn) (with-open-file (s pn :direction :output) (declare (ignore s)) (declare (optimize)))) nil) (deftest with-open-file.6 (let ((pn #p"tmp.dat")) (delete-all-versions pn) (with-open-file (s pn (cdr '(nil . :direction)) (car '(:output))) (format s "foo!~%")) (with-open-file (s pn) (read-line s))) "foo!" nil) ;;; Free declaration scope tests (deftest with-open-file.7 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (with-open-file (s (return-from done x)) (declare (special x)))))) :good) (deftest with-open-file.8 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (with-open-file (s "with-open-file.lsp" (return-from done x) :input) (declare (special x)))))) :good) (deftest with-open-file.9 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (with-open-file (s "with-open-file.lsp" :direction (return-from done x)) (declare (special x)))))) :good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest with-open-file.10 (macrolet ((%m (z) z)) (let ((pn #p"tmp.dat")) (delete-all-versions pn) (with-open-file (s (expand-in-current-env (%m pn)) :direction :output)))) nil) gcl27-2.7.0/ansi-tests/with-open-stream.lsp000066400000000000000000000035201454061450500204570ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Dec 13 01:42:59 2004 ;;;; Contains: Tests of WITH-OPEN-STREAM (in-package :cl-test) (deftest with-open-stream.1 (with-open-stream (os (make-string-output-stream))) nil) (deftest with-open-stream.2 (with-open-stream (os (make-string-output-stream)) (declare (ignore os))) nil) (deftest with-open-stream.3 (with-open-stream (os (make-string-output-stream)) (declare (ignore os)) (declare (type string-stream os))) nil) (deftest with-open-stream.4 (with-open-stream (os (make-string-output-stream)) (declare (ignore os)) (values))) (deftest with-open-stream.5 (with-open-stream (os (make-string-output-stream)) (declare (ignore os)) (values 'a 'b)) a b) (deftest with-open-stream.6 (let ((s (make-string-output-stream))) (values (with-open-stream (os s)) (notnot (typep s 'string-stream)) (open-stream-p s))) nil t nil) (deftest with-open-stream.7 (let ((s (make-string-input-stream "123"))) (values (with-open-stream (is s) (read-char s)) (notnot (typep s 'string-stream)) (open-stream-p s))) #\1 t nil) (deftest with-open-stream.8 (let ((s (make-string-output-stream))) (values (block done (with-open-stream (os s) (return-from done nil))) (notnot (typep s 'string-stream)) (open-stream-p s))) nil t nil) (deftest with-open-stream.9 (let ((s (make-string-output-stream))) (values (catch 'done (with-open-stream (os s) (throw 'done nil))) (notnot (typep s 'string-stream)) (open-stream-p s))) nil t nil) ;;; Free declaration scope (deftest with-open-stream.10 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (with-open-stream (s (return-from done x)) (declare (special x)))))) :good) gcl27-2.7.0/ansi-tests/with-output-to-string.lsp000066400000000000000000000062721454061450500215200ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 14 20:33:51 2004 ;;;; Contains: Tests of WITH-OUTPUT-TO-STRING (in-package :cl-test) (deftest with-output-to-string.1 (with-output-to-string (s)) "") (deftest with-output-to-string.2 (with-output-to-string (s) (write-char #\3 s)) "3") (deftest with-output-to-string.3 (with-output-to-string (s (make-array 10 :fill-pointer 0 :element-type 'character))) nil) (deftest with-output-to-string.4 :notes (:allow-nil-arrays :nil-vectors-are-strings) (let ((str (make-array 10 :fill-pointer 0 :element-type 'character))) (values (with-output-to-string (s str :element-type nil) (write-string "abcdef" s)) str)) "abcdef" "abcdef") (deftest with-output-to-string.5 (with-output-to-string (s (make-array 10 :fill-pointer 0 :element-type 'character)) (values))) (deftest with-output-to-string.6 (with-output-to-string (s (make-array 10 :fill-pointer 0 :element-type 'character)) (values 'a 'b 'c 'd)) a b c d) (deftest with-output-to-string.7 (with-output-to-string (s nil :element-type 'character) (write-char #\& s)) "&") (deftest with-output-to-string.8 (let ((str (with-output-to-string (s nil :element-type 'base-char) (write-char #\8 s)))) (assert (typep str 'simple-base-string)) str) "8") (deftest with-output-to-string.9 :notes (:allow-nil-arrays :nil-vectors-are-strings) (with-output-to-string (s nil :element-type nil)) "") (deftest with-output-to-string.10 (let* ((s1 (make-array 20 :element-type 'character :initial-element #\.)) (s2 (make-array 10 :element-type 'character :displaced-to s1 :displaced-index-offset 5 :fill-pointer 0))) (values (with-output-to-string (s s2) (write-string "0123456789" s)) s1 s2)) "0123456789" ".....0123456789....." "0123456789") (deftest with-output-to-string.11 (with-output-to-string (s) (declare (optimize safety))) "") (deftest with-output-to-string.12 (with-output-to-string (s) (declare (optimize safety)) (declare (optimize (speed 0)))) "") (deftest with-output-to-string.13 (with-output-to-string (s) (write-char #\0 s) (write-char #\4 s) (write-char #\9 s)) "049") (deftest with-output-to-string.14 (let* ((str1 (make-array '(256) :element-type 'base-char :fill-pointer 0)) (str2 (with-output-to-string (s nil :element-type 'base-char) (loop for i below 256 for c = (code-char i) when (typep c 'base-char) do (progn (write-char c s) (vector-push c str1)))))) (if (string= str1 str2) :good (list str1 str2))) :good) ;;; Free declaration scope (deftest with-output-to-string.15 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (with-output-to-string (s (return-from done x)) (declare (special x)))))) :good) (deftest with-output-to-string.16 (block done (let ((x :bad)) (declare (special x)) (let ((x :good) (str (make-array '(10) :element-type 'character :fill-pointer 0))) (with-output-to-string (s str :element-type (return-from done x)) (declare (special x)))))) :good) gcl27-2.7.0/ansi-tests/with-package-iterator.lsp000066400000000000000000000112421454061450500214470ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:03:36 1998 ;;;; Contains: Tests of WITH-PACKAGE-ITERATOR (in-package :cl-test) (declaim (optimize (safety 3))) (compile-and-load "package-aux.lsp") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 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 (progn (set-up-packages) (with-package-iterator-all '("A"))) t) (deftest with-package-iterator.6 (progn (set-up-packages) (with-package-iterator-all '(#:|A|))) t) (deftest with-package-iterator.7 (progn (set-up-packages) (with-package-iterator-all '(#\A))) t) (deftest with-package-iterator.8 (progn (set-up-packages) (with-package-iterator-internal (list (find-package "A")))) t) (deftest with-package-iterator.9 (progn (set-up-packages) (with-package-iterator-external (list (find-package "A")))) t) (deftest with-package-iterator.10 (progn (set-up-packages) (with-package-iterator-inherited (list (find-package "A")))) t) (deftest with-package-iterator.11 (signals-error (with-package-iterator (x "COMMON-LISP-USER")) program-error) t) (defun t-count (x) (if (eq x t) nil x)) ;;; 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 (eq t (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 (eq t (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 (eq t (with-package-iterator-inherited (list p))))) (error (c) (format t "Error ~S on package ~S~%" c p) t))) 0) (def-macro-test with-package-iterator.error.1 (with-package-iterator (x "CL" :external) nil)) ;;; Specialized sequence tests (defmacro def-with-package-iterator-test (test-name name-form) `(deftest ,test-name (let ((name ,name-form)) (safely-delete-package name) (let* ((p (make-package name :use nil)) (result nil) (s (intern "X" p))) (with-package-iterator (x name :internal) (loop (multiple-value-bind (good? sym) (x) (unless good? (safely-delete-package name) (return (equalt (list s) result))) (push sym result)))))) t)) (def-with-package-iterator-test with-package-iterator.15 (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) (def-with-package-iterator-test with-package-iterator.16 (make-array 8 :initial-contents "TEST1XXX" :fill-pointer 5 :element-type 'base-char)) (def-with-package-iterator-test with-package-iterator.17 (make-array 8 :initial-contents "TEST1XXX" :fill-pointer 5 :element-type 'character)) (def-with-package-iterator-test with-package-iterator.18 (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'base-char)) (def-with-package-iterator-test with-package-iterator.19 (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'character)) (def-with-package-iterator-test with-package-iterator.20 (let* ((etype 'base-char) (name0 (make-array 10 :initial-contents "XTEST1YzYY" :element-type etype))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 1))) (def-with-package-iterator-test with-package-iterator.21 (let* ((etype 'character) (name0 (make-array 10 :initial-contents "XTEST1YzYY" :element-type etype))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 1))) ;;; Free declaration scope (deftest with-package-iterator.22 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (with-package-iterator (s (return-from done x) :internal) (declare (special x)))))) :good) gcl27-2.7.0/ansi-tests/with-simple-restart.lsp000066400000000000000000000020761454061450500212050ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 23 04:36:52 2003 ;;;; Contains: Tests for WITH-SIMPLE-RESTART (in-package :cl-test) (deftest with-simple-restart.1 (with-simple-restart (foo "")) nil) (deftest with-simple-restart.2 (with-simple-restart (foo "") (values))) (deftest with-simple-restart.3 (with-simple-restart (foo "") (values 1 2 3 4 5 6 7 8 9 10)) 1 2 3 4 5 6 7 8 9 10) (deftest with-simple-restart.4 (block nil (tagbody (with-simple-restart (foo "") (go 10) 10 (return 'bad)) 10 (return 'good))) good) (deftest with-simple-restart.5 (with-simple-restart (foo "zzz") (invoke-restart 'foo)) nil t) (deftest with-simple-restart.6 (flet ((%f () (invoke-restart 'foo))) (with-simple-restart (foo "zzz") (%f))) nil t) (deftest with-simple-restart.7 (with-simple-restart (foo (formatter "xxx")) (invoke-restart 'foo)) nil t) (deftest with-simple-restart.8 (with-simple-restart (nil "") (invoke-restart (first (compute-restarts)))) nil t) gcl27-2.7.0/ansi-tests/with-slots.lsp000066400000000000000000000104521454061450500173730ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 17 18:04:10 2003 ;;;; Contains: Tests of WITH-SLOTS (in-package :cl-test) (deftest with-slots.1 (with-slots () nil) nil) (deftest with-slots.2 (with-slots () nil (values))) (deftest with-slots.3 (with-slots () nil (values 'a 'b 'c 'd 'e 'f)) a b c d e f) (deftest with-slots.4 (let ((x 0) (y 10) (z 20)) (values x y z (with-slots () (incf x) (incf y 3) (incf z 100)) x y z)) 0 10 20 120 1 13 120) ;;; with-slots is an implicit progn, not a tagbody (deftest with-slots.5 (block done (tagbody (with-slots () nil (go 10) 10 (return-from done :bad)) 10 (return-from done :good))) :good) ;;; with-slots has no implicit block (deftest with-slots.6 (block nil (with-slots () nil (return :good)) (return :bad)) :good) ;;; Tests on standard objects (defclass with-slots-class-01 () ((a :initarg :a) (b :initarg :b) (c :initarg :c))) (deftest with-slots.7 (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z))) (with-slots (a b c) obj (values a b c))) x y z) (deftest with-slots.8 (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z))) (with-slots (a b c) obj (values (setf a 'p) (setf b 'q) (setf c 'r) (map-slot-value obj '(a b c))))) p q r (p q r)) (deftest with-slots.9 (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z))) (with-slots (a b c) obj (values (setq a 'p) (setq b 'q) (setq c 'r) (map-slot-value obj '(a b c))))) p q r (p q r)) (deftest with-slots.10 (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z))) (with-slots ((a2 a) (b2 b) (c2 c)) obj (values a2 b2 c2))) x y z) (deftest with-slots.11 (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z))) (with-slots ((a2 a) (b2 b) (c2 c)) obj (values (setf a2 'p) (setf b2 'q) (setf c2 'r) (map-slot-value obj '(a b c))))) p q r (p q r)) (deftest with-slots.12 (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z))) (with-slots ((a2 a) (b2 b) (c2 c)) obj (values (setq a2 'p) (setq b2 'q) (setq c2 'r) (map-slot-value obj '(a b c))))) p q r (p q r)) (deftest with-slots.13 (let ((obj (make-instance 'with-slots-class-01))) (with-slots (a b c) obj (values (setf a 'p) (setf b 'q) (setf c 'r) (map-slot-value obj '(a b c))))) p q r (p q r)) (deftest with-slots.14 (let ((obj (make-instance 'with-slots-class-01 :a 1 :b 2 :c 3))) (with-slots (a b c) obj (let ((obj (make-instance 'with-slots-class-01 :a 'bad :b 'bad :c 'bad))) (values a b c)))) 1 2 3) (deftest with-slots.15 (let ((obj (make-instance 'with-slots-class-01 :a 1 :b 2 :c 3))) (with-slots (a b c) obj (with-slots ((a2 a) (b2 b) (c2 c)) (make-instance 'with-slots-class-01 :a 'bad :b 'bad :c 'bad) (values a b c)))) 1 2 3) (deftest with-slots.16 (let ((obj (make-instance 'with-slots-class-01 :a 'bad :b 'bad :c 'bad))) (with-slots (a b c) obj (with-slots (a b c) (make-instance 'with-slots-class-01 :a 1 :b 2 :c 3) (values a b c)))) 1 2 3) (deftest with-slots.17 (let ((obj (make-instance 'with-slots-class-01 :a 1 :b 2 :c 'bad))) (with-slots (a b) obj (with-slots (c) (make-instance 'with-slots-class-01 :a 'bad :b 'bad :c 3) (values a b c)))) 1 2 3) ;;; If slot is unbound, act as if slot-value had been called (defmethod slot-unbound ((class t) (instance with-slots-class-01) slot-name) 'missing) (deftest with-slots.18 (let ((obj (make-instance 'with-slots-class-01))) (with-slots (a b c) obj (values a b c))) missing missing missing) (deftest with-slots.19 (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z))) (with-slots (a b c) obj (declare (optimize (speed 3) (safety 3))) (values a b c))) x y z) (deftest with-slots.20 (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z))) (with-slots (a b c) obj (declare (optimize (speed 3) (safety 3))) (declare (special *x*)) (values a b c))) x y z) ;;; Free declaration scope test (deftest with-slots.21 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (with-slots nil (return-from done x) (declare (special x)))))) :good)gcl27-2.7.0/ansi-tests/with-standard-io-syntax.lsp000066400000000000000000000054371454061450500217670ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Feb 23 05:12:13 2004 ;;;; Contains: Tests of WITH-STANDARD-IO-SYNTAX (in-package :cl-test) (deftest with-standard-io-syntax.1 (let ((*package* (find-package :cl-test))) (with-standard-io-syntax (eqlt *package* (find-package "CL-USER")))) t) (deftest with-standard-io-syntax.2 (let ((*print-array* nil)) (with-standard-io-syntax *print-array*)) t) (deftest with-standard-io-syntax.3 (let ((*print-base* 8)) (with-standard-io-syntax *print-base*)) 10) (deftest with-standard-io-syntax.4 (let ((*print-case* :downcase)) (with-standard-io-syntax *print-case*)) :upcase) (deftest with-standard-io-syntax.5 (let ((*print-circle* t)) (with-standard-io-syntax *print-circle*)) nil) (deftest with-standard-io-syntax.6 (let ((*print-escape* nil)) (with-standard-io-syntax *print-escape*)) t) (deftest with-standard-io-syntax.7 (let ((*print-gensym* nil)) (with-standard-io-syntax *print-gensym*)) t) (deftest with-standard-io-syntax.8 (let ((*print-length* 100)) (with-standard-io-syntax *print-length*)) nil) (deftest with-standard-io-syntax.9 (let ((*print-level* 100)) (with-standard-io-syntax *print-level*)) nil) (deftest with-standard-io-syntax.10 (let ((*print-lines* 100)) (with-standard-io-syntax *print-lines*)) nil) (deftest with-standard-io-syntax.11 (let ((*print-miser-width* 100)) (with-standard-io-syntax *print-miser-width*)) nil) (deftest with-standard-io-syntax.12 (let ((*print-pretty* t)) (with-standard-io-syntax *print-pretty*)) nil) (deftest with-standard-io-syntax.13 (let ((*print-right-margin* 100)) (with-standard-io-syntax *print-right-margin*)) nil) (deftest with-standard-io-syntax.14 (let ((*read-base* 8)) (with-standard-io-syntax *read-base*)) 10) (deftest with-standard-io-syntax.15 (let ((*read-default-float-format 'long-float)) (with-standard-io-syntax *read-default-float-format*)) single-float) (deftest with-standard-io-syntax.16 (let ((*read-eval* nil)) (with-standard-io-syntax *read-eval*)) t) (deftest with-standard-io-syntax.17 (let ((*read-suppress* t)) (with-standard-io-syntax *read-suppress*)) nil) (deftest with-standard-io-syntax.18 (with-standard-io-syntax (notnot-mv (readtablep *readtable*))) t) (deftest with-standard-io-syntax.19 (with-standard-io-syntax) nil) (deftest with-standard-io-syntax.20 (with-standard-io-syntax (values 'a 'b 'c)) a b c) (deftest with-standard-io-syntax.21 (block done (tagbody (with-standard-io-syntax (go 10) 10 (return-from done :bad)) 10 (return-from done :good))) :good) (deftest with-standard-io-syntax.22 (let ((i 3)) (with-standard-io-syntax (incf i 10) (+ i 2))) 15) gcl27-2.7.0/ansi-tests/write-char.lsp000066400000000000000000000016521454061450500173250ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 18 20:50:31 2004 ;;;; Contains: Tests of WRITE-CHAR (in-package :cl-test) (deftest write-char.1 (loop for i from 0 to 255 for c = (code-char i) when c unless (string= (with-output-to-string (*standard-output*) (write-char c)) (string c)) collect c) nil) (deftest write-char.2 (with-input-from-string (is "abcd") (with-output-to-string (os) (let ((*terminal-io* (make-two-way-stream is os))) (write-char #\$ t) (close *terminal-io*)))) "$") (deftest write-char.3 (with-output-to-string (*standard-output*) (write-char #\: nil)) ":") ;;; Error tests (deftest write-char.error.1 (signals-error (write-char) program-error) t) (deftest write-char.error.2 (signals-error (with-output-to-string (s) (write-char #\a s nil)) program-error) t) ;;; More tests in other files gcl27-2.7.0/ansi-tests/write-line.lsp000066400000000000000000000074711454061450500173440ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 19 06:49:26 2004 ;;;; Contains: Tests of WRITE-LINE (in-package :cl-test) (deftest write-line.1 (let (result) (values (with-output-to-string (*standard-output*) (setq result (multiple-value-list (write-line "")))) result)) #.(string #\Newline) ("")) (deftest write-line.2 :notes (:nil-vectors-are-strings) (let (result) (values (with-output-to-string (*standard-output*) (setq result (multiple-value-list (write-line (make-array '(0) :element-type nil))))) result)) #.(string #\Newline) ("")) (deftest write-line.3 (let (result) (values (with-output-to-string (*standard-output*) (setq result (multiple-value-list (write-line "abcde")))) result)) #.(concatenate 'string "abcde" (string #\Newline)) ("abcde")) (deftest write-line.4 (let (result) (values (with-output-to-string (s) (setq result (multiple-value-list (write-line "abcde" s :start 1)))) result)) #.(concatenate 'string "bcde" (string #\Newline)) ("abcde")) (deftest write-line.5 (let (result) (values (with-output-to-string (s) (setq result (multiple-value-list (write-line "abcde" s :start 1 :end 3)))) result)) #.(concatenate 'string "bc" (string #\Newline)) ("abcde")) (deftest write-line.6 (let (result) (values (with-output-to-string (s) (setq result (multiple-value-list (write-line "abcde" s :start 1 :end nil)))) result)) #.(concatenate 'string "bcde" (string #\Newline)) ("abcde")) (deftest write-line.7 (let (result) (values (with-output-to-string (s) (setq result (multiple-value-list (write-line "abcde" s :end 3)))) result)) #.(concatenate 'string "abc" (string #\Newline)) ("abcde")) (deftest write-line.8 (let (result) (values (with-output-to-string (s) (setq result (multiple-value-list (write-line "abcde" s :end 3 :allow-other-keys nil)))) result)) #.(concatenate 'string "abc" (string #\Newline)) ("abcde")) (deftest write-line.9 (let (result) (values (with-output-to-string (s) (setq result (multiple-value-list (write-line "abcde" s :end 3 :allow-other-keys t :foo 'bar)))) result)) #.(concatenate 'string "abc" (string #\Newline)) ("abcde")) (deftest write-line.10 (let (result) (values (with-output-to-string (s) (setq result (multiple-value-list (write-line "abcde" s :end 3 :end 2)))) result)) #.(concatenate 'string "abc" (string #\Newline)) ("abcde")) (deftest write-line.11 (with-input-from-string (is "abcd") (with-output-to-string (os) (let ((*terminal-io* (make-two-way-stream is os))) (write-line "951" t) (close *terminal-io*)))) #.(concatenate 'string "951" (string #\Newline))) (deftest write-line.12 (with-output-to-string (*standard-output*) (write-line "-=|!" nil)) #.(concatenate 'string "-=|!" (string #\Newline))) ;;; Specialized string tests (deftest write-line.13 (do-special-strings (s "abcde" nil) (assert (equal (with-output-to-string (*standard-output*) (multiple-value-list (write-line "abcde"))) #.(concatenate 'string "abcde" (string #\Newline))))) nil) ;;; Error tests (deftest write-line.error.1 (signals-error (write-line) program-error) t) (deftest write-line.error.2 (signals-error (write-line "" *standard-output* :start) program-error) t) (deftest write-line.error.3 (signals-error (write-line "" *standard-output* :foo nil) program-error) t) (deftest write-line.error.4 (signals-error (write-line "" *standard-output* :allow-other-keys nil :foo nil) program-error) t) gcl27-2.7.0/ansi-tests/write-sequence.lsp000066400000000000000000000167731454061450500202320ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jan 21 04:07:58 2004 ;;;; Contains: Tests of WRITE-SEQUENCE (in-package :cl-test) (defmacro def-write-sequence-test (name input args &rest expected) `(deftest ,name (let ((s ,input)) (with-output-to-string (os) (assert (eq (write-sequence s os ,@args) s)))) ,@expected)) ;;; on strings (def-write-sequence-test write-sequence.string.1 "abcde" () "abcde") (def-write-sequence-test write-sequence.string.2 "abcde" (:start 1) "bcde") (def-write-sequence-test write-sequence.string.3 "abcde" (:end 3) "abc") (def-write-sequence-test write-sequence.string.4 "abcde" (:start 1 :end 4) "bcd") (def-write-sequence-test write-sequence.string.5 "abcde" (:end nil) "abcde") (def-write-sequence-test write-sequence.string.6 "abcde" (:start 3 :end 3) "") (def-write-sequence-test write-sequence.string.7 "abcde" (:end nil :start 1) "bcde") (def-write-sequence-test write-sequence.string.8 "abcde" (:allow-other-keys nil) "abcde") (def-write-sequence-test write-sequence.string.9 "abcde" (:allow-other-keys t :foo nil) "abcde") (def-write-sequence-test write-sequence.string.10 "abcde" (:allow-other-keys t :allow-other-keys nil :foo nil) "abcde") (def-write-sequence-test write-sequence.string.11 "abcde" (:bar 'x :allow-other-keys t) "abcde") (def-write-sequence-test write-sequence.string.12 "abcde" (:start 1 :end 4 :start 2 :end 3) "bcd") (def-write-sequence-test write-sequence.string.13 "" () "") (defmacro def-write-sequence-special-test (name string args expected) `(deftest ,name (let ((str ,string) (expected ,expected)) (do-special-strings (s str nil) (let ((out (with-output-to-string (os) (assert (eq (write-sequence s os ,@args) s))))) (assert (equal out expected))))) nil)) (def-write-sequence-special-test write-sequence.string.14 "12345" () "12345") (def-write-sequence-special-test write-sequence.string.15 "12345" (:start 1 :end 3) "23") ;;; on lists (def-write-sequence-test write-sequence.list.1 (coerce "abcde" 'list) () "abcde") (def-write-sequence-test write-sequence.list.2 (coerce "abcde" 'list) (:start 1) "bcde") (def-write-sequence-test write-sequence.list.3 (coerce "abcde" 'list) (:end 3) "abc") (def-write-sequence-test write-sequence.list.4 (coerce "abcde" 'list) (:start 1 :end 4) "bcd") (def-write-sequence-test write-sequence.list.5 (coerce "abcde" 'list) (:end nil) "abcde") (def-write-sequence-test write-sequence.list.6 (coerce "abcde" 'list) (:start 3 :end 3) "") (def-write-sequence-test write-sequence.list.7 (coerce "abcde" 'list) (:end nil :start 1) "bcde") (def-write-sequence-test write-sequence.list.8 () () "") ;;; on vectors (def-write-sequence-test write-sequence.simple-vector.1 (coerce "abcde" 'simple-vector) () "abcde") (def-write-sequence-test write-sequence.simple-vector.2 (coerce "abcde" 'simple-vector) (:start 1) "bcde") (def-write-sequence-test write-sequence.simple-vector.3 (coerce "abcde" 'simple-vector) (:end 3) "abc") (def-write-sequence-test write-sequence.simple-vector.4 (coerce "abcde" 'simple-vector) (:start 1 :end 4) "bcd") (def-write-sequence-test write-sequence.simple-vector.5 (coerce "abcde" 'simple-vector) (:end nil) "abcde") (def-write-sequence-test write-sequence.simple-vector.6 (coerce "abcde" 'simple-vector) (:start 3 :end 3) "") (def-write-sequence-test write-sequence.simple-vector.7 (coerce "abcde" 'simple-vector) (:end nil :start 1) "bcde") (def-write-sequence-test write-sequence.simple-vector.8 #() () "") ;;; on vectors with fill pointers (def-write-sequence-test write-sequence.fill-vector.1 (make-array 10 :initial-contents "abcde " :fill-pointer 5) () "abcde") (def-write-sequence-test write-sequence.fill-vector.2 (make-array 10 :initial-contents "abcde " :fill-pointer 5) (:start 1) "bcde") (def-write-sequence-test write-sequence.fill-vector.3 (make-array 10 :initial-contents "abcde " :fill-pointer 5) (:end 3) "abc") (def-write-sequence-test write-sequence.fill-vector.4 (make-array 10 :initial-contents "abcde " :fill-pointer 5) (:start 1 :end 4) "bcd") (def-write-sequence-test write-sequence.fill-vector.5 (make-array 10 :initial-contents "abcde " :fill-pointer 5) (:end nil) "abcde") (def-write-sequence-test write-sequence.fill-vector.6 (make-array 10 :initial-contents "abcde " :fill-pointer 5) (:start 3 :end 3) "") (def-write-sequence-test write-sequence.fill-vector.7 (make-array 10 :initial-contents "abcde " :fill-pointer 5) (:end nil :start 1) "bcde") ;;; on bit vectors (defmacro def-write-sequence-bv-test (name input args expected) `(deftest ,name (let ((s ,input) (expected ,expected)) (with-open-file (os "tmp.dat" :direction :output :element-type '(unsigned-byte 8) :if-exists :supersede) (assert (eq (write-sequence s os ,@args) s))) (with-open-file (is "tmp.dat" :direction :input :element-type '(unsigned-byte 8)) (loop for i from 0 below (length expected) for e = (elt expected i) always (eql (read-byte is) e)))) t)) (def-write-sequence-bv-test write-sequence.bv.1 #*00111010 () #*00111010) (def-write-sequence-bv-test write-sequence.bv.2 #*00111010 (:start 1) #*0111010) (def-write-sequence-bv-test write-sequence.bv.3 #*00111010 (:end 5) #*00111) (def-write-sequence-bv-test write-sequence.bv.4 #*00111010 (:start 1 :end 6) #*01110) (def-write-sequence-bv-test write-sequence.bv.5 #*00111010 (:start 1 :end nil) #*0111010) (def-write-sequence-bv-test write-sequence.bv.6 #*00111010 (:start 1 :end nil :end 4) #*0111010) ;;; Error tests (deftest write-sequence.error.1 (signals-error (write-sequence) program-error) t) (deftest write-sequence.error.2 (signals-error (write-sequence "abcde") program-error) t) (deftest write-sequence.error.3 (signals-error (write-sequence '(#\a . #\b) *standard-output*) type-error) t) (deftest write-sequence.error.4 (signals-error (write-sequence #\a *standard-output*) type-error) t) (deftest write-sequence.error.5 (signals-error (write-sequence "ABC" *standard-output* :start -1) type-error) t) (deftest write-sequence.error.6 (signals-error (write-sequence "ABC" *standard-output* :start 'x) type-error) t) (deftest write-sequence.error.7 (signals-error (write-sequence "ABC" *standard-output* :start 0.0) type-error) t) (deftest write-sequence.error.8 (signals-error (write-sequence "ABC" *standard-output* :end -1) type-error) t) (deftest write-sequence.error.9 (signals-error (write-sequence "ABC" *standard-output* :end 'x) type-error) t) (deftest write-sequence.error.10 (signals-error (write-sequence "ABC" *standard-output* :end 2.0) type-error) t) (deftest write-sequence.error.11 (signals-error (write-sequence "abcde" *standard-output* :foo nil) program-error) t) (deftest write-sequence.error.12 (signals-error (write-sequence "abcde" *standard-output* :allow-other-keys nil :foo t) program-error) t) (deftest write-sequence.error.13 (signals-error (write-sequence "abcde" *standard-output* :start) program-error) t) (deftest write-sequence.error.14 (check-type-error #'(lambda (x) (write-sequence x *standard-output*)) #'sequencep) nil) (deftest write-sequence.error.15 (check-type-error #'(lambda (x) (write-sequence "abcde" *standard-output* :start x)) (typef 'unsigned-byte)) nil) (deftest write-sequence.error.16 (check-type-error #'(lambda (x) (write-sequence "abcde" *standard-output* :end x)) (typef '(or null unsigned-byte))) nil) gcl27-2.7.0/ansi-tests/write-string.lsp000066400000000000000000000066641454061450500177260ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 18 21:13:32 2004 ;;;; Contains: Tests of WRITE-STRING (in-package :cl-test) (deftest write-string.1 (let (result) (values (with-output-to-string (*standard-output*) (setq result (multiple-value-list (write-string "")))) result)) "" ("")) (deftest write-string.2 :notes (:nil-vectors-are-strings) (let (result) (values (with-output-to-string (*standard-output*) (setq result (multiple-value-list (write-string (make-array '(0) :element-type nil))))) result)) "" ("")) (deftest write-string.3 (let (result) (values (with-output-to-string (*standard-output*) (setq result (multiple-value-list (write-string "abcde")))) result)) "abcde" ("abcde")) (deftest write-string.4 (let (result) (values (with-output-to-string (s) (setq result (multiple-value-list (write-string "abcde" s :start 1)))) result)) "bcde" ("abcde")) (deftest write-string.5 (let (result) (values (with-output-to-string (s) (setq result (multiple-value-list (write-string "abcde" s :start 1 :end 3)))) result)) "bc" ("abcde")) (deftest write-string.6 (let (result) (values (with-output-to-string (s) (setq result (multiple-value-list (write-string "abcde" s :start 1 :end nil)))) result)) "bcde" ("abcde")) (deftest write-string.7 (let (result) (values (with-output-to-string (s) (setq result (multiple-value-list (write-string "abcde" s :end 3)))) result)) "abc" ("abcde")) (deftest write-string.8 (let (result) (values (with-output-to-string (s) (setq result (multiple-value-list (write-string "abcde" s :end 3 :allow-other-keys nil)))) result)) "abc" ("abcde")) (deftest write-string.9 (let (result) (values (with-output-to-string (s) (setq result (multiple-value-list (write-string "abcde" s :end 3 :allow-other-keys t :foo 'bar)))) result)) "abc" ("abcde")) (deftest write-string.10 (let (result) (values (with-output-to-string (s) (setq result (multiple-value-list (write-string "abcde" s :end 3 :end 2)))) result)) "abc" ("abcde")) (deftest write-string.11 (with-input-from-string (is "abcd") (with-output-to-string (os) (let ((*terminal-io* (make-two-way-stream is os))) (write-string "951" t) (close *terminal-io*)))) "951") (deftest write-string.12 (with-output-to-string (*standard-output*) (write-string "-=|!" nil)) "-=|!") ;;; Specialized string tests (deftest write-string.13 (let (result) (do-special-strings (s "abcde" nil) (assert (equal (with-output-to-string (*standard-output*) (setq result (multiple-value-list (write-string "abcde")))) "abcde")) (assert (equal result '("abcde"))))) nil) ;;; Error tests (deftest write-string.error.1 (signals-error (write-string) program-error) t) (deftest write-string.error.2 (signals-error (write-string "" *standard-output* :start) program-error) t) (deftest write-string.error.3 (signals-error (write-string "" *standard-output* :foo nil) program-error) t) (deftest write-string.error.4 (signals-error (write-string "" *standard-output* :allow-other-keys nil :foo nil) program-error) t) gcl27-2.7.0/ansi-tests/write-to-string.lsp000066400000000000000000000016761454061450500203440ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jul 25 12:53:11 2004 ;;;; Contains: Tests of WRITE-TO-STRING (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; This function is extensively used elsewhere (deftest write-to-string.1 (random-write-to-string-test 1000) nil) (deftest write-to-string.2 (with-standard-io-syntax (write-to-string 2 :allow-other-keys nil)) "2") (deftest write-to-string.3 (with-standard-io-syntax (write-to-string 3 :allow-other-keys t '#.(gensym) 0)) "3") (deftest write-to-string.4 (with-standard-io-syntax (write-to-string 4 :base 10 :base 2)) "4") ;;; Error tests (deftest write-to-string.error.1 (signals-error (write-to-string) program-error) t) (deftest write-to-string.error.2 (signals-error (write-to-string nil '#.(gensym) nil) program-error) t) (deftest write-to-string.error.3 (signals-error (write-to-string nil :radix) program-error) t) gcl27-2.7.0/ansi-tests/write.lsp000066400000000000000000000035071454061450500164130ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jul 15 06:43:55 2004 ;;;; Contains: Tests of WRITE (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;; (compile-and-load "write-aux.lsp") ;;; This function is also incidentally tested elsewhere. (deftest write.1 (random-write-test 1000) nil) (deftest write.2 (with-standard-io-syntax (let ((*print-readably* nil)) (with-output-to-string (*standard-output*) (write 2 :stream nil)))) "2") (deftest write.3 (with-standard-io-syntax (let ((*print-readably* nil)) (with-output-to-string (os) (with-input-from-string (is "") (with-open-stream (*terminal-io* (make-two-way-stream is os)) (write 3 :stream t)))))) "3") (deftest write.4 (with-standard-io-syntax (let ((*print-readably* nil)) (with-output-to-string (os) (write 4 :stream os)))) "4") (deftest write.5 (with-standard-io-syntax (let ((*print-readably* nil)) (with-output-to-string (*standard-output*) (write 5 :allow-other-keys nil)))) "5") (deftest write.6 (with-standard-io-syntax (let ((*print-readably* nil)) (with-output-to-string (*standard-output*) (write 6 :allow-other-keys t :foo 'bar)))) "6") (deftest write.7 (with-standard-io-syntax (let ((*print-readably* nil)) (with-output-to-string (*standard-output*) (write 7 :base 10 :base 3)))) "7") ;;; Error tests (deftest write.error.1 (signals-error (write) program-error) t) (deftest write.error.2 (signals-error (write 1 :stream) program-error) t) (deftest write.error.3 (signals-error (write 1 :allow-other-keys nil :foo 'bar) program-error) t) (deftest write.error.4 (signals-error (write 1 :allow-other-keys nil :allow-other-keys t :foo 'bar) program-error) t) gcl27-2.7.0/ansi-tests/zerop.lsp000066400000000000000000000037121454061450500164160ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Aug 4 21:47:34 2003 ;;;; Contains: Tests of ZEROP (in-package :cl-test) (deftest zerop.error.1 (signals-error (zerop) program-error) t) (deftest zerop.error.2 (signals-error (zerop 0 1) program-error) t) (deftest zerop.error.3 (signals-error (zerop 1 0) program-error) t) (deftest zerop.error.4 (check-type-error #'zerop #'numberp) nil) (deftest zerop.1 (loop for x in *numbers* when (if (zerop x) (/= x 0) (= x 0)) collect x) nil) (deftest zerop.2 (zerop 1) nil) (deftest zerop.3 (zerop -1) nil) (deftest zerop.4 (notnot-mv (zerop 0)) t) (deftest zerop.5 (notnot-mv (zerop 0.0s0)) t) (deftest zerop.6 (notnot-mv (zerop 0.0f0)) t) (deftest zerop.7 (notnot-mv (zerop 0.0d0)) t) (deftest zerop.7a (notnot-mv (zerop 0.0l0)) t) (deftest zerop.8 (remove-if-not #'zerop (list least-negative-short-float least-negative-normalized-short-float least-negative-single-float least-negative-normalized-single-float least-negative-double-float least-negative-normalized-double-float least-negative-long-float least-negative-normalized-long-float most-negative-short-float most-negative-single-float most-negative-double-float most-negative-long-float)) nil) (deftest zerop.9 (remove-if-not #'zerop (list least-positive-short-float least-positive-normalized-short-float least-positive-single-float least-positive-normalized-single-float least-positive-double-float least-positive-normalized-double-float least-positive-long-float least-positive-normalized-long-float most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float)) nil) (deftest zerop.10 (notevery #'zerop (list -0.0s0 -0.0f0 -0.0d0 -0.0l0)) nil) gcl27-2.7.0/bench/000077500000000000000000000000001454061450500135215ustar00rootroot00000000000000gcl27-2.7.0/bench/boyer.cl000066400000000000000000000302771454061450500151720ustar00rootroot00000000000000;; $Header$ ;; $Locker$ ;;; BOYER -- Logic programming benchmark, originally written by Bob Boyer. ;;; Fairly CONS intensive. (defvar **unify-subst**) (defvar **temp-temp**) (defun add-lemma (term) (cond ((and (not (atom term)) (eq (car term) (quote equal)) (not (atom (cadr term)))) (setf (get (car (cadr term)) (quote lemmas)) (cons term (get (car (cadr term)) (quote lemmas))))) (t (error "~%ADD-LEMMA did not like term: ~a" term)))) (defun add-lemma-lst (lst) (cond ((null lst) t) (t (add-lemma (car lst)) (add-lemma-lst (cdr lst))))) (defun apply-subst (alist term) (cond ((atom term) (cond ((setq **temp-temp** (assoc term alist :test #'eq)) (cdr **temp-temp**)) (t term))) (t (cons (car term) (apply-subst-lst alist (cdr term)))))) (defun apply-subst-lst (alist lst) (cond ((null lst) nil) (t (cons (apply-subst alist (car lst)) (apply-subst-lst alist (cdr lst)))))) (defun falsep (x lst) (or (equal x (quote (f))) (member x lst))) (defun one-way-unify (term1 term2) (progn (setq **unify-subst** nil) (one-way-unify1 term1 term2))) (defun one-way-unify1 (term1 term2) (cond ((atom term2) (cond ((setq **temp-temp** (assoc term2 **unify-subst** :test #'eq)) (equal term1 (cdr **temp-temp**))) (t (setq **unify-subst** (cons (cons term2 term1) **unify-subst**)) t))) ((atom term1) nil) ((eq (car term1) (car term2)) (one-way-unify1-&lst (cdr term1) (cdr term2))) (t nil))) (defun one-way-unify1-&lst (lst1 lst2) (cond ((null lst1) t) ((one-way-unify1 (car lst1) (car lst2)) (one-way-unify1-&lst (cdr lst1) (cdr lst2))) (t nil))) (defun rewrite (term) (cond ((atom term) term) (t (rewrite-with-lemmas (cons (car term) (rewrite-args (cdr term))) (get (car term) (quote lemmas)))))) (defun rewrite-args (lst) (cond ((null lst) nil) (t (cons (rewrite (car lst)) (rewrite-args (cdr lst)))))) (defun rewrite-with-lemmas (term lst) (cond ((null lst) term) ((one-way-unify term (cadr (car lst))) (rewrite (apply-subst **unify-subst** (caddr (car lst))))) (t (rewrite-with-lemmas term (cdr lst))))) (defun boyer-setup () (add-lemma-lst (quote ((equal (compile form) (reverse (codegen (optimize form) (nil)))) (equal (eqp x y) (equal (fix x) (fix y))) (equal (greaterp x y) (lessp y x)) (equal (lesseqp x y) (not (lessp y x))) (equal (greatereqp x y) (not (lessp x y))) (equal (boolean x) (or (equal x (t)) (equal x (f)))) (equal (iff x y) (and (implies x y) (implies y x))) (equal (even1 x) (if (zerop x) (t) (odd (1- x)))) (equal (countps- l pred) (countps-loop l pred (zero))) (equal (fact- i) (fact-loop i 1)) (equal (reverse- x) (reverse-loop x (nil))) (equal (divides x y) (zerop (remainder y x))) (equal (assume-true var alist) (cons (cons var (t)) alist)) (equal (assume-false var alist) (cons (cons var (f)) alist)) (equal (tautology-checker x) (tautologyp (normalize x) (nil))) (equal (falsify x) (falsify1 (normalize x) (nil))) (equal (prime x) (and (not (zerop x)) (not (equal x (add1 (zero)))) (prime1 x (1- x)))) (equal (and p q) (if p (if q (t) (f)) (f))) (equal (or p q) (if p (t) (if q (t) (f)) (f))) (equal (not p) (if p (f) (t))) (equal (implies p q) (if p (if q (t) (f)) (t))) (equal (fix x) (if (numberp x) x (zero))) (equal (if (if a b c) d e) (if a (if b d e) (if c d e))) (equal (zerop x) (or (equal x (zero)) (not (numberp x)))) (equal (plus (plus x y) z) (plus x (plus y z))) (equal (equal (plus a b) (zero)) (and (zerop a) (zerop b))) (equal (difference x x) (zero)) (equal (equal (plus a b) (plus a c)) (equal (fix b) (fix c))) (equal (equal (zero) (difference x y)) (not (lessp y x))) (equal (equal x (difference x y)) (and (numberp x) (or (equal x (zero)) (zerop y)))) (equal (meaning (plus-tree (append x y)) a) (plus (meaning (plus-tree x) a) (meaning (plus-tree y) a))) (equal (meaning (plus-tree (plus-fringe x)) a) (fix (meaning x a))) (equal (append (append x y) z) (append x (append y z))) (equal (reverse (append a b)) (append (reverse b) (reverse a))) (equal (times x (plus y z)) (plus (times x y) (times x z))) (equal (times (times x y) z) (times x (times y z))) (equal (equal (times x y) (zero)) (or (zerop x) (zerop y))) (equal (exec (append x y) pds envrn) (exec y (exec x pds envrn) envrn)) (equal (mc-flatten x y) (append (flatten x) y)) (equal (member x (append a b)) (or (member x a) (member x b))) (equal (member x (reverse y)) (member x y)) (equal (length (reverse x)) (length x)) (equal (member a (intersect b c)) (and (member a b) (member a c))) (equal (nth (zero) i) (zero)) (equal (exp i (plus j k)) (times (exp i j) (exp i k))) (equal (exp i (times j k)) (exp (exp i j) k)) (equal (reverse-loop x y) (append (reverse x) y)) (equal (reverse-loop x (nil)) (reverse x)) (equal (count-list z (sort-lp x y)) (plus (count-list z x) (count-list z y))) (equal (equal (append a b) (append a c)) (equal b c)) (equal (plus (remainder x y) (times y (quotient x y))) (fix x)) (equal (power-eval (big-plus1 l i base) base) (plus (power-eval l base) i)) (equal (power-eval (big-plus x y i base) base) (plus i (plus (power-eval x base) (power-eval y base)))) (equal (remainder y 1) (zero)) (equal (lessp (remainder x y) y) (not (zerop y))) (equal (remainder x x) (zero)) (equal (lessp (quotient i j) i) (and (not (zerop i)) (or (zerop j) (not (equal j 1))))) (equal (lessp (remainder x y) x) (and (not (zerop y)) (not (zerop x)) (not (lessp x y)))) (equal (power-eval (power-rep i base) base) (fix i)) (equal (power-eval (big-plus (power-rep i base) (power-rep j base) (zero) base) base) (plus i j)) (equal (gcd x y) (gcd y x)) (equal (nth (append a b) i) (append (nth a i) (nth b (difference i (length a))))) (equal (difference (plus x y) x) (fix y)) (equal (difference (plus y x) x) (fix y)) (equal (difference (plus x y) (plus x z)) (difference y z)) (equal (times x (difference c w)) (difference (times c x) (times w x))) (equal (remainder (times x z) z) (zero)) (equal (difference (plus b (plus a c)) a) (plus b c)) (equal (difference (add1 (plus y z)) z) (add1 y)) (equal (lessp (plus x y) (plus x z)) (lessp y z)) (equal (lessp (times x z) (times y z)) (and (not (zerop z)) (lessp x y))) (equal (lessp y (plus x y)) (not (zerop x))) (equal (gcd (times x z) (times y z)) (times z (gcd x y))) (equal (value (normalize x) a) (value x a)) (equal (equal (flatten x) (cons y (nil))) (and (nlistp x) (equal x y))) (equal (listp (gopher x)) (listp x)) (equal (samefringe x y) (equal (flatten x) (flatten y))) (equal (equal (greatest-factor x y) (zero)) (and (or (zerop y) (equal y 1)) (equal x (zero)))) (equal (equal (greatest-factor x y) 1) (equal x 1)) (equal (numberp (greatest-factor x y)) (not (and (or (zerop y) (equal y 1)) (not (numberp x))))) (equal (times-list (append x y)) (times (times-list x) (times-list y))) (equal (prime-list (append x y)) (and (prime-list x) (prime-list y))) (equal (equal z (times w z)) (and (numberp z) (or (equal z (zero)) (equal w 1)))) (equal (greatereqpr x y) (not (lessp x y))) (equal (equal x (times x y)) (or (equal x (zero)) (and (numberp x) (equal y 1)))) (equal (remainder (times y x) y) (zero)) (equal (equal (times a b) 1) (and (not (equal a (zero))) (not (equal b (zero))) (numberp a) (numberp b) (equal (1- a) (zero)) (equal (1- b) (zero)))) (equal (lessp (length (delete x l)) (length l)) (member x l)) (equal (sort2 (delete x l)) (delete x (sort2 l))) (equal (dsort x) (sort2 x)) (equal (length (cons x1 (cons x2 (cons x3 (cons x4 (cons x5 (cons x6 x7))))))) (plus 6 (length x7))) (equal (difference (add1 (add1 x)) 2) (fix x)) (equal (quotient (plus x (plus x y)) 2) (plus x (quotient y 2))) (equal (sigma (zero) i) (quotient (times i (add1 i)) 2)) (equal (plus x (add1 y)) (if (numberp y) (add1 (plus x y)) (add1 x))) (equal (equal (difference x y) (difference z y)) (if (lessp x y) (not (lessp y z)) (if (lessp z y) (not (lessp y x)) (equal (fix x) (fix z))))) (equal (meaning (plus-tree (delete x y)) a) (if (member x y) (difference (meaning (plus-tree y) a) (meaning x a)) (meaning (plus-tree y) a))) (equal (times x (add1 y)) (if (numberp y) (plus x (times x y)) (fix x))) (equal (nth (nil) i) (if (zerop i) (nil) (zero))) (equal (last (append a b)) (if (listp b) (last b) (if (listp a) (cons (car (last a)) b) b))) (equal (equal (lessp x y) z) (if (lessp x y) (equal t z) (equal f z))) (equal (assignment x (append a b)) (if (assignedp x a) (assignment x a) (assignment x b))) (equal (car (gopher x)) (if (listp x) (car (flatten x)) (zero))) (equal (flatten (cdr (gopher x))) (if (listp x) (cdr (flatten x)) (cons (zero) (nil)))) (equal (quotient (times y x) y) (if (zerop y) (zero) (fix x))) (equal (get j (set i val mem)) (if (eqp j i) val (get j mem))))))) (defun tautologyp (x true-lst false-lst) (cond ((truep x true-lst) t) ((falsep x false-lst) nil) ((atom x) nil) ((eq (car x) (quote if)) (cond ((truep (cadr x) true-lst) (tautologyp (caddr x) true-lst false-lst)) ((falsep (cadr x) false-lst) (tautologyp (cadddr x) true-lst false-lst)) (t (and (tautologyp (caddr x) (cons (cadr x) true-lst) false-lst) (tautologyp (cadddr x) true-lst (cons (cadr x) false-lst)))))) (t nil))) (defun tautp (x) (tautologyp (rewrite x) nil nil)) (defun boyer-test () (prog (ans term) (setq term (apply-subst (quote ((x f (plus (plus a b) (plus c (zero)))) (y f (times (times a b) (plus c d))) (z f (reverse (append (append a b) (nil)))) (u equal (plus a b) (difference x y)) (w lessp (remainder a b) (member a (length b))))) (quote (implies (and (implies x y) (and (implies y z) (and (implies z u) (implies u w)))) (implies x w))))) (setq ans (tautp term)))) #| (defun trans-of-implies (n) (list (quote implies) (trans-of-implies1 n) (list (quote implies) 0 n))) (defun trans-of-implies1 (n) (cond ((eql n 1) (list (quote implies) 0 1)) (t (list (quote and) (list (quote implies) (1- n) n) (trans-of-implies1 (1- n)))))) |# (defun truep (x lst) (or (equal x (quote (t))) (member x lst))) (defvar setup-performed-p (prog1 t (boyer-setup))) (defun testboyer () (print (time (boyer-test)))) gcl27-2.7.0/bench/browse.cl000066400000000000000000000072541454061450500153520ustar00rootroot00000000000000;; $Header$ ;; $Locker$ ;;; BROWSE -- Benchmark to create and browse through an AI-like data base ;;; of units. ;;; n is # of symbols ;;; m is maximum amount of stuff on the plist ;;; npats is the number of basic patterns on the unit ;;; ipats is the instantiated copies of the patterns (eval-when (eval compile) (defvar *browse-rand* 21) (proclaim '(type fixnum *browse-rand*)) (defconstant *browse-star* (code-char 42)) (defconstant *browse-questionmark* (code-char 63))) (eval-when (eval compile) ;; maybe SYMBOL-NAME (defmacro browse-char1 (x) `(schar (symbol-name ,x) 0))) (defun browse-init (n m npats ipats) (declare (type fixnum n m npats)) (setq *browse-rand* 21) (let ((ipats (copy-tree ipats))) (do ((p ipats (cdr p))) ((null (cdr p)) (rplacd p ipats))) (do ((n n (the fixnum (1- n))) (i m (cond ((= i 0) m) (t (the fixnum (1- i))))) (name (gentemp) (gentemp)) (a ())) ((= n 0) a) (declare (type fixnum n i)) (push name a) (do ((i i (the fixnum (1- i)))) ((= i 0)) (declare (type fixnum i)) (setf (get name (gensym)) nil)) (setf (get name 'pattern) (do ((i npats (the fixnum (1- i))) (ipats ipats (cdr ipats)) (a ())) ((= i 0) a) (declare (type fixnum i)) (push (car ipats) a))) (do ((j (the fixnum (- m i)) (the fixnum (1- j)))) ((= j 0)) (declare (type fixnum j)) (setf (get name (gensym)) nil))))) (defun browse-random () (setq *browse-rand* (rem (the fixnum (* *browse-rand* 17)) 251))) (defun browse-randomize (l) (do ((a ())) ((null l) a) (let ((n (rem (the fixnum (browse-random)) (the fixnum (length l))))) (declare (type fixnum n)) (cond ((= n 0) (push (car l) a) (setq l (cdr l))) (t (do ((n n (the fixnum (1- n))) (x l (cdr x))) ((= n 1) (push (cadr x) a) (rplacd x (cddr x))) (declare (type fixnum n)))))))) (defun match (pat dat alist) (cond ((null pat) (null dat)) ((null dat) ()) ((or (eq (car pat) '?) (eq (car pat) (car dat))) (match (cdr pat) (cdr dat) alist)) ((eq (car pat) '*) (or (match (cdr pat) dat alist) (match (cdr pat) (cdr dat) alist) (match pat (cdr dat) alist))) (t (cond ((atom (car pat)) ;;replace eq by 'eql for char (cond ((eql (browse-char1 (car pat)) *browse-questionmark*) (let ((val (assoc (car pat) alist))) (cond (val (match (cons (cdr val) (cdr pat)) dat alist)) (t (match (cdr pat) (cdr dat) (cons (cons (car pat) (car dat)) alist)))))) ((eql (browse-char1 (car pat)) *browse-star*) (let ((val (assoc (car pat) alist))) (cond (val (match (append (cdr val) (cdr pat)) dat alist)) (t (do ((l () (nconc l (cons (car d) nil))) (e (cons () dat) (cdr e)) (d dat (cdr d))) ((null e) ()) (cond ((match (cdr pat) d (cons (cons (car pat) l) alist)) (return t)))))))))) (t (and (not (atom (car dat))) (match (car pat) (car dat) alist) (match (cdr pat) (cdr dat) alist))))))) (defun browse () (investigate (browse-randomize (browse-init 100 10 4 '((a a a b b b b a a a a a b b a a a) (a a b b b b a a (a a)(b b)) (a a a b (b a) b a b a)))) '((*a ?b *b ?b a *a a *b *a) (*a *b *b *a (*a) (*b)) (? ? * (b a) * ? ?)))) (defun investigate (units pats) (do ((units units (cdr units))) ((null units)) (do ((pats pats (cdr pats))) ((null pats)) (do ((p (get (car units) 'pattern) (cdr p))) ((null p)) (match (car pats) (car p) ()))))) (defun testbrowse () (print (time (browse)))) gcl27-2.7.0/bench/cmpinit.lsp000066400000000000000000000006511454061450500157060ustar00rootroot00000000000000(in-package 'compiler) (defun delete-substring (sub string) (let ((tem (search sub string))) (cond (tem (concatenate 'string (subseq string 0 tem) (subseq string (+ tem (length sub)) ))) (t string)))) (when (and (boundp 'compiler::*cc*) (setq compiler::*cc* (delete-substring "-msoft-float" compiler::*cc*)))) ;(load "/public/akcl/cmpnew/cmpmain.lsp") ;(load "/public/akcl/cmpnew/cmptop.lsp") gcl27-2.7.0/bench/control.cl000066400000000000000000000100651454061450500155230ustar00rootroot00000000000000;; $Header$ ;; ;; benchmark control (setf (comp:target-fpp) :m68881) (setq comp::*target-architecture* :mc68020) (setf (sys:gsgc-parameter :generation-spread) 4) (require :foreign) (use-package :ff) (load "time.o") (defforeign 'get_time :entry-point (convert-to-lang "get_time" :language :c) :arguments '(t)) (import '(lisp::time-utime-sec lisp::time-utime-usec lisp::time-stime-sec lisp::time-stime-usec lisp::time-stime-minflt lisp::time-stime-majflt lisp::time-stime-maxrss lisp::time-real-sec lisp::time-real-usec)) (defcstruct time (utime-sec :unsigned-long) (utime-usec :unsigned-long) (stime-sec :unsigned-long) (stime-usec :unsigned-long) (stime-minflt :unsigned-long) (stime-majflt :unsigned-long) (stime-maxrss :unsigned-long) (real-sec :unsigned-long) (real-usec :unsigned-long)) (defmacro bm-time-macro (form) `(let ((start (make-time)) (end (make-time))) (get_time start) (multiple-value-prog1 ,form (get_time end) (print-time start end)))) (defun print-time (start end) (let* ((u1 (truncate (+ (* 1000000 (time-utime-sec start)) (time-utime-usec start)) 1000)) (s1 (truncate (+ (* 1000000 (time-stime-sec start)) (time-stime-usec start)) 1000)) (u2 (truncate (+ (* 1000000 (time-utime-sec end)) (time-utime-usec end)) 1000)) (s2 (truncate (+ (* 1000000 (time-stime-sec end)) (time-stime-usec end)) 1000)) (r1 (truncate (+ (* 1000000 (time-real-sec start)) (time-real-usec start)) 1000)) (r2 (truncate (+ (* 1000000 (time-real-sec end)) (time-real-usec end)) 1000)) (page-faults (- (+ (time-stime-majflt end) (time-stime-minflt end)) (+ (time-stime-minflt start) (time-stime-majflt start)))) (real (- r2 r1)) (user (- u2 u1)) (system (- s2 s1))) (format *trace-output* " (~10:<~d~> ;; non-gc user ~10:<~d~> ;; non-gc system ~10:<~d~> ;; gc user ~10:<~d~> ;; gc system ~10:<~d~> ;; total user ~10:<~d~> ;; total gc ~10:<~d~> ;; real ~10:<~d~> ;; max rss size (pages) ~10:<~d~> ;; page faults )" user system 0 0 user 0 real (time-stime-maxrss end) page-faults))) (defparameter *benches* '(boyer browse ctak dderiv deriv destru (div2 div2-iter div2-recur) fft fprint fread (frpoly frpoly-1 frpoly-2 frpoly-3 frpoly-4) puzzle stak tak takl takr tprint (traverse traverse-init traverse-run) triang)) (defun compile-all-bms (&optional (result-file "results.compile")) (let ((old-time (macro-function 'time))) (setf (macro-function 'time) (macro-function 'bm-time-macro)) (let ((*trace-output* (open result-file :direction :output :if-exists :supersede))) (format *trace-output* "(:benchmark-compilation~%") (gc :tenure) (bm-time-macro (dolist (bench *benches*) (if (consp bench) (setq bench (car bench))) (setq bench (string-downcase (string bench))) (compile-file (merge-pathnames (make-pathname :type "cl") bench)))) (format *trace-output* ")~%") (close *trace-output*)) (setf (macro-function 'time) old-time) nil)) (defun run-all-bms (&optional (result-file "results.run")) (let ((*trace-output* (open result-file :direction :output :if-exists :append))) (dolist (bench *benches*) (run-bench bench)) (close *trace-output*))) (defun run-bench (bench &aux name function) (cond ((consp bench) ;; the form of bench is ;; (file name1 name2 ...) (load (string-downcase (symbol-name (car bench)))) (dolist (name (cdr bench)) (run-bench-1 name (find-symbol (format nil "~a~a" 'test name))))) (t (load (string-downcase (symbol-name bench))) (run-bench-1 bench (find-symbol (format nil "~a~a" 'test bench)))))) (defun run-bench-1 (bench function) (format *trace-output* "~%(:~a~%" bench) (dotimes (n 3) (gc :tenure) (funcall function)) (format *trace-output* ")~%") (force-output *trace-output*)) (defun run-benches (&rest bench-list) (mapc #'(lambda (bench) (apply #'run-bench bench)) bench-list)) gcl27-2.7.0/bench/ctak.cl000066400000000000000000000010361454061450500147630ustar00rootroot00000000000000;; $Header$ ;; $Locker$ ;;; CTAK -- A version of the TAKeuchi function that uses the CATCH/THROW facility. (defun ctak (x y z) (catch 'ctak (ctak-aux x y z))) (defun ctak-aux (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) (throw 'ctak z)) (t (ctak-aux (catch 'ctak (ctak-aux (the fixnum (1- x)) y z)) (catch 'ctak (ctak-aux (the fixnum (1- y)) z x)) (catch 'ctak (ctak-aux (the fixnum (1- z)) x y)))))) (defun testctak () (print (time (ctak 18 12 6)))) gcl27-2.7.0/bench/dderiv.cl000066400000000000000000000041541454061450500153220ustar00rootroot00000000000000;; $Header$ ;; $Locker$ ;;; DDERIV -- Symbolic derivative benchmark written by Vaughn Pratt. ;;; This benchmark is a variant of the simple symbolic derivative program ;;; (DERIV). The main change is that it is `table-driven.' Instead of using a ;;; large COND that branches on the CAR of the expression, this program finds ;;; the code that will take the derivative on the property list of the atom in ;;; the CAR position. So, when the expression is (+ . ), the code ;;; stored under the atom '+ with indicator DERIV will take and ;;; return the derivative for '+. The way that MacLisp does this is with the ;;; special form: (DEFUN (FOO BAR) ...). This is exactly like DEFUN with an ;;; atomic name in that it expects an argument list and the compiler compiles ;;; code, but the name of the function with that code is stored on the ;;; property list of FOO under the indicator BAR, in this case. You may have ;;; to do something like: ;;; :property keyword is not Common Lisp. (defun dderiv-aux (a) (list '// (dderiv a) a)) (defun +dderiv (a) (cons '+ (mapcar 'dderiv a))) (defun -dderiv (a) (cons '- (mapcar 'dderiv a))) (defun *dderiv (a) (list '* (cons '* a) (cons '+ (mapcar 'dderiv-aux a)))) (defun //dderiv (a) (list '- (list '// (dderiv (car a)) (cadr a)) (list '// (car a) (list '* (cadr a) (cadr a) (dderiv (cadr a)))))) (mapc #'(lambda (op fun) (setf (get op 'dderiv) (symbol-function fun))) '(+ - * //) '(+dderiv -dderiv *dderiv //dderiv)) (defun dderiv (a) (cond ((atom a) (cond ((eq a 'x) 1) (t 0))) (t (let ((dderiv (get (car a) 'dderiv))) (cond (dderiv (funcall dderiv (cdr a))) (t 'error)))))) (defun dderiv-run () (do ((i 0 (the fixnum (1+ i)))) ((= (the fixnum i) 1000.)) (declare (type fixnum i)) (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)))) (defun testdderiv () (print (time (dderiv-run)))) gcl27-2.7.0/bench/deriv.cl000066400000000000000000000022061454061450500151520ustar00rootroot00000000000000;; $Header$ ;; $Locker$ ;;; DERIV -- Symbolic derivative benchmark written by Vaughn Pratt. ;;; It uses a simple subset of Lisp and does a lot of CONSing. (defun deriv-aux (a) (list '/ (deriv a) a)) (defun deriv (a) (cond ((atom a) (cond ((eq a 'x) 1) (t 0))) ((eq (car a) '+) (cons '+ (mapcar #'deriv (cdr a)))) ((eq (car a) '-) (cons '- (mapcar #'deriv (cdr a)))) ((eq (car a) '*) (list '* a (cons '+ (mapcar #'deriv-aux (cdr a))))) ((eq (car a) '/) (list '- (list '/ (deriv (cadr a)) (caddr a)) (list '/ (cadr a) (list '* (caddr a) (caddr a) (deriv (caddr a)))))) (t 'error))) (defun deriv-run () (do ((i 0 (the fixnum (1+ i)))) ((= (the fixnum i) 1000.)) ;runs it 5000 times (declare (type fixnum i)) ;improves the code a little (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)))) (defun testderiv () (print (time (deriv-run)))) gcl27-2.7.0/bench/destru-mod.cl000066400000000000000000000026621454061450500161320ustar00rootroot00000000000000;; $Header$ ;; $Locker$ ;; DESTRU -- Destructive operation benchmark ;;mod: add fixnum declaration for n in the following let: ;; (let ((n (floor (the fixnum (length (car l1))) 2))) (defun destructive (n m) (declare (type fixnum n m)) (let ((l (do ((i 10. (the fixnum (1- i))) (a () (push () a))) ((= (the fixnum i) 0) a) (declare (type fixnum i))))) (do ((i n (the fixnum (1- i)))) ((= (the fixnum i) 0)) (declare (type fixnum i)) (cond ((null (car l)) (do ((l l (cdr l))) ((null l)) (or (car l) (rplaca l (cons () ()))) (nconc (car l) (do ((j m (the fixnum (1- j))) (a () (push () a))) ((= (the fixnum j) 0) a) (declare (type fixnum j)))))) (t (do ((l1 l (cdr l1)) (l2 (cdr l) (cdr l2))) ((null l2)) (rplacd (do ((j (floor (the fixnum (length (car l2))) 2) (the fixnum (1- j))) (a (car l2) (cdr a))) ((zerop (the fixnum j)) a) (declare (type fixnum j)) (rplaca a i)) (let ((n (floor (the fixnum (length (car l1))) 2))) (declare (fixnum n)) (cond ((= (the fixnum n) 0) (rplaca l1 ()) (car l1)) (t (do ((j n (the fixnum (1- j))) (a (car l1) (cdr a))) ((= (the fixnum j) 1) (prog1 (cdr a) (rplacd a ()))) (declare (type fixnum j)) (rplaca a i)))))))))))) (defun testdestru () (print (time (destructive 600 50)))) gcl27-2.7.0/bench/destru.cl000066400000000000000000000024431454061450500153520ustar00rootroot00000000000000;; $Header$ ;; $Locker$ ;; DESTRU -- Destructive operation benchmark (defun destructive (n m) (declare (type fixnum n m)) (let ((l (do ((i 10. (the fixnum (1- i))) (a () (push () a))) ((= (the fixnum i) 0) a) (declare (type fixnum i))))) (do ((i n (the fixnum (1- i)))) ((= (the fixnum i) 0)) (declare (type fixnum i)) (cond ((null (car l)) (do ((l l (cdr l))) ((null l)) (or (car l) (rplaca l (cons () ()))) (nconc (car l) (do ((j m (the fixnum (1- j))) (a () (push () a))) ((= (the fixnum j) 0) a) (declare (type fixnum j)))))) (t (do ((l1 l (cdr l1)) (l2 (cdr l) (cdr l2))) ((null l2)) (rplacd (do ((j (floor (the fixnum (length (car l2))) 2) (the fixnum (1- j))) (a (car l2) (cdr a))) ((zerop (the fixnum j)) a) (declare (type fixnum j)) (rplaca a i)) (let ((n (floor (the fixnum (length (car l1))) 2))) (cond ((= (the fixnum n) 0) (rplaca l1 ()) (car l1)) (t (do ((j n (the fixnum (1- j))) (a (car l1) (cdr a))) ((= (the fixnum j) 1) (prog1 (cdr a) (rplacd a ()))) (declare (type fixnum j)) (rplaca a i)))))))))))) (defun testdestru () (print (time (destructive 600 50)))) gcl27-2.7.0/bench/div2.cl000066400000000000000000000021661454061450500147120ustar00rootroot00000000000000;; $Header$ ;; $Locker$ ;;; DIV2 -- Benchmark which divides by 2 using lists of n ()'s. ;;; This file contains a recursive as well as an iterative test. (defun create-n (n) (declare (type fixnum n)) (do ((n n (the fixnum (1- n))) (a () (push () a))) ((= (the fixnum n) 0) a) (declare (type fixnum n)))) (defvar ll (create-n 200.)) (defun iterative-div2 (l) (do ((l l (cddr l)) (a () (push (car l) a))) ((null l) a))) (defun recursive-div2 (l) (cond ((null l) ()) (t (cons (car l) (recursive-div2 (cddr l)))))) (defun test-1 (l) (do ((i 300 (the fixnum (1- i)))) ((= (the fixnum i) 0)) (declare (type fixnum i)) (iterative-div2 l) (iterative-div2 l) (iterative-div2 l) (iterative-div2 l))) (defun test-2 (l) (do ((i 300 (the fixnum (1- i)))) ((= (the fixnum i) 0)) (declare (type fixnum i)) (recursive-div2 l) (recursive-div2 l) (recursive-div2 l) (recursive-div2 l))) (defun testdiv2 () (testdiv2-iter) (testdiv2-recur)) (defun testdiv2-iter () (print (time (test-1 ll)))) (defun testdiv2-recur () (print (time (test-2 ll)))) gcl27-2.7.0/bench/fft-mod.cl000066400000000000000000000102601454061450500153740ustar00rootroot00000000000000;; $Header$ ;; $Locker$ ;; FFT -- This is an FFT benchmark written by Harry Barrow. ;; It tests a variety of floating point operations, including array references. (eval-when (compile) (setq *READ-DEFAULT-FLOAT-FORMAT* 'double-float) ) (defvar **fft-re** (make-array 1025. :element-type 'double-float :initial-element 0.0)) (defvar **fft-im** (make-array 1025. :element-type 'double-float :initial-element 0.0)) (defmacro ff+ (a b) `(the double-float (+ (the double-float ,a) (the double-float ,b)))) (defmacro ff*(a b) `(the double-float (* (the double-float ,a) (the double-float ,b)))) (defmacro ff-(a b) `(the double-float (- (the double-float ,a) (the double-float ,b)))) (defmacro ff/ (a b) `(the double-float (/ (the double-float ,a) (the double-float ,b)))) (proclaim '(type (simple-array double-float (*)) **fft-re** **fft-im**)) (defvar s-pi (float pi 0.0)) (proclaim '(double-float s-pi)) (defun fft (areal aimag) (declare (type (simple-array double-float (*)) areal aimag)) (prog* ((ar areal) (ai aimag) (i 1) (j 0) (k 0) (m 0) ;compute m = log(n) (n (1- (array-dimension ar 0))) (nv2 (floor n 2)) (le 0) (le1 0) (ip 0) (ur 0.0) (ui 0.0) (wr 0.0) (wi 0.0) (tr 0.0) (ti 0.0)) (declare (type fixnum i j k n nv2 m le le1 ip)) (declare (type (simple-array double-float (*)) ar ai)) (declare (double-float ur ui wr wi tr ti)) l1 (cond ((< i n) (setq m (the fixnum (1+ m)) i (the fixnum (+ i i))) (go l1))) (cond ((not (equal n (the fixnum (expt 2 m)))) (princ "error ... array size not a power of two.") (read) (return (terpri)))) (setq j 1 ;interchange elements i 1) ;in bit-reversed order l3 (cond ((< i j) (setq tr (aref ar j) ti (aref ai j)) (setf (aref ar j) (aref ar i)) (setf (aref ai j) (aref ai i)) (setf (aref ar i) tr) (setf (aref ai i) ti))) (setq k nv2) l6 (cond ((< k j) (setq j (the fixnum (- j k)) k (the fixnum (/ k 2))) (go l6))) (setq j (the fixnum (+ j k)) i (the fixnum (1+ i))) (cond ((< i n) (go l3))) (do ((l 1 (the fixnum (1+ (the fixnum l))))) ((> (the fixnum l) m)) ;loop thru stages (declare (type fixnum l)) (setq le (the fixnum (expt 2 l)) le1 (the (values fixnum fixnum) (floor le 2)) ur 1.0 ui 0.0 wr (cos (ff/ s-pi (float le1))) wi (sin (ff/ s-pi (float le1)))) (do ((j 1 (the fixnum (1+ (the fixnum j))))) ((> (the fixnum j) le1)) ;loop thru butterflies (declare (type fixnum j)) (do ((i j (+ (the fixnum i) le))) ((> (the fixnum i) n)) ;do a butterfly (declare (type fixnum i)) (setq ip (the fixnum (+ i le1)) tr (ff- (ff* (aref ar ip) ur) (ff* (aref ai ip) ui)) ti (ff+ (ff* (aref ar ip) ui) (ff* (aref ai ip) ur))) (setf (aref ar ip) (ff- (aref ar i) tr)) (setf (aref ai ip) (ff- (aref ai i) ti)) (setf (aref ar i) (ff+ (aref ar i) tr)) (setf (aref ai i) (ff+ (aref ai i) ti)))) (setq tr (ff- (ff* ur wr) (ff* ui wi)) ti (ff+ (ff* ur wi) (ff* ui wr)) ur tr ui ti)) (return t))) (defun fft-bench () (dotimes (i 10) (fft **fft-re** **fft-im**))) (defun testfft () (print (time (fft-bench)))) ;;; ;;; the following are for verifying that the implementation gives the ;;; correct result ;;; (defun clear-fft () (dotimes (i 1025) (setf (aref **fft-re** i) 0.0 (aref **fft-im** i) 0.0)) (values)) (defun setup-fft-component (theta &optional (phase 0.0)) (let ((f (ff* 2.0 (ff* pi theta))) (c (cos (ff* 0.5 (ff* pi phase)))) (s (sin (ff* 0.5 (ff* pi phase))))) (dotimes (i 1025) (let ((x (sin (* f (/ i 1024.0))))) (incf (aref **fft-re** i) (float (* c x) 0.0)) (incf (aref **fft-im** i) (float (* s x) 0.0))))) (values)) (defvar fft-delta 0.0001) (defun print-fft () (dotimes (i 1025) (let ((re (aref **fft-re** i)) (im (aref **fft-im** i))) (unless (and (< (abs re) fft-delta) (< (abs im) fft-delta)) (format t "~4d ~10f ~10f~%" i re im)))) (values)) (defun show-fft() (clear-fft) (setup-fft-component 0.2) (fft **fft-re** **fft-im**) (print-fft)) gcl27-2.7.0/bench/fft.cl000066400000000000000000000072121454061450500146220ustar00rootroot00000000000000;; $Header$ ;; $Locker$ ;; FFT -- This is an FFT benchmark written by Harry Barrow. ;; It tests a variety of floating point operations, including array references. (eval-when (compile) (setq *READ-DEFAULT-FLOAT-FORMAT* 'double-float) ) (defvar **fft-re** (make-array 1025. :element-type 'double-float :initial-element 0.0)) (defvar **fft-im** (make-array 1025. :element-type 'double-float :initial-element 0.0)) (proclaim '(type (vector double-float) **fft-re** **fft-im**)) (defvar s-pi (float pi 0.0)) (proclaim '(double-float s-pi)) (defun fft (areal aimag) (declare (type (simple-array double-float (*)) areal aimag)) (prog* ((ar areal) (ai aimag) (i 1) (j 0) (k 0) (m 0) ;compute m = log(n) (n (1- (array-dimension ar 0))) (nv2 (floor n 2)) (le 0) (le1 0) (ip 0) (ur 0.0) (ui 0.0) (wr 0.0) (wi 0.0) (tr 0.0) (ti 0.0)) (declare (type fixnum i j k n nv2 m le le1 ip)) (declare (type (simple-array double-float (*)) ar ai)) (declare (double-float ur ui wr wi tr ti)) l1 (cond ((< i n) (setq m (the fixnum (1+ m)) i (the fixnum (+ i i))) (go l1))) (cond ((not (equal n (the fixnum (expt 2 m)))) (princ "error ... array size not a power of two.") (read) (return (terpri)))) (setq j 1 ;interchange elements i 1) ;in bit-reversed order l3 (cond ((< i j) (setq tr (aref ar j) ti (aref ai j)) (setf (aref ar j) (aref ar i)) (setf (aref ai j) (aref ai i)) (setf (aref ar i) tr) (setf (aref ai i) ti))) (setq k nv2) l6 (cond ((< k j) (setq j (the fixnum (- j k)) k (the fixnum (/ k 2))) (go l6))) (setq j (the fixnum (+ j k)) i (the fixnum (1+ i))) (cond ((< i n) (go l3))) (do ((l 1 (the fixnum (1+ (the fixnum l))))) ((> (the fixnum l) m)) ;loop thru stages (declare (type fixnum l)) (setq le (the fixnum (expt 2 l)) le1 (the (values fixnum fixnum) (floor le 2)) ur 1.0 ui 0.0 wr (cos (/ s-pi (float le1))) wi (sin (/ s-pi (float le1)))) (do ((j 1 (the fixnum (1+ (the fixnum j))))) ((> (the fixnum j) le1)) ;loop thru butterflies (declare (type fixnum j)) (do ((i j (+ (the fixnum i) le))) ((> (the fixnum i) n)) ;do a butterfly (declare (type fixnum i)) (setq ip (the fixnum (+ i le1)) tr (- (* (aref ar ip) ur) (* (aref ai ip) ui)) ti (+ (* (aref ar ip) ui) (* (aref ai ip) ur))) (setf (aref ar ip) (- (aref ar i) tr)) (setf (aref ai ip) (- (aref ai i) ti)) (setf (aref ar i) (+ (aref ar i) tr)) (setf (aref ai i) (+ (aref ai i) ti)))) (setq tr (- (* ur wr) (* ui wi)) ti (+ (* ur wi) (* ui wr)) ur tr ui ti)) (return t))) (defun fft-bench () (dotimes (i 10) (fft **fft-re** **fft-im**))) (defun testfft () (print (time (fft-bench)))) ;;; ;;; the following are for verifying that the implementation gives the ;;; correct result ;;; (defun clear-fft () (dotimes (i 1025) (setf (aref **fft-re** i) 0.0 (aref **fft-im** i) 0.0)) (values)) (defun setup-fft-component (theta &optional (phase 0.0)) (let ((f (* 2 pi theta)) (c (cos (* 0.5 pi phase))) (s (sin (* 0.5 pi phase)))) (dotimes (i 1025) (let ((x (sin (* f (/ i 1024.0))))) (incf (aref **fft-re** i) (float (* c x) 0.0)) (incf (aref **fft-im** i) (float (* s x) 0.0))))) (values)) (defvar fft-delta 0.0001) (defun print-fft () (dotimes (i 1025) (let ((re (aref **fft-re** i)) (im (aref **fft-im** i))) (unless (and (< (abs re) fft-delta) (< (abs im) fft-delta)) (format t "~4d ~10f ~10f~%" i re im)))) (values)) gcl27-2.7.0/bench/foo.cl000066400000000000000000000302771454061450500146350ustar00rootroot00000000000000;; $Header$ ;; $Locker$ ;;; BOYER -- Logic programming benchmark, originally written by Bob Boyer. ;;; Fairly CONS intensive. (defvar **unify-subst**) (defvar **temp-temp**) (defun add-lemma (term) (cond ((and (not (atom term)) (eq (car term) (quote equal)) (not (atom (cadr term)))) (setf (get (car (cadr term)) (quote lemmas)) (cons term (get (car (cadr term)) (quote lemmas))))) (t (error "~%ADD-LEMMA did not like term: ~a" term)))) (defun add-lemma-lst (lst) (cond ((null lst) t) (t (add-lemma (car lst)) (add-lemma-lst (cdr lst))))) (defun apply-subst (alist term) (cond ((atom term) (cond ((setq **temp-temp** (assoc term alist :test #'eq)) (cdr **temp-temp**)) (t term))) (t (cons (car term) (apply-subst-lst alist (cdr term)))))) (defun apply-subst-lst (alist lst) (cond ((null lst) nil) (t (cons (apply-subst alist (car lst)) (apply-subst-lst alist (cdr lst)))))) (defun falsep (x lst) (or (equal x (quote (f))) (member x lst))) (defun one-way-unify (term1 term2) (progn (setq **unify-subst** nil) (one-way-unify1 term1 term2))) (defun one-way-unify1 (term1 term2) (cond ((atom term2) (cond ((setq **temp-temp** (assoc term2 **unify-subst** :test #'eq)) (equal term1 (cdr **temp-temp**))) (t (setq **unify-subst** (cons (cons term2 term1) **unify-subst**)) t))) ((atom term1) nil) ((eq (car term1) (car term2)) (one-way-unify1-&lst (cdr term1) (cdr term2))) (t nil))) (defun one-way-unify1-&lst (lst1 lst2) (cond ((null lst1) t) ((one-way-unify1 (car lst1) (car lst2)) (one-way-unify1-&lst (cdr lst1) (cdr lst2))) (t nil))) (defun rewrite (term) (cond ((atom term) term) (t (rewrite-with-lemmas (cons (car term) (rewrite-args (cdr term))) (get (car term) (quote lemmas)))))) (defun rewrite-args (lst) (cond ((null lst) nil) (t (cons (rewrite (car lst)) (rewrite-args (cdr lst)))))) (defun rewrite-with-lemmas (term lst) (cond ((null lst) term) ((one-way-unify term (cadr (car lst))) (rewrite (apply-subst **unify-subst** (caddr (car lst))))) (t (rewrite-with-lemmas term (cdr lst))))) (defun boyer-setup () (add-lemma-lst (quote ((equal (compile form) (reverse (codegen (optimize form) (nil)))) (equal (eqp x y) (equal (fix x) (fix y))) (equal (greaterp x y) (lessp y x)) (equal (lesseqp x y) (not (lessp y x))) (equal (greatereqp x y) (not (lessp x y))) (equal (boolean x) (or (equal x (t)) (equal x (f)))) (equal (iff x y) (and (implies x y) (implies y x))) (equal (even1 x) (if (zerop x) (t) (odd (1- x)))) (equal (countps- l pred) (countps-loop l pred (zero))) (equal (fact- i) (fact-loop i 1)) (equal (reverse- x) (reverse-loop x (nil))) (equal (divides x y) (zerop (remainder y x))) (equal (assume-true var alist) (cons (cons var (t)) alist)) (equal (assume-false var alist) (cons (cons var (f)) alist)) (equal (tautology-checker x) (tautologyp (normalize x) (nil))) (equal (falsify x) (falsify1 (normalize x) (nil))) (equal (prime x) (and (not (zerop x)) (not (equal x (add1 (zero)))) (prime1 x (1- x)))) (equal (and p q) (if p (if q (t) (f)) (f))) (equal (or p q) (if p (t) (if q (t) (f)) (f))) (equal (not p) (if p (f) (t))) (equal (implies p q) (if p (if q (t) (f)) (t))) (equal (fix x) (if (numberp x) x (zero))) (equal (if (if a b c) d e) (if a (if b d e) (if c d e))) (equal (zerop x) (or (equal x (zero)) (not (numberp x)))) (equal (plus (plus x y) z) (plus x (plus y z))) (equal (equal (plus a b) (zero)) (and (zerop a) (zerop b))) (equal (difference x x) (zero)) (equal (equal (plus a b) (plus a c)) (equal (fix b) (fix c))) (equal (equal (zero) (difference x y)) (not (lessp y x))) (equal (equal x (difference x y)) (and (numberp x) (or (equal x (zero)) (zerop y)))) (equal (meaning (plus-tree (append x y)) a) (plus (meaning (plus-tree x) a) (meaning (plus-tree y) a))) (equal (meaning (plus-tree (plus-fringe x)) a) (fix (meaning x a))) (equal (append (append x y) z) (append x (append y z))) (equal (reverse (append a b)) (append (reverse b) (reverse a))) (equal (times x (plus y z)) (plus (times x y) (times x z))) (equal (times (times x y) z) (times x (times y z))) (equal (equal (times x y) (zero)) (or (zerop x) (zerop y))) (equal (exec (append x y) pds envrn) (exec y (exec x pds envrn) envrn)) (equal (mc-flatten x y) (append (flatten x) y)) (equal (member x (append a b)) (or (member x a) (member x b))) (equal (member x (reverse y)) (member x y)) (equal (length (reverse x)) (length x)) (equal (member a (intersect b c)) (and (member a b) (member a c))) (equal (nth (zero) i) (zero)) (equal (exp i (plus j k)) (times (exp i j) (exp i k))) (equal (exp i (times j k)) (exp (exp i j) k)) (equal (reverse-loop x y) (append (reverse x) y)) (equal (reverse-loop x (nil)) (reverse x)) (equal (count-list z (sort-lp x y)) (plus (count-list z x) (count-list z y))) (equal (equal (append a b) (append a c)) (equal b c)) (equal (plus (remainder x y) (times y (quotient x y))) (fix x)) (equal (power-eval (big-plus1 l i base) base) (plus (power-eval l base) i)) (equal (power-eval (big-plus x y i base) base) (plus i (plus (power-eval x base) (power-eval y base)))) (equal (remainder y 1) (zero)) (equal (lessp (remainder x y) y) (not (zerop y))) (equal (remainder x x) (zero)) (equal (lessp (quotient i j) i) (and (not (zerop i)) (or (zerop j) (not (equal j 1))))) (equal (lessp (remainder x y) x) (and (not (zerop y)) (not (zerop x)) (not (lessp x y)))) (equal (power-eval (power-rep i base) base) (fix i)) (equal (power-eval (big-plus (power-rep i base) (power-rep j base) (zero) base) base) (plus i j)) (equal (gcd x y) (gcd y x)) (equal (nth (append a b) i) (append (nth a i) (nth b (difference i (length a))))) (equal (difference (plus x y) x) (fix y)) (equal (difference (plus y x) x) (fix y)) (equal (difference (plus x y) (plus x z)) (difference y z)) (equal (times x (difference c w)) (difference (times c x) (times w x))) (equal (remainder (times x z) z) (zero)) (equal (difference (plus b (plus a c)) a) (plus b c)) (equal (difference (add1 (plus y z)) z) (add1 y)) (equal (lessp (plus x y) (plus x z)) (lessp y z)) (equal (lessp (times x z) (times y z)) (and (not (zerop z)) (lessp x y))) (equal (lessp y (plus x y)) (not (zerop x))) (equal (gcd (times x z) (times y z)) (times z (gcd x y))) (equal (value (normalize x) a) (value x a)) (equal (equal (flatten x) (cons y (nil))) (and (nlistp x) (equal x y))) (equal (listp (gopher x)) (listp x)) (equal (samefringe x y) (equal (flatten x) (flatten y))) (equal (equal (greatest-factor x y) (zero)) (and (or (zerop y) (equal y 1)) (equal x (zero)))) (equal (equal (greatest-factor x y) 1) (equal x 1)) (equal (numberp (greatest-factor x y)) (not (and (or (zerop y) (equal y 1)) (not (numberp x))))) (equal (times-list (append x y)) (times (times-list x) (times-list y))) (equal (prime-list (append x y)) (and (prime-list x) (prime-list y))) (equal (equal z (times w z)) (and (numberp z) (or (equal z (zero)) (equal w 1)))) (equal (greatereqpr x y) (not (lessp x y))) (equal (equal x (times x y)) (or (equal x (zero)) (and (numberp x) (equal y 1)))) (equal (remainder (times y x) y) (zero)) (equal (equal (times a b) 1) (and (not (equal a (zero))) (not (equal b (zero))) (numberp a) (numberp b) (equal (1- a) (zero)) (equal (1- b) (zero)))) (equal (lessp (length (delete x l)) (length l)) (member x l)) (equal (sort2 (delete x l)) (delete x (sort2 l))) (equal (dsort x) (sort2 x)) (equal (length (cons x1 (cons x2 (cons x3 (cons x4 (cons x5 (cons x6 x7))))))) (plus 6 (length x7))) (equal (difference (add1 (add1 x)) 2) (fix x)) (equal (quotient (plus x (plus x y)) 2) (plus x (quotient y 2))) (equal (sigma (zero) i) (quotient (times i (add1 i)) 2)) (equal (plus x (add1 y)) (if (numberp y) (add1 (plus x y)) (add1 x))) (equal (equal (difference x y) (difference z y)) (if (lessp x y) (not (lessp y z)) (if (lessp z y) (not (lessp y x)) (equal (fix x) (fix z))))) (equal (meaning (plus-tree (delete x y)) a) (if (member x y) (difference (meaning (plus-tree y) a) (meaning x a)) (meaning (plus-tree y) a))) (equal (times x (add1 y)) (if (numberp y) (plus x (times x y)) (fix x))) (equal (nth (nil) i) (if (zerop i) (nil) (zero))) (equal (last (append a b)) (if (listp b) (last b) (if (listp a) (cons (car (last a)) b) b))) (equal (equal (lessp x y) z) (if (lessp x y) (equal t z) (equal f z))) (equal (assignment x (append a b)) (if (assignedp x a) (assignment x a) (assignment x b))) (equal (car (gopher x)) (if (listp x) (car (flatten x)) (zero))) (equal (flatten (cdr (gopher x))) (if (listp x) (cdr (flatten x)) (cons (zero) (nil)))) (equal (quotient (times y x) y) (if (zerop y) (zero) (fix x))) (equal (get j (set i val mem)) (if (eqp j i) val (get j mem))))))) (defun tautologyp (x true-lst false-lst) (cond ((truep x true-lst) t) ((falsep x false-lst) nil) ((atom x) nil) ((eq (car x) (quote if)) (cond ((truep (cadr x) true-lst) (tautologyp (caddr x) true-lst false-lst)) ((falsep (cadr x) false-lst) (tautologyp (cadddr x) true-lst false-lst)) (t (and (tautologyp (caddr x) (cons (cadr x) true-lst) false-lst) (tautologyp (cadddr x) true-lst (cons (cadr x) false-lst)))))) (t nil))) (defun tautp (x) (tautologyp (rewrite x) nil nil)) (defun boyer-test () (prog (ans term) (setq term (apply-subst (quote ((x f (plus (plus a b) (plus c (zero)))) (y f (times (times a b) (plus c d))) (z f (reverse (append (append a b) (nil)))) (u equal (plus a b) (difference x y)) (w lessp (remainder a b) (member a (length b))))) (quote (implies (and (implies x y) (and (implies y z) (and (implies z u) (implies u w)))) (implies x w))))) (setq ans (tautp term)))) #| (defun trans-of-implies (n) (list (quote implies) (trans-of-implies1 n) (list (quote implies) 0 n))) (defun trans-of-implies1 (n) (cond ((eql n 1) (list (quote implies) 0 1)) (t (list (quote and) (list (quote implies) (1- n) n) (trans-of-implies1 (1- n)))))) |# (defun truep (x lst) (or (equal x (quote (t))) (member x lst))) (defvar setup-performed-p (prog1 t (boyer-setup))) (defun testboyer () (print (time (boyer-test)))) gcl27-2.7.0/bench/foo.lsp000066400000000000000000000044411454061450500150270ustar00rootroot00000000000000;; $Header$ ;; $Locker$ ;;; TRIANG -- Board game benchmark. (proclaim '(special board sequence a b c)) (proclaim '(type (vector fixnum ) board sequence a b c)) (defvar answer) (defvar final) (defun triang-setup () (setq board (make-array 16 :element-type 'fixnum :initial-element 1)) (setq sequence (make-array 14 :element-type 'fixnum :initial-element 0)) (setq a (make-array 37 :element-type 'fixnum :initial-contents '(1 2 4 3 5 6 1 3 6 2 5 4 11 12 13 7 8 4 4 7 11 8 12 13 6 10 15 9 14 13 13 14 15 9 10 6 6))) (setq b (make-array 37 :element-type 'fixnum :initial-contents '(2 4 7 5 8 9 3 6 10 5 9 8 12 13 14 8 9 5 2 4 7 5 8 9 3 6 10 5 9 8 12 13 14 8 9 5 5))) (setq c (make-array 37 :element-type 'fixnum :initial-contents '(4 7 11 8 12 13 6 10 15 9 14 13 13 14 15 9 10 6 1 2 4 3 5 6 1 3 6 2 5 4 11 12 13 7 8 4 4))) (setf (aref board 5) 0)) (defun last-position () (do ((i 1 (the fixnum (+ i 1)))) ((= i 16) 0) (declare (fixnum i)) (if (eql 1 (aref board i)) (return i)))) (defun try (i depth) (declare (fixnum i depth)) (cond ((= depth 14) (let ((lp (last-position))) (unless (member lp final :test #'eql) (push lp final))) ;;; (format t "~&~s" (cdr (simple-vector-to-list sequence))) (push (cdr (simple-vector-to-list sequence)) answer) t) ; this is a hack to replace LISTARRAY ((and (eql 1 (aref board (aref a i))) (eql 1 (aref board (aref b i))) (eql 0 (aref board (aref c i)))) (setf (aref board (aref a i)) 0) (setf (aref board (aref b i)) 0) (setf (aref board (aref c i)) 1) (setf (aref sequence depth) i) (do ((j 0 (the fixnum (+ j 1))) (depth (the fixnum (+ depth 1)))) ((or (= j 36) (try j depth)) ()) (declare (fixnum j depth))) (setf (aref board (aref a i)) 1) (setf (aref board (aref b i)) 1) (setf (aref board (aref c i)) 0) ()))) (defun simple-vector-to-list (seq) (do ((i (- (length seq) 1) (1- i)) (res)) ((< i 0) res) (declare (fixnum i)) (declare (type (array fixnum) seq)) (push (aref seq i) res))) (defun gogogo (i) (let ((answer ()) (final ())) (try i 1))) (defun testtriang () (triang-setup) (print (time (gogogo 22)))) gcl27-2.7.0/bench/fprint.cl000066400000000000000000000020261454061450500153430ustar00rootroot00000000000000;; $Header$ ;; $Locker$ ;;; FPRINT -- Benchmark to print to a file. (defvar test-atoms '(abcdef12 cdefgh23 efghij34 ghijkl45 ijklmn56 klmnop67 mnopqr78 opqrst89 qrstuv90 stuvwx01 uvwxyz12 wxyzab23 xyzabc34 123456ab 234567bc 345678cd 456789de 567890ef 678901fg 789012gh 890123hi)) (defun init-aux (m n atoms) (declare (fixnum m n)) (cond ((= m 0) (pop atoms)) (t (do ((i n (the fixnum (- i 2))) (a ())) ((< i 1) a) (declare (fixnum i)) (push (pop atoms) a) (push (init-aux (the fixnum (1- m)) n atoms) a))))) (defun fprint-init (m n atoms) (let ((atoms (subst () () atoms))) (do ((a atoms (cdr a))) ((null (cdr a)) (rplacd a atoms))) (init-aux m n atoms))) (defvar test-pattern (fprint-init 6. 6. test-atoms)) (defun fprint () (if (probe-file "/tmp/fprint.tst") (delete-file "/tmp/fprint.tst")) (let ((stream (open "/tmp/fprint.tst" :direction :output))) (print test-pattern stream) (close stream))) (defun testfprint () (print (time (fprint)))) gcl27-2.7.0/bench/fread.cl000066400000000000000000000005131454061450500151210ustar00rootroot00000000000000;; $Header$ ;; $Locker$ ;;; FREAD -- Benchmark to read from a file. ;;; Pronounced "FRED". Requires the existance of FPRINT.TST which is created ;;; by FPRINT. (defun fread () (let ((stream (open "/tmp/fprint.tst" :direction :input))) (read stream) (close stream))) (defun testfread () (print (time (fread)))) gcl27-2.7.0/bench/frpoly-mod.cl000066400000000000000000000133051454061450500161330ustar00rootroot00000000000000;; $Header$ ;; $Locker$ ;; FRPOLY -- Benchmark from Berkeley based on polynomial arithmetic. ;; Originally writen in Franz Lisp by Richard Fateman. ;; PDIFFER1 appears in the code, but is not defined; is not called for in this ;; test, however. ;; ;; This contain 2 fixes from Gabriel's book. ;; ;; "ptimes3": after label 'b', change the "if" to a "cond". ;; The "go" should be activated when the condition ;; holds, NOT when it fails. ;; ;; The variables *x*, u*, and v are used specially, since this is ;; used to handle polynomial coefficients in a recursive ;; way. Declaring them global is the wrong approach. (defvar ans) (defvar coef) (defvar f) (defvar inc) (defvar i) (defvar qq) (defvar ss) (defvar v) (defvar *x*) (defvar *alpha*) (defvar *a*) (defvar *b*) (defvar *chk) (defvar *l) (defvar *p) (defvar q*) (defvar u*) (defvar *var) (defvar *y*) (defvar r) (defvar r2) (defvar r3) (defvar start) (defvar res1) (defvar res2) (defvar res3) ;(defmacro pointergp (x y) `(> (get ,x 'order)(get ,y 'order))) (defmacro valget (x) `(the fixnum (symbol-value ,x))) (defmacro pointergp (x y) `(> (valget ,x) (valget ,y))) (defmacro f+ (x y) `(the fixnum (+ (the fixnum ,x) (the fixnum ,y)))) (defmacro f> (x y) `(> (the fixnum ,x) (the fixnum ,y))) (defmacro pcoefp (e) `(atom ,e)) (defmacro pzerop (x) `(and (not (consp ,x)) (if (typep ,x 'fixnum) (eql 0 (the fixnum ,x)) (if (typep ,x 'float) (= 0.0 (the float ,x)))))) (defmacro pzero () 0) (defmacro cplus (x y) `(+ ,x ,y)) (defmacro ctimes (x y) `(* ,x ,y)) (defun pcoefadd (e c x) (if (pzerop c) x (cons e (cons c x)))) (defun pcplus (c p) (if (pcoefp p) (cplus p c) (psimp (car p) (pcplus1 c (cdr p))))) (defun pcplus1 (c x) (cond ((null x) (if (pzerop c) nil (cons 0 (cons c nil)))) ((pzerop (car x)) (pcoefadd 0 (pplus c (cadr x)) nil)) (t (cons (car x) (cons (cadr x) (pcplus1 c (cddr x))))))) (defun pctimes (c p) (if (pcoefp p) (ctimes c p) (psimp (car p) (pctimes1 c (cdr p))))) (defun pctimes1 (c x) (if (null x) nil (pcoefadd (car x) (ptimes c (cadr x)) (pctimes1 c (cddr x))))) (defun pplus (x y) (cond ((pcoefp x) (pcplus x y)) ((pcoefp y) (pcplus y x)) ((eq (car x) (car y)) (psimp (car x) (pplus1 (cdr y) (cdr x)))) ((pointergp (car x) (car y)) (psimp (car x) (pcplus1 y (cdr x)))) (t (psimp (car y) (pcplus1 x (cdr y)))))) (defun pplus1 (x y) (cond ((null x) y) ((null y) x) ((= (car x) (car y)) (pcoefadd (car x) (pplus (cadr x) (cadr y)) (pplus1 (cddr x) (cddr y)))) ((> (car x) (car y)) (cons (car x) (cons (cadr x) (pplus1 (cddr x) y)))) (t (cons (car y) (cons (cadr y) (pplus1 x (cddr y))))))) (defun psimp (var x) (cond ((null x) 0) ((atom x) x) ((zerop (car x)) (cadr x)) (t (cons var x)))) (defun ptimes (x y) (cond ((or (pzerop x) (pzerop y)) (pzero)) ((pcoefp x) (pctimes x y)) ((pcoefp y) (pctimes y x)) ((eq (car x) (car y)) (psimp (car x) (ptimes1 (cdr x) (cdr y)))) ((pointergp (car x) (car y)) (psimp (car x) (pctimes1 y (cdr x)))) (t (psimp (car y) (pctimes1 x (cdr y)))))) (defun ptimes1 (*x* y) (prog (u* v) (setq v (setq u* (ptimes2 y))) a (setq *x* (cddr *x*)) (if (null *x*) (return u*)) (ptimes3 y) (go a))) (defun ptimes2 (y) (if (null y) nil (pcoefadd (+ (car *x*) (car y)) (ptimes (cadr *x*) (cadr y)) (ptimes2 (cddr y))))) (defun ptimes3 (y) (prog (e u c) a1 (if (null y) (return nil)) (setq e (f+ (car *x*) (car y)) c (ptimes (cadr y) (cadr *x*) )) (cond ((pzerop c) (setq y (cddr y)) (go a1)) ((or (null v) (f> e (car v))) (setq u* (setq v (pplus1 u* (list e c)))) (setq y (cddr y)) (go a1)) ((= e (car v)) (setq c (pplus c (cadr v))) (if (pzerop c) ; never true, evidently (setq u* (setq v (pdiffer1 u* (list (car v) (cadr v))))) (rplaca (cdr v) c)) (setq y (cddr y)) (go a1))) a (cond ((and (cddr v) (> (caddr v) e)) (setq v (cddr v)) (go a))) (setq u (cdr v)) b (cond ((or (null (cdr u)) (< (cadr u) e)) (rplacd u (cons e (cons c (cdr u)))) (go e))) (cond ((pzerop (setq c (pplus (caddr u) c))) (rplacd u (cdddr u)) (go d)) (t (rplaca (cddr u) c))) e (setq u (cddr u)) d (setq y (cddr y)) (if (null y) (return nil)) (setq e (f+ (car *x*) (car y)) c (ptimes (cadr y) (cadr *x*))) c (cond ((and (cdr u) (> (cadr u) e)) (setq u (cddr u)) (go c))) (go b))) (defun pexptsq (p n) (do ((n (floor n 2) (floor n 2)) (s (if (oddp n) p 1))) ((zerop n) s) (setq p (ptimes p p)) (and (oddp n) (setq s (ptimes s p))))) (eval-when (load eval) (setf (valget 'x ) 1) (setf (valget 'y) 2) (setf (valget 'z ) 3) (setq r (pplus '(x 1 1 0 1) (pplus '(y 1 1) '(z 1 1))) ; r= x+y+z+1 r2 (ptimes r 100000) ; r2 = 100000*r r3 (ptimes r 1.0))) ; r3 = r with floating point coefficients (defun standard-frpoly-test1 () (progn (pexptsq r 2) (pexptsq r2 2) (pexptsq r3 2) nil)) (defun standard-frpoly-test2 () (progn (pexptsq r 5) (pexptsq r2 5) (pexptsq r3 5) nil)) (defun standard-frpoly-test3 () (progn (pexptsq r 10) (pexptsq r2 10) (pexptsq r3 10) nil)) (defun standard-frpoly-test4 () (progn (pexptsq r 15) (pexptsq r2 15) (pexptsq r3 15) nil)) (defun testfrpoly () (testfrpoly-1) (testfrpoly-2) (testfrpoly-3) (testfrpoly-4)) (defun testfrpoly-1 () (print (time (standard-frpoly-test1)))) (defun testfrpoly-2 () (print (time (standard-frpoly-test2)))) (defun testfrpoly-3 () (print (time (standard-frpoly-test3)))) (defun testfrpoly-4 () (print (time (standard-frpoly-test4)))) gcl27-2.7.0/bench/frpoly.cl000066400000000000000000000126241454061450500153610ustar00rootroot00000000000000;; $Header$ ;; $Locker$ ;; FRPOLY -- Benchmark from Berkeley based on polynomial arithmetic. ;; Originally writen in Franz Lisp by Richard Fateman. ;; PDIFFER1 appears in the code, but is not defined; is not called for in this ;; test, however. ;; ;; This contain 2 fixes from Gabriel's book. ;; ;; "ptimes3": after label 'b', change the "if" to a "cond". ;; The "go" should be activated when the condition ;; holds, NOT when it fails. ;; ;; The variables *x*, u*, and v are used specially, since this is ;; used to handle polynomial coefficients in a recursive ;; way. Declaring them global is the wrong approach. (defvar ans) (defvar coef) (defvar f) (defvar inc) (defvar i) (defvar qq) (defvar ss) (defvar v) (defvar *x*) (defvar *alpha*) (defvar *a*) (defvar *b*) (defvar *chk) (defvar *l) (defvar *p) (defvar q*) (defvar u*) (defvar *var) (defvar *y*) (defvar r) (defvar r2) (defvar r3) (defvar start) (defvar res1) (defvar res2) (defvar res3) (defmacro pointergp (x y) `(> (get ,x 'order)(get ,y 'order))) (defmacro pcoefp (e) `(atom ,e)) (defmacro pzerop (x) `(if (numberp ,x) ; no signp in CL (zerop ,x))) (defmacro pzero () 0) (defmacro cplus (x y) `(+ ,x ,y)) (defmacro ctimes (x y) `(* ,x ,y)) (defun pcoefadd (e c x) (if (pzerop c) x (cons e (cons c x)))) (defun pcplus (c p) (if (pcoefp p) (cplus p c) (psimp (car p) (pcplus1 c (cdr p))))) (defun pcplus1 (c x) (cond ((null x) (if (pzerop c) nil (cons 0 (cons c nil)))) ((pzerop (car x)) (pcoefadd 0 (pplus c (cadr x)) nil)) (t (cons (car x) (cons (cadr x) (pcplus1 c (cddr x))))))) (defun pctimes (c p) (if (pcoefp p) (ctimes c p) (psimp (car p) (pctimes1 c (cdr p))))) (defun pctimes1 (c x) (if (null x) nil (pcoefadd (car x) (ptimes c (cadr x)) (pctimes1 c (cddr x))))) (defun pplus (x y) (cond ((pcoefp x) (pcplus x y)) ((pcoefp y) (pcplus y x)) ((eq (car x) (car y)) (psimp (car x) (pplus1 (cdr y) (cdr x)))) ((pointergp (car x) (car y)) (psimp (car x) (pcplus1 y (cdr x)))) (t (psimp (car y) (pcplus1 x (cdr y)))))) (defun pplus1 (x y) (cond ((null x) y) ((null y) x) ((= (car x) (car y)) (pcoefadd (car x) (pplus (cadr x) (cadr y)) (pplus1 (cddr x) (cddr y)))) ((> (car x) (car y)) (cons (car x) (cons (cadr x) (pplus1 (cddr x) y)))) (t (cons (car y) (cons (cadr y) (pplus1 x (cddr y))))))) (defun psimp (var x) (cond ((null x) 0) ((atom x) x) ((zerop (car x)) (cadr x)) (t (cons var x)))) (defun ptimes (x y) (cond ((or (pzerop x) (pzerop y)) (pzero)) ((pcoefp x) (pctimes x y)) ((pcoefp y) (pctimes y x)) ((eq (car x) (car y)) (psimp (car x) (ptimes1 (cdr x) (cdr y)))) ((pointergp (car x) (car y)) (psimp (car x) (pctimes1 y (cdr x)))) (t (psimp (car y) (pctimes1 x (cdr y)))))) (defun ptimes1 (*x* y) (prog (u* v) (setq v (setq u* (ptimes2 y))) a (setq *x* (cddr *x*)) (if (null *x*) (return u*)) (ptimes3 y) (go a))) (defun ptimes2 (y) (if (null y) nil (pcoefadd (+ (car *x*) (car y)) (ptimes (cadr *x*) (cadr y)) (ptimes2 (cddr y))))) (defun ptimes3 (y) (prog (e u c) a1 (if (null y) (return nil)) (setq e (+ (car *x*) (car y)) c (ptimes (cadr y) (cadr *x*) )) (cond ((pzerop c) (setq y (cddr y)) (go a1)) ((or (null v) (> e (car v))) (setq u* (setq v (pplus1 u* (list e c)))) (setq y (cddr y)) (go a1)) ((= e (car v)) (setq c (pplus c (cadr v))) (if (pzerop c) ; never true, evidently (setq u* (setq v (pdiffer1 u* (list (car v) (cadr v))))) (rplaca (cdr v) c)) (setq y (cddr y)) (go a1))) a (cond ((and (cddr v) (> (caddr v) e)) (setq v (cddr v)) (go a))) (setq u (cdr v)) b (cond ((or (null (cdr u)) (< (cadr u) e)) (rplacd u (cons e (cons c (cdr u)))) (go e))) (cond ((pzerop (setq c (pplus (caddr u) c))) (rplacd u (cdddr u)) (go d)) (t (rplaca (cddr u) c))) e (setq u (cddr u)) d (setq y (cddr y)) (if (null y) (return nil)) (setq e (+ (car *x*) (car y)) c (ptimes (cadr y) (cadr *x*))) c (cond ((and (cdr u) (> (cadr u) e)) (setq u (cddr u)) (go c))) (go b))) (defun pexptsq (p n) (do ((n (floor n 2) (floor n 2)) (s (if (oddp n) p 1))) ((zerop n) s) (setq p (ptimes p p)) (and (oddp n) (setq s (ptimes s p))))) (eval-when (load eval) (setf (get 'x 'order) 1) (setf (get 'y 'order) 2) (setf (get 'z 'order) 3) (setq r (pplus '(x 1 1 0 1) (pplus '(y 1 1) '(z 1 1))) ; r= x+y+z+1 r2 (ptimes r 100000) ; r2 = 100000*r r3 (ptimes r 1.0))) ; r3 = r with floating point coefficients (defun standard-frpoly-test1 () (progn (pexptsq r 2) (pexptsq r2 2) (pexptsq r3 2) nil)) (defun standard-frpoly-test2 () (progn (pexptsq r 5) (pexptsq r2 5) (pexptsq r3 5) nil)) (defun standard-frpoly-test3 () (progn (pexptsq r 10) (pexptsq r2 10) (pexptsq r3 10) nil)) (defun standard-frpoly-test4 () (progn (pexptsq r 15) (pexptsq r2 15) (pexptsq r3 15) nil)) (defun testfrpoly () (testfrpoly-1) (testfrpoly-2) (testfrpoly-3) (testfrpoly-4)) (defun testfrpoly-1 () (print (time (standard-frpoly-test1)))) (defun testfrpoly-2 () (print (time (standard-frpoly-test2)))) (defun testfrpoly-3 () (print (time (standard-frpoly-test3)))) (defun testfrpoly-4 () (print (time (standard-frpoly-test4)))) gcl27-2.7.0/bench/init.lsp000066400000000000000000000016411454061450500152060ustar00rootroot00000000000000(si::set-hole-size 1000) (si::allocate 'cons 2000 t) (si::allocate 'fixnum 400) ;(si::allocate 'cfun 400) #-next (si::allocate-relocatable-pages 700 t) ;#+next (si::allocate-relocatable-pages 1000 t) (si::gbc 1) (setq si::*notify-gbc* t) (setq compiler::*cc* (concatenate 'string compiler::*cc* " -O6 ")) (trace si::system) ;;so that the lisps do the same thing. (setq *print-pretty* nil) ;#+sparc(setq compiler::*cc* (concatenate 'string compiler::*cc* " -O4 ")) ;(setq compiler::*cc* "/u15/gcc-2/gcc -B/u15/gcc-2/ -I/u15/gcc-2/include -I/u15/gcc-2 -DVOL=volatile -W -DMUST_COPY_VA_LIST") ;(setq compiler::*cc* "mygcc -DVOL=volatile -W -DMUST_COPY_VA_LIST") ;(setq compiler::*cc* "cc -DVOL= ") ;(trace system) ;(setq compiler::*cc* "gcc -pipe -fwritable-strings -DVOL=volatile -I/usr/local/src/gcl-2.2/o -fsigned-char -fcaller-saves -fomit-frame-pointer -funroll-loops -static -O6 -c -I. boyer.c -w ") gcl27-2.7.0/bench/integer.cl000066400000000000000000000020121454061450500154710ustar00rootroot00000000000000 (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)) ; (print (list n tt d s)) (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)))))))) (defun dvide (x y n) (let* ((ew (+ (integer-length (car y)) (- (integer-length (car x))) n 1)) (mw (truncate (ash (car x) ew) (car y))) (ew (- (cdr x) (cdr y) ew))) (cons mw ew))) (defun pi (bits) (dvide (cons 1 0) (pi-inv bits) bits)) (defun test-float (x) (scale-float (coerce (car x) 'long-float) (cdr x))) (defun factorial (n) (declare (fixnum n)) (do ((i 1 (+ i 1)) (ans 1 (* i ans))) ((> i n) ans) (declare (fixnum i ) (integer ans)))) gcl27-2.7.0/bench/make-declare.lsp000066400000000000000000000054341454061450500165610ustar00rootroot00000000000000;; By W. Schelter ;; Usage: (si::proclaim-file "foo.lsp") (compile-file "foo.lsp") (in-package 'si) (proclaim (quote (optimize (compilation-speed 0) (safety 0) (speed 3) (space 0) (debug 0)))) ;; 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 efect. Unfortunately it is impossible to tell about ;; multiple values without doing a full compiler type pass over ;; all files in the relevant system. AKCL supports doing such a pass ;; during the compilation of a system, and can thus produce proclaims for ;; a subsequent compilation. [see emit-fn documentation]. (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 )))))))) (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) '(DEFUN)) (COND ((AND (listp (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 `(ftype (function ,(ARG-DECLARES (THIRD FORM) (cdddr FORM)) t) ,(cadr form))) )))))) (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) gcl27-2.7.0/bench/makefile000066400000000000000000000021711454061450500152220ustar00rootroot00000000000000# Makefile for running gabriel bench marks # Do # make "LISP= lisp name " # except for CMULISP which requires # make "LISP=cmulisp" "QUIT=(quit)" FILES= boyer browse ctak dderiv deriv destru-mod destru div2 fft-mod \ fft fprint fread frpoly puzzle-mod puzzle stak \ tak-mod tak takl takr tprint traverse triang-mod triang REPEAT=1 LISP=akcl RESULTS= times all: times make -e "LISP=${LISP}" "FILES=${FILES}" "QUIT=${QUIT}" compile @ echo >> $(RESULTS) @ echo "-------------- SESSION ------------------" >> $(RESULTS) @ echo >> $(RESULTS) @ echo " " For $(LISP) Common Lisp >> $(RESULTS) @ date >> $(RESULTS) make -i -e "LISP=${LISP}" "FILES=${FILES}" "QUIT=${QUIT}" test compile: for v in $(FILES) ; do \ echo "(load \"make-declare.lsp\")(si::proclaim-file \"$$v.cl\")" \ "(compile-file \"$$v.cl\")" "$(QUIT)" | $(LISP) ; done test: times for v in $(FILES) ; do \ echo "(load \"test-help.lsp\")(do-test \"$$v\" \"$(RESULTS)\")${QUIT}" \ | $(LISP); \ done clean: rm -f core *.o *.lbin *.bin *.*fasl *~ *.x86f times times: touch times tar: tar cvf - *.cl *.lsp makefile | gzip -c > gabriel.tgz gcl27-2.7.0/bench/puzzle-mod.cl000066400000000000000000000121631454061450500161520ustar00rootroot00000000000000;; $Header$ ;; $Locker$ (eval-when (compile load eval) (defconstant puzzle-size 511.) (defconstant puzzle-classmax 3.) (defconstant puzzle-typemax 12.)) (defvar **iii** 0) (defvar **kount** 0) (defvar puzzle-d 8.) (proclaim '(type fixnum **iii** **kount** puzzle-d)) (defvar piececount (make-array (1+ puzzle-classmax) :element-type 'fixnum :initial-element 0)) (defvar puzzle-class (make-array (1+ puzzle-typemax) :element-type 'fixnum :initial-element 0)) (defvar piecemax (make-array (1+ puzzle-typemax) :element-type 'fixnum :initial-element 0)) (defvar puzzle (make-array (1+ puzzle-size))) (defvar puzzle-p (make-array (list (1+ puzzle-typemax) (1+ puzzle-size)))) (proclaim '(type (array fixnum) piececount puzzle-class piecemax)) (defmacro fref (a i) `(the fixnum (aref ,a (the fixnum ,i)))) (proclaim '(type simple-vector puzzle)) (proclaim '(type (simple-array t (#.(1+ puzzle-typemax) #.(1+ puzzle-size))) puzzle-p)) (defun fit (i j) (declare (type fixnum i j)) (let ((end (fref piecemax i))) (declare (type fixnum end)) (do ((k 0 (the fixnum (1+ k)))) ((> k end) t) (declare (type fixnum k)) (cond ((aref puzzle-p i k) (cond ((aref puzzle (the fixnum (+ j k))) (return nil)))))))) (proclaim '(function place (fixnum fixnum ) fixnum)) (defun jil () 3) (defun place (i j) (declare (type fixnum i j)) (let ((end (fref piecemax i))) (declare (type fixnum end)) (do ((k 0 (the fixnum (1+ k)))) ((> k end)) (declare (type fixnum k)) (cond ((aref puzzle-p i k) (setf (aref puzzle (the fixnum (+ j k))) t)))) (setf (fref piececount (fref puzzle-class i)) (the fixnum (- (the fixnum (fref piececount (fref puzzle-class i))) 1))) (do ((k j (the fixnum (1+ k)))) ((> k puzzle-size) (terpri) (princ "Puzzle filled") 0) (declare (type fixnum k)) (cond ((not (aref puzzle k)) (return k)))))) (defun puzzle-remove (i j) (declare (type fixnum i j)) (let ((end (fref piecemax i))) (declare (type fixnum end)) (do ((k 0 (the fixnum (1+ k)))) ((> k end)) (declare (type fixnum k)) (cond ((aref puzzle-p i k) (setf (aref puzzle (the fixnum (+ j k))) nil)))) (setf (fref piececount (fref puzzle-class i)) (the fixnum (+ (the fixnum (fref piececount (fref puzzle-class i))) 1))))) (defun trial (j) (declare (type fixnum j)) (let ((k 0)) (declare (type fixnum k)) (do ((i 0 (the fixnum (1+ i)))) ((> i puzzle-typemax) (setq **kount** (the fixnum (1+ **kount**))) nil) (declare (type fixnum i)) (cond ((not (= (the fixnum (fref piececount (fref puzzle-class i))) 0)) (cond ((fit i j) (setq k (place i j)) (cond ((or (trial k) (= k 0)) (setq **kount** (the fixnum (+ **kount** 1))) (return t)) (t (puzzle-remove i j)))))))))) (defun definepiece (iclass ii jj kk) (declare (type fixnum ii jj kk)) (let ((index 0)) (declare (type fixnum index)) (do ((i 0 (the fixnum (1+ i)))) ((> i ii)) (declare (type fixnum i)) (do ((j 0 (the fixnum (1+ j)))) ((> j jj)) (declare (type fixnum j)) (do ((k 0 (the fixnum (1+ k)))) ((> k kk)) (declare (type fixnum k)) (setq index (+ i (the fixnum (* puzzle-d (the fixnum (+ j (the fixnum (* puzzle-d k)))))))) (setf (aref puzzle-p **iii** index) t)))) (setf (fref puzzle-class **iii**) iclass) (setf (fref piecemax **iii**) index) (cond ((not (= **iii** puzzle-typemax)) (setq **iii** (the fixnum (+ **iii** 1))))))) (defun puzzle-start () (do ((m 0 (the fixnum (1+ m)))) ((> m puzzle-size)) (declare (type fixnum m)) (setf (aref puzzle m) t)) (do ((i 1 (the fixnum (1+ i)))) ((> i 5)) (declare (type fixnum i)) (do ((j 1 (the fixnum (1+ j)))) ((> j 5)) (declare (type fixnum j)) (do ((k 1 (the fixnum (1+ k)))) ((> k 5)) (declare (type fixnum k)) (setf (aref puzzle (+ i (the fixnum (* puzzle-d (the fixnum (+ j (the fixnum (* puzzle-d k)))))))) nil)))) (do ((i 0 (the fixnum (1+ i)))) ((> i puzzle-typemax)) (declare (type fixnum i)) (do ((m 0 (the fixnum (1+ m)))) ((> m puzzle-size)) (declare (type fixnum m)) (setf (aref puzzle-p i m) nil))) (setq **iii** 0) (definepiece 0 3 1 0) (definepiece 0 1 0 3) (definepiece 0 0 3 1) (definepiece 0 1 3 0) (definepiece 0 3 0 1) (definepiece 0 0 1 3) (definepiece 1 2 0 0) (definepiece 1 0 2 0) (definepiece 1 0 0 2) (definepiece 2 1 1 0) (definepiece 2 1 0 1) (definepiece 2 0 1 1) (definepiece 3 1 1 1) (setf (fref piececount 0) 13.) (setf (fref piececount 1) 3) (setf (fref piececount 2) 1) (setf (fref piececount 3) 1) (let ((m (+ 1 (the fixnum (* puzzle-d (the fixnum (+ 1 puzzle-d)))))) (n 0)(**kount** 0)) (declare (type fixnum m n **kount**)) (cond ((fit 0 m) (setq n (place 0 m))) (t (format t "~%Error."))) (cond ((trial n) (format t "~%Success in ~4D trials." **kount**)) (t (format t "~%Failure."))))) (defun testpuzzle () (time (puzzle-start))) gcl27-2.7.0/bench/puzzle-mod1.cl000066400000000000000000000123271454061450500162350ustar00rootroot00000000000000;; $Header$ ;; $Locker$ (eval-when (compile load eval) (defconstant puzzle-size 511.) (defconstant puzzle-classmax 3.) (defconstant puzzle-typemax 12.)) (defvar **iii** 0) (defvar **kount** 0) (defvar puzzle-d 8.) (proclaim '(type fixnum **iii** **kount** puzzle-d)) (defvar piececount (make-array (1+ puzzle-classmax) :element-type 'fixnum :initial-element 0)) (defvar puzzle-class (make-array (1+ puzzle-typemax) :element-type 'fixnum :initial-element 0)) (defvar piecemax (make-array (1+ puzzle-typemax) :element-type 'fixnum :initial-element 0)) (defvar puzzle (make-array (1+ puzzle-size))) (defvar puzzle-p (make-array (list (1+ puzzle-typemax) (1+ puzzle-size)))) (proclaim '(type (array fixnum) piececount puzzle-class piecemax)) (defmacro fref (a i) `(the fixnum (aref ,a (the fixnum ,i)))) (proclaim '(type simple-vector puzzle)) (proclaim '(type (simple-array t (#.(1+ puzzle-typemax) #.(1+ puzzle-size))) puzzle-p)) (defun fit (i j) (declare (type fixnum i j)) (let ((end (fref piecemax i)) (puzzle-pl puzzle-p)) (declare (type fixnum end) (type (simple-array t (#.(1+ puzzle-typemax) #.(1+ puzzle-size))) puzzle-pl) ) (do ((k 0 (the fixnum (1+ k)))) ((> k end) t) (declare (type fixnum k)) (cond ((aref puzzle-pl i k) (cond ((aref puzzle (the fixnum (+ j k))) (return nil)))))))) (proclaim '(function place (fixnum fixnum ) fixnum)) (defun place (i j) (declare (type fixnum i j)) (let ((end (fref piecemax i))) (declare (type fixnum end)) (do ((k 0 (the fixnum (1+ k)))) ((> k end)) (declare (type fixnum k)) (cond ((aref puzzle-p i k) (setf (aref puzzle (the fixnum (+ j k))) t)))) (setf (fref piececount (fref puzzle-class i)) (the fixnum (- (the fixnum (fref piececount (fref puzzle-class i))) 1))) (do ((k j (the fixnum (1+ k)))) ((> k puzzle-size) (terpri) (princ "Puzzle filled") 0) (declare (type fixnum k)) (cond ((not (aref puzzle k)) (return k)))))) (defun puzzle-remove (i j) (declare (type fixnum i j)) (let ((end (fref piecemax i))) (declare (type fixnum end)) (do ((k 0 (the fixnum (1+ k)))) ((> k end)) (declare (type fixnum k)) (cond ((aref puzzle-p i k) (setf (aref puzzle (the fixnum (+ j k))) nil)))) (setf (fref piececount (fref puzzle-class i)) (the fixnum (+ (the fixnum (fref piececount (fref puzzle-class i))) 1))))) (defun trial (j) (declare (type fixnum j)) (let ((k 0)) (declare (type fixnum k)) (do ((i 0 (the fixnum (1+ i)))) ((> i puzzle-typemax) (setq **kount** (the fixnum (1+ **kount**))) nil) (declare (type fixnum i)) (cond ((not (= (the fixnum (fref piececount (fref puzzle-class i))) 0)) (cond ((fit i j) (setq k (place i j)) (cond ((or (trial k) (= k 0)) (setq **kount** (the fixnum (+ **kount** 1))) (return t)) (t (puzzle-remove i j)))))))))) (defun definepiece (iclass ii jj kk) (declare (type fixnum ii jj kk)) (let ((index 0)) (declare (type fixnum index)) (do ((i 0 (the fixnum (1+ i)))) ((> i ii)) (declare (type fixnum i)) (do ((j 0 (the fixnum (1+ j)))) ((> j jj)) (declare (type fixnum j)) (do ((k 0 (the fixnum (1+ k)))) ((> k kk)) (declare (type fixnum k)) (setq index (+ i (the fixnum (* puzzle-d (the fixnum (+ j (the fixnum (* puzzle-d k)))))))) (setf (aref puzzle-p **iii** index) t)))) (setf (fref puzzle-class **iii**) iclass) (setf (fref piecemax **iii**) index) (cond ((not (= **iii** puzzle-typemax)) (setq **iii** (the fixnum (+ **iii** 1))))))) (defun puzzle-start () (do ((m 0 (the fixnum (1+ m)))) ((> m puzzle-size)) (declare (type fixnum m)) (setf (aref puzzle m) t)) (do ((i 1 (the fixnum (1+ i)))) ((> i 5)) (declare (type fixnum i)) (do ((j 1 (the fixnum (1+ j)))) ((> j 5)) (declare (type fixnum j)) (do ((k 1 (the fixnum (1+ k)))) ((> k 5)) (declare (type fixnum k)) (setf (aref puzzle (+ i (the fixnum (* puzzle-d (the fixnum (+ j (the fixnum (* puzzle-d k)))))))) nil)))) (do ((i 0 (the fixnum (1+ i)))) ((> i puzzle-typemax)) (declare (type fixnum i)) (do ((m 0 (the fixnum (1+ m)))) ((> m puzzle-size)) (declare (type fixnum m)) (setf (aref puzzle-p i m) nil))) (setq **iii** 0) (definepiece 0 3 1 0) (definepiece 0 1 0 3) (definepiece 0 0 3 1) (definepiece 0 1 3 0) (definepiece 0 3 0 1) (definepiece 0 0 1 3) (definepiece 1 2 0 0) (definepiece 1 0 2 0) (definepiece 1 0 0 2) (definepiece 2 1 1 0) (definepiece 2 1 0 1) (definepiece 2 0 1 1) (definepiece 3 1 1 1) (setf (fref piececount 0) 13.) (setf (fref piececount 1) 3) (setf (fref piececount 2) 1) (setf (fref piececount 3) 1) (let ((m (+ 1 (the fixnum (* puzzle-d (the fixnum (+ 1 puzzle-d)))))) (n 0)(**kount** 0)) (declare (type fixnum m n **kount**)) (cond ((fit 0 m) (setq n (place 0 m))) (t (format t "~%Error."))) (cond ((trial n) (format t "~%Success in ~4D trials." **kount**)) (t (format t "~%Failure."))))) (defun testpuzzle () (time (puzzle-start))) gcl27-2.7.0/bench/puzzle-mod2.cl000066400000000000000000000122601454061450500162320ustar00rootroot00000000000000;; $Header$ ;; $Locker$ (eval-when (compile load eval) (defconstant puzzle-size 511.) (defconstant puzzle-classmax 3.) (defconstant puzzle-typemax 12.)) (defvar **iii** 0) (defvar **kount** 0) (defvar puzzle-d 8.) (proclaim '(type fixnum **iii** **kount** puzzle-d)) (defvar piececount (make-array (1+ puzzle-classmax) :element-type 'fixnum :initial-element 0)) (defvar puzzle-class (make-array (1+ puzzle-typemax) :element-type 'fixnum :initial-element 0)) (defvar piecemax (make-array (1+ puzzle-typemax) :element-type 'fixnum :initial-element 0)) (defvar puzzle (make-array (1+ puzzle-size))) (defvar puzzle-p (make-array (list (1+ puzzle-typemax) (1+ puzzle-size)))) (proclaim '(type (array fixnum) piececount puzzle-class piecemax)) (defmacro fref (a i) `(the fixnum (aref ,a (the fixnum ,i)))) (proclaim '(type simple-vector puzzle)) (proclaim '(type (simple-array t (#.(1+ puzzle-typemax) #.(1+ puzzle-size))) puzzle-p)) (defun fit (i j) (declare (type fixnum i j)) (let ((end (aref piecemax i))) (declare (type fixnum end)) (do ((k 0 (the fixnum (1+ k)))) ((> k end) t) (declare (type fixnum k)) (cond ((aref puzzle-p i k) (cond ((aref puzzle (the fixnum (+ j k))) (return nil)))))))) (proclaim '(function place (fixnum fixnum ) fixnum)) (proclaim '(function puzzle-remove (fixnum fixnum) fixnum)) (defun jil () 3) (defun place (i j) (declare (type fixnum i j)) (let ((end (aref piecemax i))) (declare (type fixnum end)) (do ((k 0 (the fixnum (1+ k)))) ((> k end)) (declare (type fixnum k)) (cond ((aref puzzle-p i k) (setf (aref puzzle (the fixnum (+ j k))) t)))) (setf (aref piececount (aref puzzle-class i)) (the fixnum (- (the fixnum (aref piececount (aref puzzle-class i))) 1))) (do ((k j (the fixnum (1+ k)))) ((> k puzzle-size) (terpri) (princ "Puzzle filled") 0) (declare (type fixnum k)) (cond ((not (aref puzzle k)) (return k)))))) (defun puzzle-remove (i j) (declare (type fixnum i j)) (let ((end (aref piecemax i))) (declare (type fixnum end)) (do ((k 0 (the fixnum (1+ k)))) ((> k end)) (declare (type fixnum k)) (cond ((aref puzzle-p i k) (setf (aref puzzle (the fixnum (+ j k))) nil)))) (setf (aref piececount (aref puzzle-class i)) (the fixnum (+ (the fixnum (aref piececount (aref puzzle-class i))) 1))))) (defun trial (j) (declare (type fixnum j)) (let ((k 0)) (declare (type fixnum k)) (do ((i 0 (the fixnum (1+ i)))) ((> i puzzle-typemax) (setq **kount** (the fixnum (1+ **kount**))) nil) (declare (type fixnum i)) (cond ((not (= (the fixnum (aref piececount (aref puzzle-class i))) 0)) (cond ((fit i j) (setq k (place i j)) (cond ((or (trial k) (= k 0)) (setq **kount** (the fixnum (+ **kount** 1))) (return t)) (t (puzzle-remove i j)))))))))) (defun definepiece (iclass ii jj kk) (declare (type fixnum ii jj kk)) (let ((index 0)) (declare (type fixnum index)) (do ((i 0 (the fixnum (1+ i)))) ((> i ii)) (declare (type fixnum i)) (do ((j 0 (the fixnum (1+ j)))) ((> j jj)) (declare (type fixnum j)) (do ((k 0 (the fixnum (1+ k)))) ((> k kk)) (declare (type fixnum k)) (setq index (+ i (the fixnum (* puzzle-d (the fixnum (+ j (the fixnum (* puzzle-d k)))))))) (setf (aref puzzle-p **iii** index) t)))) (setf (aref puzzle-class **iii**) iclass) (setf (aref piecemax **iii**) index) (cond ((not (= **iii** puzzle-typemax)) (setq **iii** (the fixnum (+ **iii** 1))))))) (defun puzzle-start () (do ((m 0 (the fixnum (1+ m)))) ((> m puzzle-size)) (declare (type fixnum m)) (setf (aref puzzle m) t)) (do ((i 1 (the fixnum (1+ i)))) ((> i 5)) (declare (type fixnum i)) (do ((j 1 (the fixnum (1+ j)))) ((> j 5)) (declare (type fixnum j)) (do ((k 1 (the fixnum (1+ k)))) ((> k 5)) (declare (type fixnum k)) (setf (aref puzzle (+ i (the fixnum (* puzzle-d (the fixnum (+ j (the fixnum (* puzzle-d k)))))))) nil)))) (do ((i 0 (the fixnum (1+ i)))) ((> i puzzle-typemax)) (declare (type fixnum i)) (do ((m 0 (the fixnum (1+ m)))) ((> m puzzle-size)) (declare (type fixnum m)) (setf (aref puzzle-p i m) nil))) (setq **iii** 0) (definepiece 0 3 1 0) (definepiece 0 1 0 3) (definepiece 0 0 3 1) (definepiece 0 1 3 0) (definepiece 0 3 0 1) (definepiece 0 0 1 3) (definepiece 1 2 0 0) (definepiece 1 0 2 0) (definepiece 1 0 0 2) (definepiece 2 1 1 0) (definepiece 2 1 0 1) (definepiece 2 0 1 1) (definepiece 3 1 1 1) (setf (aref piececount 0) 13.) (setf (aref piececount 1) 3) (setf (aref piececount 2) 1) (setf (aref piececount 3) 1) (let ((m (+ 1 (the fixnum (* puzzle-d (the fixnum (+ 1 puzzle-d)))))) (n 0)(**kount** 0)) (declare (type fixnum m n **kount**)) (cond ((fit 0 m) (setq n (place 0 m))) (t (format t "~%Error."))) (cond ((trial n) (format t "~%Success in ~4D trials." **kount**)) (t (format t "~%Failure."))))) (defun testpuzzle () (time (puzzle-start))) gcl27-2.7.0/bench/puzzle.cl000066400000000000000000000116011454061450500153710ustar00rootroot00000000000000;; $Header$ ;; $Locker$ (eval-when (compile load eval) (defconstant puzzle-size 511.) (defconstant puzzle-classmax 3.) (defconstant puzzle-typemax 12.)) (defvar **iii** 0) (defvar **kount** 0) (defvar puzzle-d 8.) (proclaim '(type fixnum **iii** **kount** puzzle-d)) (defvar piececount (make-array (1+ puzzle-classmax) :initial-element 0)) (defvar puzzle-class (make-array (1+ puzzle-typemax) :initial-element 0)) (defvar piecemax (make-array (1+ puzzle-typemax) :initial-element 0)) (defvar puzzle (make-array (1+ puzzle-size))) (defvar puzzle-p (make-array (list (1+ puzzle-typemax) (1+ puzzle-size)))) (proclaim '(type simple-vector piececount puzzle-class piecemax puzzle)) (proclaim '(type (simple-array t (#.(1+ puzzle-typemax) #.(1+ puzzle-size))) puzzle-p)) (defun fit (i j) (declare (type fixnum i j)) (let ((end (aref piecemax i))) (declare (type fixnum end)) (do ((k 0 (the fixnum (1+ k)))) ((> k end) t) (declare (type fixnum k)) (cond ((aref puzzle-p i k) (cond ((aref puzzle (the fixnum (+ j k))) (return nil)))))))) (defun place (i j) (declare (type fixnum i j)) (let ((end (aref piecemax i))) (declare (type fixnum end)) (do ((k 0 (the fixnum (1+ k)))) ((> k end)) (declare (type fixnum k)) (cond ((aref puzzle-p i k) (setf (aref puzzle (the fixnum (+ j k))) t)))) (setf (aref piececount (aref puzzle-class i)) (the fixnum (- (the fixnum (aref piececount (aref puzzle-class i))) 1))) (do ((k j (the fixnum (1+ k)))) ((> k puzzle-size) (terpri) (princ "Puzzle filled") 0) (declare (type fixnum k)) (cond ((not (aref puzzle k)) (return k)))))) (defun puzzle-remove (i j) (declare (type fixnum i j)) (let ((end (aref piecemax i))) (declare (type fixnum end)) (do ((k 0 (the fixnum (1+ k)))) ((> k end)) (declare (type fixnum k)) (cond ((aref puzzle-p i k) (setf (aref puzzle (the fixnum (+ j k))) nil)))) (setf (aref piececount (aref puzzle-class i)) (+ (the fixnum (aref piececount (aref puzzle-class i))) 1)))) (defun trial (j) (declare (type fixnum j)) (let ((k 0)) (declare (type fixnum k)) (do ((i 0 (the fixnum (1+ i)))) ((> i puzzle-typemax) (setq **kount** (the fixnum (1+ **kount**))) nil) (declare (type fixnum i)) (cond ((not (= (the fixnum (aref piececount (aref puzzle-class i))) 0)) (cond ((fit i j) (setq k (place i j)) (cond ((or (trial k) (= k 0)) (setq **kount** (the fixnum (+ **kount** 1))) (return t)) (t (puzzle-remove i j)))))))))) (defun definepiece (iclass ii jj kk) (declare (type fixnum ii jj kk)) (let ((index 0)) (declare (type fixnum index)) (do ((i 0 (the fixnum (1+ i)))) ((> i ii)) (declare (type fixnum i)) (do ((j 0 (the fixnum (1+ j)))) ((> j jj)) (declare (type fixnum j)) (do ((k 0 (the fixnum (1+ k)))) ((> k kk)) (declare (type fixnum k)) (setq index (+ i (the fixnum (* puzzle-d (the fixnum (+ j (the fixnum (* puzzle-d k)))))))) (setf (aref puzzle-p **iii** index) t)))) (setf (aref puzzle-class **iii**) iclass) (setf (aref piecemax **iii**) index) (cond ((not (= **iii** puzzle-typemax)) (setq **iii** (the fixnum (+ **iii** 1))))))) (defun puzzle-start () (do ((m 0 (the fixnum (1+ m)))) ((> m puzzle-size)) (declare (type fixnum m)) (setf (aref puzzle m) t)) (do ((i 1 (the fixnum (1+ i)))) ((> i 5)) (declare (type fixnum i)) (do ((j 1 (the fixnum (1+ j)))) ((> j 5)) (declare (type fixnum j)) (do ((k 1 (the fixnum (1+ k)))) ((> k 5)) (declare (type fixnum k)) (setf (aref puzzle (+ i (the fixnum (* puzzle-d (the fixnum (+ j (the fixnum (* puzzle-d k)))))))) nil)))) (do ((i 0 (the fixnum (1+ i)))) ((> i puzzle-typemax)) (declare (type fixnum i)) (do ((m 0 (the fixnum (1+ m)))) ((> m puzzle-size)) (declare (type fixnum m)) (setf (aref puzzle-p i m) nil))) (setq **iii** 0) (definepiece 0 3 1 0) (definepiece 0 1 0 3) (definepiece 0 0 3 1) (definepiece 0 1 3 0) (definepiece 0 3 0 1) (definepiece 0 0 1 3) (definepiece 1 2 0 0) (definepiece 1 0 2 0) (definepiece 1 0 0 2) (definepiece 2 1 1 0) (definepiece 2 1 0 1) (definepiece 2 0 1 1) (definepiece 3 1 1 1) (setf (aref piececount 0) 13.) (setf (aref piececount 1) 3) (setf (aref piececount 2) 1) (setf (aref piececount 3) 1) (let ((m (+ 1 (the fixnum (* puzzle-d (the fixnum (+ 1 puzzle-d)))))) (n 0)(**kount** 0)) (declare (type fixnum m n **kount**)) (cond ((fit 0 m) (setq n (place 0 m))) (t (format t "~%Error."))) (cond ((trial n) (format t "~%Success in ~4D trials." **kount**)) (t (format t "~%Failure."))))) (defun testpuzzle () (time (puzzle-start))) gcl27-2.7.0/bench/stak.cl000066400000000000000000000013301454061450500150000ustar00rootroot00000000000000;; $Header$ ;; $Locker$ ;;; STAK -- The TAKeuchi function with special variables instead of ;;; parameter passing. (defvar stak-x) (defvar stak-y) (defvar stak-z) (proclaim '(fixnum stak-x stak-y stak-z)) (defun stak (stak-x stak-y stak-z) (stak-aux)) (defun stak-aux () (if (not (< stak-y stak-x)) stak-z (let ((stak-x (let ((stak-x (the fixnum (1- stak-x))) (stak-y stak-y) (stak-z stak-z)) (stak-aux))) (stak-y (let ((stak-x (the fixnum (1- stak-y))) (stak-y stak-z) (stak-z stak-x)) (stak-aux))) (stak-z (let ((stak-x (the fixnum (1- stak-z))) (stak-y stak-x) (stak-z stak-y)) (stak-aux)))) (stak-aux)))) (defun teststak () (print (time (stak 18 12 6)))) gcl27-2.7.0/bench/tak-mod.cl000066400000000000000000000011711454061450500153750ustar00rootroot00000000000000;; $Header$ ;; $Locker$ #+excl (eval-when (compile) (setq comp::register-use-threshold 6)) (proclaim '(function tak (fixnum fixnum fixnum) fixnum)) (defun tak (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak (tak (the fixnum (1- x)) y z) (tak (the fixnum (1- y)) z x) (tak (the fixnum (1- z)) x y))))) (defun testtak () (print (time (progn (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6))))) #+excl (eval-when (compile) (setq comp::register-use-threshold 3)) gcl27-2.7.0/bench/tak.cl000066400000000000000000000010771454061450500146250ustar00rootroot00000000000000;; $Header$ ;; $Locker$ #+excl (eval-when (compile) (setq comp::register-use-threshold 6)) (defun tak (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak (tak (the fixnum (1- x)) y z) (tak (the fixnum (1- y)) z x) (tak (the fixnum (1- z)) x y))))) (defun testtak () (print (time (progn (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6))))) #+excl (eval-when (compile) (setq comp::register-use-threshold 3)) gcl27-2.7.0/bench/takl.cl000066400000000000000000000010201454061450500147650ustar00rootroot00000000000000;; $Header$ ;; $Locker$ ;;; TAKL -- The TAKeuchi function using lists as counters. (defun listn (n) (declare (type fixnum n)) (if (not (= 0 n)) (cons n (listn (the fixnum (1- n)))))) (defvar 18l (listn 18)) (defvar 12l (listn 12)) (defvar 6l (listn 6)) (defun mas (x y z) (if (not (shorterp y x)) z (mas (mas (cdr x) y z) (mas (cdr y) z x) (mas (cdr z) x y)))) (defun shorterp (x y) (and y (or (null x) (shorterp (cdr x) (cdr y))))) (defun testtakl () (print (time (mas 18l 12l 6l)))) gcl27-2.7.0/bench/takr.cl000066400000000000000000000472261454061450500150150ustar00rootroot00000000000000;; $Header$ ;; $Locker$ ;;; TAKR -- 100 function (count `em) version of TAK that tries to defeat cache ;;; memory effects. Results should be the same as for TAK on stack machines. ;;; Distribution of calls is not completely flat. (defun tak0 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak1 (tak37 (the fixnum (1- x)) y z) (tak11 (the fixnum (1- y)) z x) (tak17 (the fixnum (1- z)) x y))))) (defun tak1 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak2 (tak74 (the fixnum (1- x)) y z) (tak22 (the fixnum (1- y)) z x) (tak34 (the fixnum (1- z)) x y))))) (defun tak2 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak3 (tak11 (the fixnum (1- x)) y z) (tak33 (the fixnum (1- y)) z x) (tak51 (the fixnum (1- z)) x y))))) (defun tak3 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak4 (tak48 (the fixnum (1- x)) y z) (tak44 (the fixnum (1- y)) z x) (tak68 (the fixnum (1- z)) x y))))) (defun tak4 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak5 (tak85 (the fixnum (1- x)) y z) (tak55 (the fixnum (1- y)) z x) (tak85 (the fixnum (1- z)) x y))))) (defun tak5 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak6 (tak22 (the fixnum (1- x)) y z) (tak66 (the fixnum (1- y)) z x) (tak2 (the fixnum (1- z)) x y))))) (defun tak6 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak7 (tak59 (the fixnum (1- x)) y z) (tak77 (the fixnum (1- y)) z x) (tak19 (the fixnum (1- z)) x y))))) (defun tak7 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak8 (tak96 (the fixnum (1- x)) y z) (tak88 (the fixnum (1- y)) z x) (tak36 (the fixnum (1- z)) x y))))) (defun tak8 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak9 (tak33 (the fixnum (1- x)) y z) (tak99 (the fixnum (1- y)) z x) (tak53 (the fixnum (1- z)) x y))))) (defun tak9 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak10 (tak70 (the fixnum (1- x)) y z) (tak10 (the fixnum (1- y)) z x) (tak70 (the fixnum (1- z)) x y))))) (defun tak10 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak11 (tak7 (the fixnum (1- x)) y z) (tak21 (the fixnum (1- y)) z x) (tak87 (the fixnum (1- z)) x y))))) (defun tak11 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak12 (tak44 (the fixnum (1- x)) y z) (tak32 (the fixnum (1- y)) z x) (tak4 (the fixnum (1- z)) x y))))) (defun tak12 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak13 (tak81 (the fixnum (1- x)) y z) (tak43 (the fixnum (1- y)) z x) (tak21 (the fixnum (1- z)) x y))))) (defun tak13 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak14 (tak18 (the fixnum (1- x)) y z) (tak54 (the fixnum (1- y)) z x) (tak38 (the fixnum (1- z)) x y))))) (defun tak14 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak15 (tak55 (the fixnum (1- x)) y z) (tak65 (the fixnum (1- y)) z x) (tak55 (the fixnum (1- z)) x y))))) (defun tak15 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak16 (tak92 (the fixnum (1- x)) y z) (tak76 (the fixnum (1- y)) z x) (tak72 (the fixnum (1- z)) x y))))) (defun tak16 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak17 (tak29 (the fixnum (1- x)) y z) (tak87 (the fixnum (1- y)) z x) (tak89 (the fixnum (1- z)) x y))))) (defun tak17 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak18 (tak66 (the fixnum (1- x)) y z) (tak98 (the fixnum (1- y)) z x) (tak6 (the fixnum (1- z)) x y))))) (defun tak18 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak19 (tak3 (the fixnum (1- x)) y z) (tak9 (the fixnum (1- y)) z x) (tak23 (the fixnum (1- z)) x y))))) (defun tak19 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak20 (tak40 (the fixnum (1- x)) y z) (tak20 (the fixnum (1- y)) z x) (tak40 (the fixnum (1- z)) x y))))) (defun tak20 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak21 (tak77 (the fixnum (1- x)) y z) (tak31 (the fixnum (1- y)) z x) (tak57 (the fixnum (1- z)) x y))))) (defun tak21 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak22 (tak14 (the fixnum (1- x)) y z) (tak42 (the fixnum (1- y)) z x) (tak74 (the fixnum (1- z)) x y))))) (defun tak22 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak23 (tak51 (the fixnum (1- x)) y z) (tak53 (the fixnum (1- y)) z x) (tak91 (the fixnum (1- z)) x y))))) (defun tak23 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak24 (tak88 (the fixnum (1- x)) y z) (tak64 (the fixnum (1- y)) z x) (tak8 (the fixnum (1- z)) x y))))) (defun tak24 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak25 (tak25 (the fixnum (1- x)) y z) (tak75 (the fixnum (1- y)) z x) (tak25 (the fixnum (1- z)) x y))))) (defun tak25 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak26 (tak62 (the fixnum (1- x)) y z) (tak86 (the fixnum (1- y)) z x) (tak42 (the fixnum (1- z)) x y))))) (defun tak26 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak27 (tak99 (the fixnum (1- x)) y z) (tak97 (the fixnum (1- y)) z x) (tak59 (the fixnum (1- z)) x y))))) (defun tak27 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak28 (tak36 (the fixnum (1- x)) y z) (tak8 (the fixnum (1- y)) z x) (tak76 (the fixnum (1- z)) x y))))) (defun tak28 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak29 (tak73 (the fixnum (1- x)) y z) (tak19 (the fixnum (1- y)) z x) (tak93 (the fixnum (1- z)) x y))))) (defun tak29 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak30 (tak10 (the fixnum (1- x)) y z) (tak30 (the fixnum (1- y)) z x) (tak10 (the fixnum (1- z)) x y))))) (defun tak30 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak31 (tak47 (the fixnum (1- x)) y z) (tak41 (the fixnum (1- y)) z x) (tak27 (the fixnum (1- z)) x y))))) (defun tak31 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak32 (tak84 (the fixnum (1- x)) y z) (tak52 (the fixnum (1- y)) z x) (tak44 (the fixnum (1- z)) x y))))) (defun tak32 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak33 (tak21 (the fixnum (1- x)) y z) (tak63 (the fixnum (1- y)) z x) (tak61 (the fixnum (1- z)) x y))))) (defun tak33 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak34 (tak58 (the fixnum (1- x)) y z) (tak74 (the fixnum (1- y)) z x) (tak78 (the fixnum (1- z)) x y))))) (defun tak34 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak35 (tak95 (the fixnum (1- x)) y z) (tak85 (the fixnum (1- y)) z x) (tak95 (the fixnum (1- z)) x y))))) (defun tak35 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak36 (tak32 (the fixnum (1- x)) y z) (tak96 (the fixnum (1- y)) z x) (tak12 (the fixnum (1- z)) x y))))) (defun tak36 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak37 (tak69 (the fixnum (1- x)) y z) (tak7 (the fixnum (1- y)) z x) (tak29 (the fixnum (1- z)) x y))))) (defun tak37 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak38 (tak6 (the fixnum (1- x)) y z) (tak18 (the fixnum (1- y)) z x) (tak46 (the fixnum (1- z)) x y))))) (defun tak38 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak39 (tak43 (the fixnum (1- x)) y z) (tak29 (the fixnum (1- y)) z x) (tak63 (the fixnum (1- z)) x y))))) (defun tak39 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak40 (tak80 (the fixnum (1- x)) y z) (tak40 (the fixnum (1- y)) z x) (tak80 (the fixnum (1- z)) x y))))) (defun tak40 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak41 (tak17 (the fixnum (1- x)) y z) (tak51 (the fixnum (1- y)) z x) (tak97 (the fixnum (1- z)) x y))))) (defun tak41 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak42 (tak54 (the fixnum (1- x)) y z) (tak62 (the fixnum (1- y)) z x) (tak14 (the fixnum (1- z)) x y))))) (defun tak42 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak43 (tak91 (the fixnum (1- x)) y z) (tak73 (the fixnum (1- y)) z x) (tak31 (the fixnum (1- z)) x y))))) (defun tak43 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak44 (tak28 (the fixnum (1- x)) y z) (tak84 (the fixnum (1- y)) z x) (tak48 (the fixnum (1- z)) x y))))) (defun tak44 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak45 (tak65 (the fixnum (1- x)) y z) (tak95 (the fixnum (1- y)) z x) (tak65 (the fixnum (1- z)) x y))))) (defun tak45 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak46 (tak2 (the fixnum (1- x)) y z) (tak6 (the fixnum (1- y)) z x) (tak82 (the fixnum (1- z)) x y))))) (defun tak46 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak47 (tak39 (the fixnum (1- x)) y z) (tak17 (the fixnum (1- y)) z x) (tak99 (the fixnum (1- z)) x y))))) (defun tak47 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak48 (tak76 (the fixnum (1- x)) y z) (tak28 (the fixnum (1- y)) z x) (tak16 (the fixnum (1- z)) x y))))) (defun tak48 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak49 (tak13 (the fixnum (1- x)) y z) (tak39 (the fixnum (1- y)) z x) (tak33 (the fixnum (1- z)) x y))))) (defun tak49 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak50 (tak50 (the fixnum (1- x)) y z) (tak50 (the fixnum (1- y)) z x) (tak50 (the fixnum (1- z)) x y))))) (defun tak50 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak51 (tak87 (the fixnum (1- x)) y z) (tak61 (the fixnum (1- y)) z x) (tak67 (the fixnum (1- z)) x y))))) (defun tak51 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak52 (tak24 (the fixnum (1- x)) y z) (tak72 (the fixnum (1- y)) z x) (tak84 (the fixnum (1- z)) x y))))) (defun tak52 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak53 (tak61 (the fixnum (1- x)) y z) (tak83 (the fixnum (1- y)) z x) (tak1 (the fixnum (1- z)) x y))))) (defun tak53 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak54 (tak98 (the fixnum (1- x)) y z) (tak94 (the fixnum (1- y)) z x) (tak18 (the fixnum (1- z)) x y))))) (defun tak54 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak55 (tak35 (the fixnum (1- x)) y z) (tak5 (the fixnum (1- y)) z x) (tak35 (the fixnum (1- z)) x y))))) (defun tak55 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak56 (tak72 (the fixnum (1- x)) y z) (tak16 (the fixnum (1- y)) z x) (tak52 (the fixnum (1- z)) x y))))) (defun tak56 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak57 (tak9 (the fixnum (1- x)) y z) (tak27 (the fixnum (1- y)) z x) (tak69 (the fixnum (1- z)) x y))))) (defun tak57 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak58 (tak46 (the fixnum (1- x)) y z) (tak38 (the fixnum (1- y)) z x) (tak86 (the fixnum (1- z)) x y))))) (defun tak58 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak59 (tak83 (the fixnum (1- x)) y z) (tak49 (the fixnum (1- y)) z x) (tak3 (the fixnum (1- z)) x y))))) (defun tak59 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak60 (tak20 (the fixnum (1- x)) y z) (tak60 (the fixnum (1- y)) z x) (tak20 (the fixnum (1- z)) x y))))) (defun tak60 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak61 (tak57 (the fixnum (1- x)) y z) (tak71 (the fixnum (1- y)) z x) (tak37 (the fixnum (1- z)) x y))))) (defun tak61 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak62 (tak94 (the fixnum (1- x)) y z) (tak82 (the fixnum (1- y)) z x) (tak54 (the fixnum (1- z)) x y))))) (defun tak62 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak63 (tak31 (the fixnum (1- x)) y z) (tak93 (the fixnum (1- y)) z x) (tak71 (the fixnum (1- z)) x y))))) (defun tak63 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak64 (tak68 (the fixnum (1- x)) y z) (tak4 (the fixnum (1- y)) z x) (tak88 (the fixnum (1- z)) x y))))) (defun tak64 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak65 (tak5 (the fixnum (1- x)) y z) (tak15 (the fixnum (1- y)) z x) (tak5 (the fixnum (1- z)) x y))))) (defun tak65 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak66 (tak42 (the fixnum (1- x)) y z) (tak26 (the fixnum (1- y)) z x) (tak22 (the fixnum (1- z)) x y))))) (defun tak66 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak67 (tak79 (the fixnum (1- x)) y z) (tak37 (the fixnum (1- y)) z x) (tak39 (the fixnum (1- z)) x y))))) (defun tak67 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak68 (tak16 (the fixnum (1- x)) y z) (tak48 (the fixnum (1- y)) z x) (tak56 (the fixnum (1- z)) x y))))) (defun tak68 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak69 (tak53 (the fixnum (1- x)) y z) (tak59 (the fixnum (1- y)) z x) (tak73 (the fixnum (1- z)) x y))))) (defun tak69 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak70 (tak90 (the fixnum (1- x)) y z) (tak70 (the fixnum (1- y)) z x) (tak90 (the fixnum (1- z)) x y))))) (defun tak70 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak71 (tak27 (the fixnum (1- x)) y z) (tak81 (the fixnum (1- y)) z x) (tak7 (the fixnum (1- z)) x y))))) (defun tak71 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak72 (tak64 (the fixnum (1- x)) y z) (tak92 (the fixnum (1- y)) z x) (tak24 (the fixnum (1- z)) x y))))) (defun tak72 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak73 (tak1 (the fixnum (1- x)) y z) (tak3 (the fixnum (1- y)) z x) (tak41 (the fixnum (1- z)) x y))))) (defun tak73 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak74 (tak38 (the fixnum (1- x)) y z) (tak14 (the fixnum (1- y)) z x) (tak58 (the fixnum (1- z)) x y))))) (defun tak74 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak75 (tak75 (the fixnum (1- x)) y z) (tak25 (the fixnum (1- y)) z x) (tak75 (the fixnum (1- z)) x y))))) (defun tak75 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak76 (tak12 (the fixnum (1- x)) y z) (tak36 (the fixnum (1- y)) z x) (tak92 (the fixnum (1- z)) x y))))) (defun tak76 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak77 (tak49 (the fixnum (1- x)) y z) (tak47 (the fixnum (1- y)) z x) (tak9 (the fixnum (1- z)) x y))))) (defun tak77 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak78 (tak86 (the fixnum (1- x)) y z) (tak58 (the fixnum (1- y)) z x) (tak26 (the fixnum (1- z)) x y))))) (defun tak78 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak79 (tak23 (the fixnum (1- x)) y z) (tak69 (the fixnum (1- y)) z x) (tak43 (the fixnum (1- z)) x y))))) (defun tak79 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak80 (tak60 (the fixnum (1- x)) y z) (tak80 (the fixnum (1- y)) z x) (tak60 (the fixnum (1- z)) x y))))) (defun tak80 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak81 (tak97 (the fixnum (1- x)) y z) (tak91 (the fixnum (1- y)) z x) (tak77 (the fixnum (1- z)) x y))))) (defun tak81 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak82 (tak34 (the fixnum (1- x)) y z) (tak2 (the fixnum (1- y)) z x) (tak94 (the fixnum (1- z)) x y))))) (defun tak82 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak83 (tak71 (the fixnum (1- x)) y z) (tak13 (the fixnum (1- y)) z x) (tak11 (the fixnum (1- z)) x y))))) (defun tak83 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak84 (tak8 (the fixnum (1- x)) y z) (tak24 (the fixnum (1- y)) z x) (tak28 (the fixnum (1- z)) x y))))) (defun tak84 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak85 (tak45 (the fixnum (1- x)) y z) (tak35 (the fixnum (1- y)) z x) (tak45 (the fixnum (1- z)) x y))))) (defun tak85 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak86 (tak82 (the fixnum (1- x)) y z) (tak46 (the fixnum (1- y)) z x) (tak62 (the fixnum (1- z)) x y))))) (defun tak86 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak87 (tak19 (the fixnum (1- x)) y z) (tak57 (the fixnum (1- y)) z x) (tak79 (the fixnum (1- z)) x y))))) (defun tak87 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak88 (tak56 (the fixnum (1- x)) y z) (tak68 (the fixnum (1- y)) z x) (tak96 (the fixnum (1- z)) x y))))) (defun tak88 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak89 (tak93 (the fixnum (1- x)) y z) (tak79 (the fixnum (1- y)) z x) (tak13 (the fixnum (1- z)) x y))))) (defun tak89 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak90 (tak30 (the fixnum (1- x)) y z) (tak90 (the fixnum (1- y)) z x) (tak30 (the fixnum (1- z)) x y))))) (defun tak90 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak91 (tak67 (the fixnum (1- x)) y z) (tak1 (the fixnum (1- y)) z x) (tak47 (the fixnum (1- z)) x y))))) (defun tak91 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak92 (tak4 (the fixnum (1- x)) y z) (tak12 (the fixnum (1- y)) z x) (tak64 (the fixnum (1- z)) x y))))) (defun tak92 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak93 (tak41 (the fixnum (1- x)) y z) (tak23 (the fixnum (1- y)) z x) (tak81 (the fixnum (1- z)) x y))))) (defun tak93 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak94 (tak78 (the fixnum (1- x)) y z) (tak34 (the fixnum (1- y)) z x) (tak98 (the fixnum (1- z)) x y))))) (defun tak94 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak95 (tak15 (the fixnum (1- x)) y z) (tak45 (the fixnum (1- y)) z x) (tak15 (the fixnum (1- z)) x y))))) (defun tak95 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak96 (tak52 (the fixnum (1- x)) y z) (tak56 (the fixnum (1- y)) z x) (tak32 (the fixnum (1- z)) x y))))) (defun tak96 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak97 (tak89 (the fixnum (1- x)) y z) (tak67 (the fixnum (1- y)) z x) (tak49 (the fixnum (1- z)) x y))))) (defun tak97 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak98 (tak26 (the fixnum (1- x)) y z) (tak78 (the fixnum (1- y)) z x) (tak66 (the fixnum (1- z)) x y))))) (defun tak98 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak99 (tak63 (the fixnum (1- x)) y z) (tak89 (the fixnum (1- y)) z x) (tak83 (the fixnum (1- z)) x y))))) (defun tak99 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak0 (tak0 (the fixnum (1- x)) y z) (tak0 (the fixnum (1- y)) z x) (tak0 (the fixnum (1- z)) x y))))) (defun testtakr () (print (time (tak0 18 12 6)))) gcl27-2.7.0/bench/test-help.lsp000066400000000000000000000016031454061450500161460ustar00rootroot00000000000000(defvar *repeats* '(("destru" 4)("destru-mod" 4)("fprint" 4)("fread" 4) ("stak" 4)("takr" 4)("tprint" 4))) (defun do-test (file output &optional (n 1 given) &aux tem) (if (and (not given) (setq tem (assoc file *repeats* :test 'equalp))) (setq n (second tem))) (or (eql n 1) (format t "..Using ~a repeats" n)) (load file) (let ((pos (position #\- file)) (orig file)) (if pos (setq file (subseq file 0 pos))) (let ((command (intern (string-upcase (format nil "TEST~a" file))))) (let ((start (get-internal-run-time))) (dotimes (i n) (funcall command)) (setq start (- (get-internal-run-time) start)) (setq start (/ (float start) n)) (with-open-file (st output :direction :output :if-exists :append) (format st "~%~:@(~a~)~,12t~,3f" orig (/ start (float internal-time-units-per-second))) (force-output st) ))))) gcl27-2.7.0/bench/times000066400000000000000000000207661454061450500146000ustar00rootroot00000000000000 -------------- SESSION ------------------ For lisp Common Lisp Wed Jun 22 19:49:51 UTC 2005 -------------- SESSION ------------------ For lisp Common Lisp Wed Jun 22 19:51:27 UTC 2005 BOYER 0.032 BROWSE 0.079 CTAK 0.002 DDERIV 0.029 DERIV 0.019 DESTRU-MOD 0.005 DESTRU 0.005 DIV2 0.020 FFT-MOD 0.004 FFT 0.003 FPRINT 0.006 FREAD 0.003 FRPOLY 0.065 PUZZLE-MOD 0.074 PUZZLE 0.099 STAK 0.004 TAK-MOD 0.010 TAK 0.013 TAKL 0.003 TAKR 0.002 TPRINT 0.005 TRAVERSE 0.085 TRIANG-MOD 1.247 TRIANG 0.226 -------------- SESSION ------------------ For ../bin/gcl Common Lisp Wed Jun 22 20:16:03 UTC 2005 BOYER 0.015 CTAK 0.007 DDERIV 0.008 DERIV 0.007 FFT-MOD 0.001 -------------- SESSION ------------------ For ../bin/gcl Common Lisp Wed Jun 22 22:02:04 UTC 2005 BOYER 0.014 BROWSE 0.039 CTAK 0.007 DDERIV 0.008 DERIV 0.007 DESTRU-MOD 0.003 DESTRU 0.002 DIV2 0.007 FFT-MOD 0.001 FFT 0.048 FPRINT 0.003 FREAD 0.002 FRPOLY 0.050 PUZZLE 0.007 STAK 0.002 TAK-MOD 0.008 TAK 0.007 TAKL 0.002 TAKR 0.001 TPRINT 0.002 TRAVERSE 0.046 TRIANG-MOD 0.183 TRIANG 0.109 -------------- SESSION ------------------ For ../bin/gcl Common Lisp Thu Jun 23 17:44:22 UTC 2005 BOYER 0.014 BROWSE 0.037 CTAK 0.007 DDERIV 0.009 DERIV 0.008 DESTRU-MOD 0.003 DESTRU 0.002 DIV2 0.008 FFT-MOD 0.001 FFT 0.048 FPRINT 0.003 FREAD 0.002 FRPOLY 0.051 PUZZLE-MOD 0.005 PUZZLE 0.008 STAK 0.002 TAK-MOD 0.006 TAK 0.006 TAKL 0.002 TAKR 0.001 TPRINT 0.002 TRAVERSE 0.048 TRIANG-MOD 0.182 TRIANG 0.109 -------------- SESSION ------------------ For /usr/bin/gcl Common Lisp Thu Jun 23 17:52:35 UTC 2005 BOYER 0.013 BROWSE 0.030 CTAK 0.007 DDERIV 0.009 DERIV 0.008 DESTRU-MOD 0.003 DESTRU 0.005 DIV2 0.008 FFT-MOD 0.001 FFT 0.001 FPRINT 0.002 FREAD 0.002 FRPOLY 0.047 PUZZLE-MOD 0.005 PUZZLE 0.005 STAK 0.003 TAK-MOD 0.005 TAK 0.007 TAKL 0.002 TAKR 0.001 TPRINT 0.002 TRAVERSE 0.083 TRIANG-MOD 0.102 TRIANG 0.108 -------------- SESSION ------------------ For ../bin/gcl Common Lisp Thu Jun 23 19:23:58 UTC 2005 BOYER 0.014 BROWSE 0.039 CTAK 0.007 DDERIV 0.009 DERIV 0.007 DESTRU-MOD 0.002 DESTRU 0.002 DIV2 0.008 FFT-MOD 0.001 FFT 0.001 FPRINT 0.002 FREAD 0.002 FRPOLY 0.048 PUZZLE-MOD 0.005 PUZZLE 0.008 STAK 0.002 TAK-MOD 0.006 TAK 0.007 TAKL 0.002 TAKR 0.001 TPRINT 0.002 TRAVERSE 0.051 TRIANG-MOD 0.101 TRIANG 0.106 -------------- SESSION ------------------ For ../bin/gcl Common Lisp Thu Jun 23 19:59:23 UTC 2005 BOYER 5.650 BROWSE 13.880 CTAK 2.660 DDERIV 3.160 DERIV 2.740 DESTRU-MOD 3.780 DESTRU 3.600 DIV2 3.000 FFT-MOD 0.450 FFT 0.490 FPRINT 4.200 FREAD 2.480 FRPOLY 20.250 PUZZLE-MOD 2.060 PUZZLE 2.140 STAK 3.760 TAK-MOD 2.790 TAK 3.420 TAKL 0.760 TAKR 1.640 TPRINT 2.740 TRAVERSE 19.190 TRIANG-MOD 40.240 TRIANG 42.270 -------------- SESSION ------------------ For /usr/bin/gcl Common Lisp Thu Jun 23 20:03:52 UTC 2005 BOYER 5.050 BROWSE 11.950 CTAK 2.700 DDERIV 3.600 DERIV 3.090 DESTRU-MOD 3.910 DESTRU 7.610 DIV2 3.340 FFT-MOD 0.480 FFT 0.560 FPRINT 3.710 FREAD 2.450 FRPOLY 18.880 PUZZLE-MOD 2.920 PUZZLE 1.920 STAK 4.440 TAK-MOD 2.500 TAK 2.960 TAKL 0.800 TAKR 1.380 TPRINT 2.540 TRAVERSE 33.120 TRIANG-MOD 40.720 TRIANG 43.590 -------------- SESSION ------------------ For lisp Common Lisp Thu Jun 23 20:11:55 UTC 2005 BOYER 12.040 BROWSE 31.380 CTAK 0.790 DDERIV 10.880 DERIV 6.560 DESTRU-MOD 7.880 DESTRU 7.870 DIV2 7.720 FFT-MOD 1.440 FFT 1.070 FPRINT 8.650 FREAD 4.400 FRPOLY 25.510 PUZZLE-MOD 27.950 PUZZLE 26.460 STAK 6.700 TAK-MOD 4.140 TAK 3.920 TAKL 1.320 TAKR 2.590 TPRINT 8.090 TRAVERSE 32.700 TRIANG-MOD 483.680 TRIANG 87.320 -------------- SESSION ------------------ For clisp Common Lisp Thu Jun 23 20:31:05 UTC 2005 -------------- SESSION ------------------ For clisp Common Lisp Thu Jun 23 20:37:26 UTC 2005 -------------- SESSION ------------------ For clisp Common Lisp Thu Jun 23 20:47:43 UTC 2005 BOYER 48.430 BROWSE 562.080 CTAK 71.360 DDERIV 72.950 DERIV 66.670 DESTRU-MOD 968.090 DESTRU 1062.870 -------------- SESSION ------------------ For ../bin/gcl Common Lisp Sat Jun 25 19:38:51 UTC 2005 BOYER 6.860 BROWSE 15.600 CTAK 3.220 DDERIV 4.490 DERIV 3.700 DESTRU-MOD 4.750 DESTRU 4.490 DIV2 3.850 FFT-MOD 0.470 FFT 0.540 FPRINT 4.550 FREAD 3.120 FRPOLY 23.960 PUZZLE-MOD 2.110 PUZZLE 2.060 STAK 6.200 TAK-MOD 2.500 TAK 2.600 TAKL 0.820 TAKR 1.610 TPRINT 3.550 TRAVERSE 22.460 TRIANG 45.540 -------------- SESSION ------------------ For ../bin/gcl Common Lisp Sat Jun 25 20:25:29 UTC 2005 BOYER 5.640 BROWSE 13.780 CTAK 3.110 DDERIV 3.660 DERIV 2.840 DESTRU-MOD 3.690 DESTRU 3.760 DIV2 3.000 FFT-MOD 0.450 FFT 0.480 FPRINT 4.090 FREAD 2.460 FRPOLY 19.270 PUZZLE-MOD 1.870 PUZZLE 2.080 STAK 3.460 TAK-MOD 2.320 TAK 2.450 TAKL 0.800 TAKR 1.590 TPRINT 3.050 TRAVERSE 19.160 TRIANG 42.660 -------------- SESSION ------------------ For ../bin/gcl Common Lisp Sat Jun 25 22:19:15 UTC 2005 BOYER 5.420 BROWSE 18.360 CTAK 2.570 DDERIV 3.270 DERIV 2.790 DESTRU-MOD 3.590 DESTRU 3.640 DIV2 2.950 FFT-MOD 0.450 FFT 0.480 FPRINT 3.870 FREAD 2.450 FRPOLY 19.720 PUZZLE-MOD 1.920 PUZZLE 1.850 STAK 3.460 TAK-MOD 2.360 TAK 2.490 TAKL 0.770 TAKR 1.600 TPRINT 2.710 TRAVERSE 19.550 TRIANG-MOD 57.220 TRIANG 42.530 -------------- SESSION ------------------ For ../bin/gcl Common Lisp Sat Jun 25 22:35:49 UTC 2005 BOYER 5.530 BROWSE 13.840 CTAK 2.540 DDERIV 3.300 DERIV 2.810 DESTRU-MOD 3.600 DESTRU 3.740 DIV2 3.090 FFT-MOD 0.450 FFT 0.480 FPRINT 4.200 FREAD 2.720 FRPOLY 19.290 PUZZLE-MOD 1.820 PUZZLE 2.030 STAK 3.520 TAK-MOD 2.330 TAK 2.500 TAKL 0.770 TAKR 1.560 TPRINT 2.870 TRAVERSE 18.910 TRIANG-MOD 41.060 TRIANG 42.630 -------------- SESSION ------------------ For ../bin/gcl Common Lisp Mon Jun 27 17:52:57 UTC 2005 BOYER 5.730 BROWSE 15.680 CTAK 2.600 DDERIV 3.180 DERIV 2.750 DESTRU-MOD 3.630 DESTRU 3.800 DIV2 2.990 FFT-MOD 0.450 FFT 0.480 FPRINT 4.050 FREAD 2.440 FRPOLY 19.120 PUZZLE-MOD 1.910 PUZZLE 2.030 STAK 4.480 TAK-MOD 2.220 TAK 2.950 TAKL 0.770 TAKR 1.560 TPRINT 2.770 TRAVERSE 19.190 TRIANG-MOD 40.640 TRIANG 47.290 -------------- SESSION ------------------ For ../bin/gcl Common Lisp Mon Jun 27 18:06:42 UTC 2005 BOYER 5.630 BROWSE 13.520 CTAK 2.540 DDERIV 3.200 DERIV 2.750 DESTRU-MOD 3.560 DESTRU 3.590 DIV2 3.010 FFT-MOD 0.450 FFT 0.480 FPRINT 3.960 FREAD 2.480 FRPOLY 18.890 PUZZLE-MOD 1.890 PUZZLE 1.990 STAK 3.490 TAK-MOD 2.530 TAK 2.520 TAKL 0.820 TAKR 1.590 TPRINT 2.760 TRAVERSE 19.520 TRIANG-MOD 40.890 TRIANG 42.540gcl27-2.7.0/bench/tprint.cl000066400000000000000000000014611454061450500153630ustar00rootroot00000000000000;; $Header$ ;; $Locker$ ;;; TPRINT -- Benchmark to print and read to the terminal. (defvar test-atoms '(abc1 cde2 efg3 ghi4 ijk5 klm6 mno7 opq8 qrs9 stu0 uvw1 wxy2 xyz3 123a 234b 345c 456d 567d 678e 789f 890g)) (defun tprint-init (m n atoms) (let ((atoms (subst () () atoms))) (do ((a atoms (cdr a))) ((null (cdr a)) (rplacd a atoms))) (tprint-init-aux m n atoms))) (defun tprint-init-aux (m n atoms) (declare (fixnum m n)) (cond ((= m 0) (pop atoms)) (t (do ((i n (the fixnum (- i 2))) (a ())) ((< i 1) a) (push (pop atoms) a) (push (tprint-init-aux (the fixnum (1- m)) n atoms) a))))) (defvar test-pattern (tprint-init 6. 6. test-atoms)) (defun standard-tprint-test () (print test-pattern)) (defun testtprint () (print (time (print test-pattern)))) gcl27-2.7.0/bench/traverse.cl000066400000000000000000000076501454061450500157040ustar00rootroot00000000000000;; $Header$ ;; $Locker$ ;;; TRAVERSE -- Benchmark which creates and traverses a tree structure. (eval-when (eval compile load) (defstruct node (parents ()) (sons ()) (sn (snb)) (entry1 ()) (entry2 ()) (entry3 ()) (entry4 ()) (entry5 ()) (entry6 ()) (mark ())) ) (defvar traverse-sn 0) (defvar traverse-rand 21.) (defvar traverse-count 0) (proclaim `(type fixnum traverse-sn traverse-rand traverse-count)) (defvar traverse-marker nil) (defvar traverse-root) (setq traverse-sn 0 traverse-rand 21 traverse-count 0 traverse-marker nil) (defun snb () (setq traverse-sn (the fixnum (1+ traverse-sn)))) (defun traverse-seed () (setq traverse-rand 21.)) (defun traverse-random () (setq traverse-rand (the fixnum (rem (the fixnum (* traverse-rand 17)) 251)))) (defun traverse-remove (n q) (declare (type fixnum n)) (cond ((eq (cdr (car q)) (car q)) (prog2 () (caar q) (rplaca q ()))) ((= n 0) (prog2 () (caar q) (do ((p (car q) (cdr p))) ((eq (cdr p) (car q)) (rplaca q (rplacd p (cdr (car q)))))))) (t (do ((n n (the fixnum (1- n))) (q (car q) (cdr q)) (p (cdr (car q)) (cdr p))) ((= n 0) (prog2 () (car q) (rplacd q p))) (declare (type fixnum n)))))) (defun traverse-select (n q) (declare (type fixnum n)) (do ((n n (the fixnum (1- n))) (q (car q) (cdr q))) ((= n 0) (car q)) (declare (type fixnum n)))) (defun traverse-add (a q) (cond ((null q) `(,(let ((x `(,a))) (rplacd x x) x))) ((null (car q)) (let ((x `(,a))) (rplacd x x) (rplaca q x))) (t (rplaca q (rplacd (car q) `(,a .,(cdr (car q)))))))) (defun traverse-create-structure (n) (declare (type fixnum n)) (let ((a `(,(make-node)))) (do ((m (the fixnum (1- n)) (the fixnum (1- m))) (p a)) ((= m 0) (setq a `(,(rplacd p a))) (do ((unused a) (used (traverse-add (traverse-remove 0 a) ())) (x) (y)) ((null (car unused)) (find-root (traverse-select 0 used) n)) (setq x (traverse-remove (the fixnum (rem (the fixnum (traverse-random)) n)) unused)) (setq y (traverse-select (the fixnum (rem (the fixnum (traverse-random)) n)) used)) (traverse-add x used) (setf (node-sons y) `(,x .,(node-sons y))) (setf (node-parents x) `(,y .,(node-parents x))) )) (declare (type fixnum m)) (push (make-node) a)))) (defun find-root (node n) (declare (type fixnum n)) (do ((n n (the fixnum (1- n)))) ((= n 0) node) (declare (type fixnum n)) (cond ((null (node-parents node)) (return node)) (t (setq node (car (node-parents node))))))) (defun travers (node mark) (cond ((eq (node-mark node) mark) ()) (t (setf (node-mark node) mark) (setq traverse-count (the fixnum (1+ traverse-count))) (setf (node-entry1 node) (not (node-entry1 node))) (setf (node-entry2 node) (not (node-entry2 node))) (setf (node-entry3 node) (not (node-entry3 node))) (setf (node-entry4 node) (not (node-entry4 node))) (setf (node-entry5 node) (not (node-entry5 node))) (setf (node-entry6 node) (not (node-entry6 node))) (do ((sons (node-sons node) (cdr sons))) ((null sons) ()) (travers (car sons) mark))))) (defun traverse (traverse-root) (let ((traverse-count 0)) (declare (type fixnum traverse-count)) (travers traverse-root (setq traverse-marker (not traverse-marker))) traverse-count)) (defun init-traverse() (setq traverse-root (traverse-create-structure 100.)) nil) (defun run-traverse () (do ((i 50 (the fixnum (1- (the fixnum i))))) ((= (the fixnum i) 0)) (declare (type fixnum i)) (traverse traverse-root) (traverse traverse-root) (traverse traverse-root) (traverse traverse-root) (traverse traverse-root))) (defun testtraverse () (testtraverse-init) (testtraverse-run)) (defun testtraverse-init () (print (time (init-traverse)))) (defun testtraverse-run () (print (time (run-traverse)))) gcl27-2.7.0/bench/triang-mod.cl000066400000000000000000000046531454061450500161120ustar00rootroot00000000000000;; $Header$ ;; $Locker$ ;;; TRIANG -- Board game benchmark. ;;; In converting to common lisp eq compares of fixnums have been changed ;;; to eql and the type of the board vectors has been declared. (proclaim '(special board sequence a b c)) (proclaim '(type (vector fixnum ) board sequence a b c)) (defvar answer) (defvar final) (defun triang-setup () (setq board (make-array 16 :element-type 'fixnum :initial-element 1)) (setq sequence (make-array 14 :element-type 'fixnum :initial-element 0)) (setq a (make-array 37 :element-type 'fixnum :initial-contents '(1 2 4 3 5 6 1 3 6 2 5 4 11 12 13 7 8 4 4 7 11 8 12 13 6 10 15 9 14 13 13 14 15 9 10 6 6))) (setq b (make-array 37 :element-type 'fixnum :initial-contents '(2 4 7 5 8 9 3 6 10 5 9 8 12 13 14 8 9 5 2 4 7 5 8 9 3 6 10 5 9 8 12 13 14 8 9 5 5))) (setq c (make-array 37 :element-type 'fixnum :initial-contents '(4 7 11 8 12 13 6 10 15 9 14 13 13 14 15 9 10 6 1 2 4 3 5 6 1 3 6 2 5 4 11 12 13 7 8 4 4))) (setf (aref board 5) 0)) (defun last-position () (do ((i 1 (the fixnum (+ i 1)))) ((= i 16) 0) (declare (fixnum i)) (if (eql 1 (aref board i)) (return i)))) (defun try (i depth) (declare (fixnum i depth)) (cond ((= depth 14) (let ((lp (last-position))) (unless (member lp final :test #'eql) (push lp final))) ;;; (format t "~&~s" (cdr (simple-vector-to-list sequence))) (push (cdr (simple-vector-to-list sequence)) answer) t) ; this is a hack to replace LISTARRAY ((and (eql 1 (aref board (aref a i))) (eql 1 (aref board (aref b i))) (eql 0 (aref board (aref c i)))) (setf (aref board (aref a i)) 0) (setf (aref board (aref b i)) 0) (setf (aref board (aref c i)) 1) (setf (aref sequence depth) i) (do ((j 0 (the fixnum (+ j 1))) (depth (the fixnum (+ depth 1)))) ((or (= j 36) (try j depth)) ()) (declare (fixnum j depth))) (setf (aref board (aref a i)) 1) (setf (aref board (aref b i)) 1) (setf (aref board (aref c i)) 0) ()))) (defun simple-vector-to-list (seq) (do ((i (- (length seq) 1) (1- i)) (res)) ((< i 0) res) (declare (fixnum i)) (declare (type (array fixnum) seq)) (push (aref seq i) res))) (defun gogogo (i) (let ((answer ()) (final ())) (try i 1))) (defun testtriang () (triang-setup) (print (time (gogogo 22)))) gcl27-2.7.0/bench/triang-old-mod.cl000066400000000000000000000043061454061450500166610ustar00rootroot00000000000000;; $Header$ ;; $Locker$ ;;; TRIANG -- Board game benchmark. (proclaim '(special board sequence a b c)) (proclaim '(type (vector fixnum) a b c)) (defmacro fref (v i) `(the fixnum (aref (the (vector fixnum) ,v) ,i))) (defvar answer) (defvar final) (defun triang-setup () (setq board (make-array 16 :initial-element 1)) (setq sequence (make-array 14 :initial-element 0)) (setq a (make-array 37 :element-type 'fixnum :initial-contents '(1 2 4 3 5 6 1 3 6 2 5 4 11 12 13 7 8 4 4 7 11 8 12 13 6 10 15 9 14 13 13 14 15 9 10 6 6))) (setq b (make-array 37 :element-type 'fixnum :initial-contents '(2 4 7 5 8 9 3 6 10 5 9 8 12 13 14 8 9 5 2 4 7 5 8 9 3 6 10 5 9 8 12 13 14 8 9 5 5))) (setq c (make-array 37 :element-type 'fixnum :initial-contents '(4 7 11 8 12 13 6 10 15 9 14 13 13 14 15 9 10 6 1 2 4 3 5 6 1 3 6 2 5 4 11 12 13 7 8 4 4))) (setf (svref board 5) 0)) (defun last-position () (do ((i 1 (the fixnum (+ i 1)))) ((= i 16) 0) (declare (fixnum i)) (if (eq 1 (svref board i)) (return i)))) (proclaim '(function try (fixnum fixnum) t)) (defun try (i depth) (declare (fixnum i depth)) (cond ((= depth 14) (let ((lp (last-position))) (unless (member lp final :test #'eq) (push lp final))) (push (cdr (simple-vector-to-list sequence)) answer) t) ; this is a hack to replace LISTARRAY ((and (eq 1 (svref board (fref a i))) (eq 1 (svref board (fref b i))) (eq 0 (svref board (fref c i)))) (setf (svref board (fref a i)) 0) (setf (svref board (fref b i)) 0) (setf (svref board (fref c i)) 1) (setf (svref sequence depth) i) (do ((j 0 (the fixnum (+ j 1))) (depth (the fixnum (+ depth 1)))) ((or (= j 36) (try j depth)) ()) (declare (fixnum j depth))) (setf (svref board (fref a i)) 1) (setf (svref board (fref b i)) 1) (setf (svref board (fref c i)) 0) ()))) (defun simple-vector-to-list (seq) (do ((i (- (length seq) 1) (1- i)) (res)) ((< i 0) res) (declare (fixnum i)) (push (svref seq i) res))) (defun gogogo (i) (let ((answer ()) (final ())) (try i 1))) (defun testtriang () (triang-setup) (print (time (gogogo 22)))) gcl27-2.7.0/bench/triang.cl000066400000000000000000000037421454061450500153330ustar00rootroot00000000000000;; $Header$ ;; $Locker$ ;;; TRIANG -- Board game benchmark. (proclaim '(special board sequence a b c)) (defvar answer) (defvar final) (defun triang-setup () (setq board (make-array 16 :initial-element 1)) (setq sequence (make-array 14 :initial-element 0)) (setq a (make-array 37 :initial-contents '(1 2 4 3 5 6 1 3 6 2 5 4 11 12 13 7 8 4 4 7 11 8 12 13 6 10 15 9 14 13 13 14 15 9 10 6 6))) (setq b (make-array 37 :initial-contents '(2 4 7 5 8 9 3 6 10 5 9 8 12 13 14 8 9 5 2 4 7 5 8 9 3 6 10 5 9 8 12 13 14 8 9 5 5))) (setq c (make-array 37 :initial-contents '(4 7 11 8 12 13 6 10 15 9 14 13 13 14 15 9 10 6 1 2 4 3 5 6 1 3 6 2 5 4 11 12 13 7 8 4 4))) (setf (svref board 5) 0)) (defun last-position () (do ((i 1 (the fixnum (+ i 1)))) ((= i 16) 0) (declare (fixnum i)) (if (eq 1 (svref board i)) (return i)))) (defun try (i depth) (declare (fixnum i depth)) (cond ((= depth 14) (let ((lp (last-position))) (unless (member lp final :test #'eq) (push lp final))) (push (cdr (simple-vector-to-list sequence)) answer) t) ; this is a hack to replace LISTARRAY ((and (eq 1 (svref board (svref a i))) (eq 1 (svref board (svref b i))) (eq 0 (svref board (svref c i)))) (setf (svref board (svref a i)) 0) (setf (svref board (svref b i)) 0) (setf (svref board (svref c i)) 1) (setf (svref sequence depth) i) (do ((j 0 (the fixnum (+ j 1))) (depth (the fixnum (+ depth 1)))) ((or (= j 36) (try j depth)) ()) (declare (fixnum j depth))) (setf (svref board (svref a i)) 1) (setf (svref board (svref b i)) 1) (setf (svref board (svref c i)) 0) ()))) (defun simple-vector-to-list (seq) (do ((i (- (length seq) 1) (1- i)) (res)) ((< i 0) res) (declare (fixnum i)) (push (svref seq i) res))) (defun gogogo (i) (let ((answer ()) (final ())) (try i 1))) (defun testtriang () (triang-setup) (print (time (gogogo 22)))) gcl27-2.7.0/bfdtest.c000066400000000000000000000324311454061450500142440ustar00rootroot00000000000000#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); } } gcl27-2.7.0/bin/000077500000000000000000000000001454061450500132125ustar00rootroot00000000000000gcl27-2.7.0/bin/.gitignore000066400000000000000000000000301454061450500151730ustar00rootroot00000000000000append dpp file-sub gcl gcl27-2.7.0/bin/append.c000077500000000000000000000012411454061450500146260ustar00rootroot00000000000000#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; } gcl27-2.7.0/bin/dpp.c000077500000000000000000000313161454061450500141500ustar00rootroot00000000000000/* 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; if (nopt || rest_flag || key_flag) 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"); if (nopt == 0 && !rest_flag && !key_flag) fprintf(out, "\tcheck_arg(%d);\n", nreq); else { fprintf(out, "\tnarg = vs_top - vs_base;\n"); 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; } gcl27-2.7.0/bin/file-sub.c000066400000000000000000000026101454061450500150630ustar00rootroot00000000000000/* # 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); } } gcl27-2.7.0/bin/info000077500000000000000000000003131454061450500140700ustar00rootroot00000000000000#!/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))))' gcl27-2.7.0/bin/info1000077500000000000000000000004041454061450500141520ustar00rootroot00000000000000#!/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))) gcl27-2.7.0/bin/makefile000066400000000000000000000006141454061450500147130ustar00rootroot00000000000000DEFS = -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 gcl27-2.7.0/bin/tkinfo000077500000000000000000000004511454061450500144320ustar00rootroot00000000000000#!/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) gcl27-2.7.0/clcs/000077500000000000000000000000001454061450500133665ustar00rootroot00000000000000gcl27-2.7.0/clcs/.gitignore000066400000000000000000000000271454061450500153550ustar00rootroot00000000000000*.c *.h saved_clcs_gcl gcl27-2.7.0/clcs/gcl_clcs_condition_definitions.lisp000077500000000000000000000160351454061450500225010ustar00rootroot00000000000000;;; -*- 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-condition 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 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) (DEFINE-CONDITION DIVISION-BY-ZERO (ARITHMETIC-ERROR) NIL) (DEFINE-CONDITION FLOATING-POINT-INVALID-OPERATION (ARITHMETIC-ERROR) NIL) (DEFINE-CONDITION FLOATING-POINT-UNDERFLOW (ARITHMETIC-ERROR) NIL) (DEFINE-CONDITION FLOATING-POINT-INEXACT (ARITHMETIC-ERROR) NIL) (DEFINE-CONDITION FLOATING-POINT-OVERFLOW (ARITHMETIC-ERROR) 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))))) (macrolet ((make-fpe-conditions (&aux (n "indoux")) (labels ((fpe (st &optional (p "FPE-")) (intern (concatenate 'string p (string st)))) (fpess (st) (when (> (length st) 2) (let ((i -1)) (mapcar (lambda (x) (fpe (concatenate 'string (subseq st 0 (incf i)) (subseq st (1+ i))))) (make-list (length st)))))) (make-sub-fpe-conditions (l &optional c);FIXME, all combinations not needed nor possible per IEEE (cond (l (append (make-sub-fpe-conditions (cdr l) c) (make-sub-fpe-conditions (cdr l) (cons (car l) c)))) ((cdr c) (let ((st (nstring-upcase (coerce (mapcar (lambda (x) (aref n (1- (integer-length (caddr x))))) c) 'string)))) `((,(fpe st) ,(or (fpess st) (mapcar (lambda (x) (fpe (car x) "INTERNAL-SIMPLE-")) c))))))))) `(progn ,@(mapcar (lambda (x) `(define-condition ,(car x) (arithmetic-error) nil)) fpe::+fe-list+) ,@(mapcar (lambda (x) `(define-condition ,@x nil)) (make-sub-fpe-conditions fpe::+fe-list+)))))) (make-fpe-conditions)) #.`(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))))) gcl27-2.7.0/clcs/gcl_clcs_conditions.lisp000077500000000000000000000060071454061450500202670ustar00rootroot00000000000000;;; -*- 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)) gcl27-2.7.0/clcs/gcl_clcs_precom.lisp000077500000000000000000000003621454061450500174010ustar00rootroot00000000000000;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- (unless (find-package :conditions) (make-package :conditions :use '("LISP" "PCL"))) (in-package "CONDITIONS") #+pcl (pcl::precompile-random-code-segments clcs) gcl27-2.7.0/clcs/gcl_cmpinit.lsp000066400000000000000000000003301454061450500163720ustar00rootroot00000000000000;(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")) ;;;;; gcl27-2.7.0/clcs/loading.lisp000077500000000000000000000012401454061450500156740ustar00rootroot00000000000000(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))) gcl27-2.7.0/clcs/makefile000066400000000000000000000031301454061450500150630ustar00rootroot00000000000000-include ../makedefs COMPILE_FILE=./saved_clcs_gcl ./ $(LISPFLAGS) -system-p -c-file -data-file \ -o-file nil -h-file -compile FILES:=$(shell ls -1 gcl_clcs_*.lisp | sed 's,\.lisp,,1') APPEND=../xbin/append all: $(addsuffix .c,$(FILES)) $(addsuffix .o,$(FILES)) gprof_objs: $(addprefix ../gprof/,$(addsuffix .o,$(FILES))) ../gprof/%.o: %.c #$(DECL) $(CC) -I../h -c $(filter-out -fomit-frame-pointer,$(CFLAGS)) $(DEFS) -pg $*.c $(AUX_INFO) -o $@ ${APPEND} ${NULLFILE} $*.data $@ saved_clcs_gcl: ../unixport/saved_pcl_gcl echo '(load "package.lisp")(load "myloadp.lisp")(setq si::*disable-recompile* t)(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))) gcl27-2.7.0/clcs/unused/test2.lisp000077500000000000000000000030551454061450500166310ustar00rootroot00000000000000(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)))) gcl27-2.7.0/clcs/unused/test3.lisp000077500000000000000000000072761454061450500166430ustar00rootroot00000000000000(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)) gcl27-2.7.0/clcs/unused/test4.lisp000077500000000000000000000010521454061450500166260ustar00rootroot00000000000000(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))))) gcl27-2.7.0/clcs/unused/test5.lisp000077500000000000000000000261651454061450500166430ustar00rootroot00000000000000;;; -*- 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)))) ) gcl27-2.7.0/clcs/unused/tester.lisp000077500000000000000000000005661454061450500171020ustar00rootroot00000000000000(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)))gcl27-2.7.0/cmpnew/000077500000000000000000000000001454061450500137335ustar00rootroot00000000000000gcl27-2.7.0/cmpnew/.gitignore000066400000000000000000000000101454061450500157120ustar00rootroot00000000000000*.c *.h gcl27-2.7.0/cmpnew/gcl_cmpbind.lsp000077500000000000000000000055441454061450500167270ustar00rootroot00000000000000;;; 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*. (defvar *new-env* nil) (defun c2bind (var) (case (var-kind var) (LEXICAL (when (var-ref-ccb var) (wt-nl) (clink (var-ref var)) (setf (var-ref-ccb var) (ccb-vs-push)))) (SPECIAL (setq *bds-used* t) (wt-nl "bds_bind(" (vv-str (var-loc var)) ",") (wt-vs (var-ref var)) (wt ");") (push 'bds-bind *unwind-exit*)) (t (wt-nl "V" (var-loc var) "=") (wt (or (cdr (assoc (var-kind var) +to-c-var-alist+)) (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) (clink (var-ref var) loc) (setf (var-ref-ccb var) (ccb-vs-push))) (t (wt-nl) (wt-vs (var-ref var)) (wt "= " loc ";")))) (SPECIAL (setq *bds-used* t) (wt-nl "bds_bind(" (vv-str (var-loc var)) "," loc ");") (push 'bds-bind *unwind-exit*)) (t (wt-nl "V" (var-loc var) "= ") (let ((wtf (cdr (assoc (var-kind var) +wt-loc-alist+)))) (unless wtf (baboon)) (funcall wtf loc)) (wt ";")))) (defun c2bind-init (var init) (case (var-kind var) (LEXICAL (cond ((var-ref-ccb var) (let* ((loc (list 'vs (var-ref var))) (*value-to-go* loc)) (c2expr* init)) (clink (var-ref var)) (setf (var-ref-ccb var) (ccb-vs-push))) ((let ((*value-to-go* (list 'vs (var-ref var)))) (c2expr* init))))) (SPECIAL (let* ((loc `(cvar ,(cs-push t))) (*value-to-go* loc)) (c2expr* init) (c2bind-loc var loc))) (t (let ((*value-to-go* (list 'var var nil))) (unless (assoc (var-kind var) +wt-loc-alist+) (baboon));FIXME??? (c2expr* init))))) gcl27-2.7.0/cmpnew/gcl_cmpblock.lsp000077500000000000000000000420621454061450500171010ustar00rootroot00000000000000;;; 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 (:print-function (lambda (x s i) (s-print 'blk (blk-name x) (si::address x) s)))) 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. type ) (si::freeze-defstruct 'blk) (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 ref-blks (form blks) (ref-obs form blks (lambda (x) (setf (blk-ref-ccb x) t)) (lambda (x) (setf (blk-ref-clb x) t)) (lambda (x) (setf (blk-ref x) t)) 'blk-name "Blk" (lambda (x &aux (y (pop x))) (when (eq y 'return-from) (cdr x))))) ;; (defun ref-blks1 (form blks &aux (i (cadr form))) ;; (dolist (blk blks) ;; (when (member blk (info-bref-ccb i)) ;; (setf (blk-ref-ccb blk) t)) ;; (when (member blk (info-bref-clb i)) ;; (setf (blk-ref-clb blk) t)) ;; (when (member blk (info-bref i)) ;; (setf (blk-ref blk) t)))) ;; (defun ref-blks (form blks &optional l) ;; (cond ((not l) ;; (cond (*fast-ref* (ref-blks1 form blks)) ;; ((let* ((l (list (info-bref (cadr form)) (info-bref-ccb (cadr form)) (info-bref-clb (cadr form)))) ;; (l (mapcar (lambda (x) (intersection x blks)) l)) ;; (l (mapcar (lambda (y) (mapcar (lambda (x) (cons x nil)) y)) l))) ;; (ref-blks form blks l) ;; (let* (y (x (member-if (lambda (x) (setq y (member nil x :key 'cdr))) l))) ;; (when y ;; (cmpwarn "~s Blk ~s reffed in info but not in form" (length (ldiff l x)) (blk-name (caar y))))))))) ;; ((atom form)) ;; ((eq (car form) 'return-from) ;; (let* ((bref (cddr form)) ;; (v (pop bref)) ;; (clb (pop bref)) ;; (ccb (car bref))) ;; (when (member v blks) ;; (cond (ccb (setf (blk-ref-ccb v) t) ;; (let* ((x (cadr l))(x (assoc v x))) ;; (if x (rplacd x t) (cmpwarn "ccb Block ~s reffed in form but not in info" (blk-name v))))) ;; (clb (setf (blk-ref-clb v) t) ;; (let* ((x (caddr l))(x (assoc v x))) ;; (if x (rplacd x t) (cmpwarn "clb Block ~s reffed in form but not in info" (blk-name v))))) ;; ((setf (blk-ref v) t) ;; (let* ((x (car l))(x (assoc v x))) ;; (if x (rplacd x t) (cmpwarn "nil Block ~s reffed in form but not in info" (blk-name v)))))) ;; (keyed-cmpnote (list 'blk-ref (blk-name v)) "Block ~s is referred with barrier ~s" (blk-name v) (if ccb 'cb (if clb 'lb)))) ;; (ref-blks (cdddr form) blks l)));FIXME? ;; (t (ref-blks (car form) blks l) (ref-blks (cdr form) blks l)))) (defun prune-mch (l) (remove-if (lambda (x &aux (v (pop x))(tp (pop x))(st (pop x))(m (car x))) (and (type>= (type-and (var-dt v) tp) (var-type v)) (subsetp st (var-store v)) (if m (equal tp m) t))) l)) (defvar *c1exit* nil) (defun make-c1exit (n) (cons n (current-env))) (defun c1block (args &aux (info (make-info))(*c1exit* (cons (make-c1exit (car args)) *c1exit*))) (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 :exit *c1exit* :var (mapcan (lambda (x) (when (var-p x) (list (list x nil nil nil)))) *vars*))) (body (let ((*blocks* (cons blk *blocks*))) (c1progn (cdr args))))) (labels ((nb (b) (if (and (eq (car b) 'return-from) (eq blk (caddr b))) (nb (seventh b)) b))) (setq body (nb body))) (add-info info (cadr body)) (setf (info-type info) (type-or1 (info-type (cadr body)) (blk-type blk))) (when (info-type (cadr body)) (or-mch (prune-mch (blk-var blk)))) (ref-blks body (list blk)) (when (or (blk-ref-ccb blk) (blk-ref-clb blk)) (incf *setjmps*)) (mapc (lambda (x &aux (y x)(v (pop x))(tp (pop x))(st (pop x))(m (car x)) (tp (type-and tp (var-dt v))));FIXME, unnecessary? (unless (and (si::type= tp (var-type v)) (subsetp st (var-store v)) (subsetp (var-store v) st) (if m (equal m tp) t)) (keyed-cmpnote (list (var-name v) 'block-set) "Altering ~s at end of block ~s:~% type from ~s to ~s,~% store from ~s to ~s" v (blk-name blk) (cmp-unnorm-tp (var-type v)) (cmp-unnorm-tp tp) (var-store v) st) (do-setq-tp v '(blk-set) tp) (push-vbinds v st))) (blk-var blk)) (cond ((or (blk-ref-ccb blk) (blk-ref-clb blk) (blk-ref blk))(list 'block info blk body)) (body)))) ;; (defun c1block (args &aux (info (make-info))) ;; (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 :exit *c1exit*)) ;; (body (let ((*blocks* (cons blk *blocks*))) (c1progn (cdr args))))) ;; (labels ((nb (b) (if (and (eq (car b) 'return-from) (eq blk (caddr b))) (nb (seventh b)) b))) (setq body (nb body))) ;; (add-info info (cadr body)) ;; (setf (info-type info) (type-or1 (info-type (cadr body)) (blk-type blk))) ;; (ref-blks body (list blk)) ;; (when (or (blk-ref-ccb blk) (blk-ref-clb blk)) ;; (incf *setjmps*)) ;; (cond ((or (blk-ref-ccb blk) (blk-ref-clb blk) (blk-ref blk))(list 'block info blk body)) ;; (body)))) ;; (defun c1block (args &aux (info (make-info))) ;; (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 :exit *c1exit*)) ;; (body (let ((*blocks* (cons blk *blocks*))) (c1progn (cdr args))))) ;; (add-info info (cadr body)) ;; (setf (info-type info) (type-or1 (info-type (cadr body)) (blk-type blk))) ;; (ref-blks body (list blk)) ;; (when (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 info blk body) ;; body))) ;; (defun c1block (args &aux (info (make-info))) ;; (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 :exit *c1exit*)) ;; (body (let ((*blocks* (cons blk *blocks*))) (c1progn (cdr args))))) ;; (when (or (blk-ref-ccb blk) (blk-ref-clb blk)) ;; (incf *setjmps*)) ;; (add-info info (cadr body)) ;; (setf (info-type info) (type-or1 (info-type (cadr body)) (blk-type blk))) ;; (if (or (blk-ref-ccb blk) (blk-ref-clb blk) (blk-ref blk)) ;; (list 'block info 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) (add-libc "setjmp") (setq *frame-used* t) (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) (clink (blk-ref-clb blk)) (setf (blk-ref-ccb blk) (ccb-vs-push)) (add-libc "setjmp") (setq *frame-used* t) (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 &aux (name (car args)) ccb clb inner) (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))) (dolist (blk *blocks* (cmperr "The block ~s is undefined." name)) (case blk (cb (setq ccb t inner (or inner 'cb))) (lb (setq clb t inner (or inner 'lb))) (t (when (when (eq (blk-name blk) name) (not (member blk *lexical-env-mask*))) (let* ((*c1exit* (blk-exit blk)) (val (c1expr (cadr args))) (c1fv (when ccb (c1inner-fun-var)))) (setf (blk-type blk) (type-or1 (blk-type blk) (info-type (cadr val)))) (when (info-type (cadr val)) (or-mch (prune-mch (blk-var blk)))) (return (list 'return-from (let ((info (copy-info (cadr val)))) (setf (info-type info) nil) (cond (ccb (pushnew blk (info-ref-ccb info))) (clb (pushnew blk (info-ref-clb info))) ((pushnew blk (info-ref info)))) (when c1fv (add-info info (cadr c1fv))) info) blk ccb clb c1fv val))))))));FIXME infer-tp here, or better in blk-var-null, etc. ;; (defun c1return-from (args &aux (name (car args)) ccb clb inner) ;; (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))) ;; (dolist (blk *blocks* (cmperr "The block ~s is undefined." name)) ;; (case blk ;; (cb (setq ccb t inner (or inner 'cb))) ;; (lb (setq clb t inner (or inner 'lb))) ;; (t (when (eq (blk-name blk) name) ;; (let* ((*c1exit* (cons (blk-name blk) (blk-exit blk))) ;; (val (c1expr (cadr args))) ;; (c1fv (when ccb (c1inner-fun-var)))) ;; (setf (blk-type blk) (type-or1 (blk-type blk) (info-type (cadr val)))) ;; (return (list 'return-from ;; (let ((info (copy-info (cadr val)))) ;; (setf (info-type info) nil) ;; (cond (ccb (pushnew blk (info-ref-ccb info))) ;; (clb (pushnew blk (info-ref-clb info))) ;; ((pushnew blk (info-ref info)))) ;; (when c1fv (add-info info (cadr c1fv))) ;; info) ;; blk ccb clb c1fv val)))))))) ;; (defun c1return-from (args &aux (name (car args)) ccb clb inner) ;; (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))) ;; (dolist (blk *blocks* (cmperr "The block ~s is undefined." name)) ;; (case blk ;; (cb (setq ccb t inner (or inner 'cb))) ;; (lb (setq clb t inner (or inner 'lb))) ;; (t (when (eq (blk-name blk) name) ;; (let* ((*c1exit* (cons (blk-name blk) (blk-exit blk))) ;; (val (c1expr (cadr args))) ;; (c1fv (when ccb (c1inner-fun-var)))) ;; (setf (blk-type blk) (type-or1 (blk-type blk) (info-type (cadr val)))) ;; (return (list 'return-from ;; (let ((info (copy-info (cadr val)))) ;; (setf (info-type info) nil) ;; (pushnew blk (info-blocks info)) ;; (when *make-fast-ref* ;; (cond (ccb (pushnew blk (info-vref-ccb info))) ;; (clb (pushnew blk (info-vref-clb info))) ;; ((pushnew blk (info-vref info))))) ;; (when c1fv (add-info info (cadr c1fv))) ;; info) ;; blk ccb clb c1fv val)))))))) ;; (defun c1return-from (args &aux (name (car args)) ccb clb inner) ;; (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))) ;; (dolist (blk *blocks* (cmperr "The block ~s is undefined." name)) ;; (case blk ;; (cb (setq ccb t inner (or inner 'cb))) ;; (lb (setq clb t inner (or inner 'lb))) ;; (t (when (eq (blk-name blk) name) ;; (let* ((*c1exit* (cons (blk-name blk) (blk-exit blk))) ;; (val (c1expr (cadr args))) ;; (c1fv (when ccb (c1inner-fun-var)))) ;; (setf (blk-type blk) (type-or1 (blk-type blk) (info-type (cadr val)))) ;; (return (list 'return-from ;; (let ((info (copy-info (cadr val)))) ;; (setf (info-type info) nil) ;; (pushnew blk (info-blocks info)) ;; (cond (ccb (pushnew blk (info-bref-ccb info))) ;; (clb (pushnew blk (info-bref-clb info))) ;; ((pushnew blk (info-bref info)))) ;; (when c1fv (add-info info (cadr c1fv))) ;; info) ;; blk clb ccb c1fv val)))))))) ;; (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 clb inner) ;; ((endp blks) ;; (cmperr "The block ~s is undefined." name)) ;; (case (car blks) ;; (cb (setq ccb t inner (or inner 'cb))) ;; (lb (setq clb t inner (or inner 'lb))) ;; (t (when (eq (blk-name (car blks)) name) ;; (let* ((blk (car blks)) ;; (*c1exit* (cons (blk-name (car blks)) (blk-exit (car blks)))) ;; (val (c1expr (cadr args)))) ;; (cond ;; (ccb (ref-inner inner) (setf (blk-ref-ccb blk) t)) ;; (clb (setf (blk-ref-clb blk) t)) ;; (t (setf (blk-ref blk) t))) ;; (setf (blk-type (car blks)) (type-or1 (blk-type (car blks)) (info-type (cadr val)))) ;; (return (list 'return-from ;; (let ((info (copy-info (cadr val)))) ;; (setf (info-type info) nil) ;; (pushnew blk (info-blocks info)) ;; info) ;; blk clb ccb val)))))))) (defun c2return-from (blk ccb clb c1fv val) (declare (ignore c1fv)) (cond (ccb (c2return-ccb blk val)) (clb (c2return-clb blk val)) (t (c2return-local blk val)))) ;; (defun c2return-from (blk clb ccb c1fv val) ;; (declare (ignore c1fv)) ;; (cond (ccb (c2return-ccb blk val)) ;; (clb (c2return-clb blk val)) ;; (t (c2return-local blk 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);") (unwind-exit nil)) (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);}") (unwind-exit nil)) gcl27-2.7.0/cmpnew/gcl_cmpcall.lsp000077500000000000000000000553321454061450500167260ustar00rootroot00000000000000;;; 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) (defun link-arg-p (x) (or (is-global-arg-type x) (not (is-local-arg-type x)))) (defun fast-link-proclaimed-type-p (fname &optional args) (and (symbolp fname) ; (not (get fname 'lfun)) (and (< (length args) 64) (or (and (get fname 'fixed-args) (listp args)) (and (link-arg-p (get-return-type fname)) (not (member-if-not 'link-arg-p (get-arg-types fname)))))))) (si::putprop 'funcall 'c2funcall-aux 'wholec2) (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) (or (c1local-fun name) (macro-function name))) ;; (defun sf (s) ;; (declare (optimize (safety 1))) ;; (check-type s symbol) ;; (or (let ((x (c::symbol-sfdef s))) ;; (unless (= x (si::address nil)) (cons 'special x))) ;; (let ((x (c::symbol-gfdef s))) ;; (when (= 0 (si::address x)) ;; (error 'undefined-function s)) ;; (if (= (c::symbol-mflag s) 0) x (cons 'macro x))))) ;; (defun funcallable-symbol-p (s) ;; (and (symbolp s) ;; (/= (si::address (c::symbol-gfdef s)) 0) ;; (= (c::symbol-mflag s) 0) ;; (= (c::symbol-sfdef s) (si::address nil)))) ;; (declaim (inline funcallable-symbol-p)) ;; (deftype funcallable-symbol nil `(satisfies funcallable-symbol-p)) ;; (defun fsf (s) ;; (declare (optimize (safety 1))) ;; (check-type s funcallable-symbol) ;; (c::symbol-gfdef s)) ;; (declaim (inline fsf)) ;; (defun c1funob (fun &aux sym) ;; ;;; 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 (symbolp (cadr fun)) ;; (or (c1local-fun (cadr fun)) ;; (list 'call-global ;; (make-info :type (get-return-type (cadr fun)) ;; :sp-change (if (null (get (cadr fun) 'no-sp-change)) 1 0)) ;; (cadr fun))) ;; ))) ;; (and (eq (car fun) 'function) ;; (not (endp (cdr fun))) ;; (endp (cddr fun)) ;; (or ;; (and (setq sym (si::funid-sym-p (cadr fun))) ;; (or (c1local-fun sym) ;; (list 'call-global ;; (make-info :type (get-return-type sym) ;; :sp-change (if (null (get sym 'no-sp-change)) 1 0)) ;; sym)) ;; ))))) ;; (let* ((x (c1expr (let ((x (tmpsym))) `(let ((,x ,fun)) (if (symbolp ,x) (fsf ,x) ,x))))) ;; (info (make-info :type (get-return-type fun) :sp-change 1))) ;; (add-info info (cadr x)) ;; (list 'ordinary info x)))) (defun c2funcall-aux(form &aux (funob (caddr form)) (args (cadddr form))) (c2funcall funob args)) (defvar *use-sfuncall* t) (defvar *super-funcall* nil) (defun c2funcall (funob args &optional loc) (unless (listp 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) (return-from c2funcall nil)) (unless (eq 'ordinary (car funob)) (baboon)) (let* ((fn (caddr funob)) (all (cons fn args)) (*inline-blocks* 0)) (setq *sup-used* t) (unwind-exit (get-inline-loc (list (make-list (length all) :initial-element t) '* #.(flags ans set svt) (concatenate 'string "({object _z;fixnum _v=(fixnum)#v; fcall.fun=#0;fcall.valp=_v;fcall.argd=#n-1; _z=Rset && !(#0)->fun.fun_argd && fcall.argd>=(#0)->fun.fun_minarg && fcall.argd<=((#0)->fun.fun_maxarg) ? " (if args "(#0)->fun.fun_self(#*)" "((#0)->fun.fun_maxarg ? (#0)->fun.fun_self(#?) : (#0)->fun.fun_self(#*))") " : call_proc_cs2(#?); if (!(#0)->fun.fun_neval && !(#0)->fun.fun_vv) vs_top=_v ? (object *)_v : sup; _z;})")) all)) (close-inline-blocks))) (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 find-var (n x &optional f) (cond ((not f) (find-var n x t)) ((var-p x) (when (eq n (var-name x)) x)) ((atom x) nil) ((or (find-var n (car x) f) (find-var n (cdr x) f))))) (defun ori-p (x) (and (consp x) (eq (car x) 'var) (char= #\Z (aref (symbol-name (var-name (caaddr x))) 0)))) (defun kp (x y) (setf (get y 'kp) x) (cons x y)) (defun ll-sym (x &optional kn) (cond ((atom x) x) ((atom (car x)) (car x)) (kn (caar x)) ((cadar x)))) (defun ll-alist (l &aux k (a "G")) (mapcan (lambda (x) (cond ((member x lambda-list-keywords) (setq k x a (string (aref (symbol-name k) 1))) nil) (`(,@(when (and (consp x) (caddr x)) (list (kp (caddr x) (gensym "P")))) ,(kp (ll-sym x) (gensym a)))))) l)) ;; (defun ll-alist (l &aux k) ;; (mapcan (lambda (x) ;; (cond ((member x lambda-list-keywords) (setq k x) nil) ;; (`(,@(when (and (consp x) (caddr x)) (list (kp (caddr x) (gensym "P")))) ;; ,(kp (ll-sym x) (gensym (if k (string (aref (symbol-name k) 1)) "G"))))))) l)) (defun name-keys (l &aux k) (mapcar (lambda (x) (cond ((member x lambda-list-keywords) (setq k x) x) ((eq k '&key) (cond ((atom x) (list (list (intern (symbol-name x) 'keyword) x))) ((atom (car x)) (list* (list (intern (symbol-name (car x)) 'keyword) (car x)) (cdr x))) (x))) (x))) l)) (defun blla-recur (tag ll args last) (let* ((ll (ldiff ll (member '&aux ll)));FIXME ? impossible check? (ll (name-keys ll)) (s (ll-alist ll)) (sl (sublis s ll))) (blla sl args last `((tail-recur ,tag ,s))))) (defun c1tail-recur (args) (let* ((s (cadr args)) (ts (or (car (member (car args) *ttl-tags* :key 'car)) (baboon))) (ttl-tag (pop ts)) (nv (mapcar (lambda (x) (car (member (cdr x) *vars* :key (lambda (x) (when (var-p x) (var-name x)))))) s)) (ov (mapcar (lambda (x) (car (member (car x) (car ts) :key (lambda (x) (when (var-p x) (var-name x)))))) s)) (v (mapc (lambda (x) (set-var-noreplace x)) (append nv ov))) (*vars* (append v *vars*)) (*tags* (cons ttl-tag *tags*)) (*lexical-env-mask* (remove ttl-tag (set-difference *lexical-env-mask* v)))) (c1expr `(progn (setq ,@(mapcan (lambda (x) (list (car x) (cdr x))) s)) (go ,(tag-name ttl-tag)))))) ;; (defun c1tail-recur (args) ;; (let* ((tag (pop args)) ;; (s (car args)) ;; (ts (or (car (member tag *ttl-tags* :key (lambda (x) (tag-name (car x))))) (baboon))) ;; (ttl-tag (pop ts)) ;; (nv (mapcar (lambda (x) (car (member (cdr x) *vars* ;; :key (lambda (x) (when (var-p x) (var-name x)))))) s)) ;; (ov (mapcar (lambda (x) (car (member (car x) (car ts) ;; :key (lambda (x) (when (var-p x) (var-name x)))))) s)) ;; (*vars* (mapc (lambda (x) (set-var-noreplace x)) (append nv ov))) ;; (*tags* (cons ttl-tag *tags*))) ;; (c1expr `(progn ;; (setq ,@(mapcan (lambda (x) (list (car x) (cdr x))) s)) ;; (go ,tag))))) ;; (defun c1tail-recur (args) ;; (let* ((tag (pop args)) ;; (s (car args)) ;; (ts (or (car (member tag *ttl-tags* :key (lambda (x) (tag-name (car x))))) (baboon))) ;; (ttl-tag (pop ts)) ;; (nv (mapcar (lambda (x) (car (member (cdr x) *vars* ;; :key (lambda (x) (when (var-p x) (var-name x)))))) s)) ;; (ov (mapcar (lambda (x) (car (member (car x) (car ts) ;; :key (lambda (x) (when (var-p x) (var-name x)))))) s)) ;; (*vars* (mapc (lambda (x) (setf (var-store x) t)) (append nv ov))) ;; (*tags* (cons ttl-tag *tags*))) ;; (c1expr `(progn ;; (setq ,@(mapcan (lambda (x) (list (car x) (cdr x))) s)) ;; (go ,tag))))) ;; (defun c1tail-recur (args) ;; (let* ((tag (pop args)) ;; (s (car args)) ;; (ts (or (car (member tag *ttl-tags* :key (lambda (x) (tag-name (car x))))) (baboon))) ;; (ttl-tag (pop ts)) ;; (nv (mapcar (lambda (x) (car (member (cdr x) *vars* ;; :key (lambda (x) (when (var-p x) (var-name x)))))) s)) ;; (ov (mapcar (lambda (x) (car (member (car x) (car ts) ;; :key (lambda (x) (when (var-p x) (var-name x)))))) s)) ;; (*vars* (mapc (lambda (x) (setf (var-store x) t)) (append nv ov))) ;; (*tags* (cons ttl-tag *tags*))) ;; (c1expr `(progn ;; (psetq ,@(mapcan (lambda (x) (list (car x) (cdr x))) s)) ;; (go ,tag))))) (setf (get 'tail-recur 'c1) 'c1tail-recur) (defun c2call-global (fname args loc return-type &optional lastp &aux fd (*vs* *vs*)) (assert (not (special-operator-p fname))) (assert (not (macro-function fname))) (assert (listp args)) (assert (null loc)) (assert (setq fd (get-inline-info fname args return-type (when lastp (length args))))) (let ((*inline-blocks* 0) (*restore-avma* *restore-avma*)) (save-avma fd) (unwind-exit (get-inline-loc fd args) nil fname) (close-inline-blocks))) (defun link-rt (tp global) (cond ((cmpt tp) `(,(car tp) ,@(mapcar (lambda (x) (link-rt x global)) (cdr tp)))) ((not tp) #tnull) ((type>= #tboolean tp) #tt);FIXME ((car (member tp `(,@(if global +c-global-arg-types+ +c-local-var-types+) t *) :test 'type<=))))) (defun ldiffn (list tail) (if tail (ldiff list tail) list)) (declaim (inline ldiffn)) (defun commasep (x) (mapcon (lambda (x) (if (cdr x) (list (car x) ",") (list (car x)))) x)) (defun ms (&rest r) (apply 'concatenate 'string (mapcar (lambda (x) (cond ((listp x) (apply 'ms x)) ((stringp x) x) ((write-to-string x)))) r))) (defun nords (n &aux (i -1)) (mapl (lambda (x) (setf (car x) (incf i))) (make-list n))) (defun nobs (n &optional (p "_x")) (mapcar (lambda (x) (ms p x)) (nords n))) (defun bind-str (nreq nsup nl) (let* ((unroll (nobs (- nreq nsup))) (decl (commasep (cons (list "_l=#" nsup) unroll))) (unroll (mapcar (lambda (x) (list nl x "=_l->c.c_car;if (_l!=Cnil) _n--;_l=_l->c.c_cdr;")) unroll)) (ndecl (unless (= nreq nsup) (list "fixnum _n=" (- (1+ nsup)) ";")))) (ms ndecl "object " decl ";" unroll))) (defun cond-str (nreq nsup st) (ms "(" (unless (= nreq nsup) (list "_n==" (- (1+ nreq)) (unless st "&&"))) (unless st "_l==Cnil") ")")) (defun mod-argstr (n call st nsup) (let* ((x (commasep (append (nobs nsup "#") (nobs (- n nsup)) (when st (list "_l"))))) (s (or (search "#" call) (length call)))) (ms (subseq call 0 s) x))) (defun nvfun-wrap (cname argstr sig clp ap) (vfun-wrap (ms cname "(" argstr ")") sig clp ap)) (defun wrong-number-args (&rest r) (error 'program-error :format-control "Wrong number of arguments to anonymous function: ~a" :format-arguments (list r))) (defun insufficient-arg-str (fnstr nreq nsup sig st &aux (sig (if st sig (cons '(*) (cdr sig)))) ;(st nil)(nreq 0) (fnstr (or fnstr (ms (vv-str (add-object 'wrong-number-args)) "->s.s_gfdef")))) (ms (cdr (assoc (cadr sig) +to-c-var-alist+)) "(" (nvfun-wrap "call_proc_cs2" (ms (commasep (append (nobs nsup "#") (nobs (- nreq nsup)) `(("#" ,nsup))))) sig fnstr (1+ nreq)) ")"));FIXME better way? ;;FIXME can unroll in lisp only? ;; (defun lisp-unroll (sig args) ;; (let* ((at (car sig)) ;; (st (member '* at)) ;; (regs (ldiffn at st)) ;; (nr (length regs)) ;; (la (1- (length args))) ;; (nd (- nr la)) ;; (binds (mapc (lambda (x) (setf (car x) (tmpsym))) (make-list la))) ;; (l (tmpsym)) ;; (unrolls (mapc (lambda (x) (setf (car x) (tmpsym))) (make-list nd)))) ;; `(let (,@(mapcar 'list binds args) ;; (,l (car (last args))) ;; ,@(mapcar (lambda (x) (list x `(pop ,l))) unrolls)) ;; (if (,l) ;; (apply ',fn ,@binds ,@unrolls ,l) ;; (funcall ',fn ,@binds ,@unrolls))))) (defun maybe-unroll (argstr cname sig ap clp fnstr) (let* ((at (car sig)) (st (member '* at)) (nreq (length (ldiffn at st))) (nsup (if ap (1- ap) nreq))) (when (or (< nsup nreq) (and ap (= nsup nreq) (not st))) (let ((nl (list (string #\Newline) " "))) (ms (list "@" (nords (1+ nsup)) ";") "({" (bind-str nreq nsup nl) nl (cond-str nreq nsup st) " ? " nl (nvfun-wrap cname (mod-argstr nreq argstr st nsup) sig clp ap) " : " nl (insufficient-arg-str fnstr nreq nsup sig st) ";})"))))) (defun g1 (fnstr cname sig ap clp &optional (lev -1)) (let* ((x (make-inline-arg-str sig lev))) (or (maybe-unroll x cname sig ap clp fnstr) (nvfun-wrap cname x sig clp ap)))) ;; (defun g0 (cname sig apnarg clp &optional (lev -1)) ;; (let* ((at (car sig)) ;; (st (member '* at)) ;; (nreg (length (ldiff at st))) ;; (apreg (if apnarg (1- apnarg) nreg)) ;; (u (when (< apreg nreg) (- nreg apreg))) ;; (x (make-inline-arg-str sig lev)) ;; (ss (when u (search (strcat "#" (write-to-string apreg)) x))) ;; (x (if ss (subseq x 0 ss) x)) ;; (yy (when u (let (r) (dotimes (i u (nreverse r)) (push i r))))) ;; (yy (mapcar (lambda (x) (strcat "_x" (write-to-string x))) yy)) ;; (y (append yy (when (when st u) (list "_l")))) ;; (y (mapcon (lambda (x) (if (cdr x) (list (car x) ",") (list (car x)))) y)) ;; (y (apply 'strcat y)) ;; (z (length x))(w (length y)) ;; (s (if (or (= w 0) (= z 0) ;; (char= (char x (1- z)) #\,) (char= (char x (1- z)) #\*)) "" ",")) ;; (x (strcat x s y)) ;; (x (format nil "(~a(~a))" cname x)) ;; (x (vfun-wrap x sig clp)) ;; (ss (when apnarg (search "#n" x))) ;; (x (if ss (progn (setf (aref x (1- ss)) #\-) ;; (when u ;; (setf (aref x (+ 2 ss)) #\-) ;; (setf (aref x (+ 3 ss)) (code-char (+ (truncate u 10) (char-code #\0)))) ;; (setf (aref x (+ 4 ss)) (code-char (+ (mod u 10) (char-code #\0))))) ;; x) x)) ;; (nx (apply 'strcat (mapcar (lambda (x) (strcat x "=_l->c.c_car;_l=_l->c.c_cdr;")) yy))) ;; (nx (strcat "object _l=#" (write-to-string apreg) ;; (apply 'strcat (mapcar (lambda (x) (strcat "," x)) yy)) ";" nx)) ;; (x (if (> w 0) (concatenate 'string "({" nx x ";})") x))) ;; x)) (defun g (fname n sig &optional apnarg (clp t) &aux (cname (format nil "/* ~a */(*LnkLI~d)" (function-string fname) n)) (fnstr (ms (vv-str (add-object fname)) "->s.s_gfdef")) (clp (when clp fnstr))) (g1 fnstr cname sig apnarg clp)) ;; (defun g (fname n sig &optional apnarg (clp t) ;; &aux (cname (format nil "/* ~a */(*LnkLI~d)" (function-string fname) n)) ;; (clp (when clp (concatenate 'string (vv-str (add-object fname)) "->s.s_gfdef")))) ;; (g0 cname sig apnarg clp)) (defun call-arg-types (at la apnarg) (let* ((st (member '* at)) (reg (ldiff at st)) (nr (length reg)) (la (if apnarg (max nr (1- la)) la)) (ns (- nr la))) (cond ((> ns 0) (butlast reg ns));funcall too few args (st at) ((= ns 0) at) ((append at '(*))))));let call_proc_new foil fast linking and catch errors (defun add-fast-link (fname la &optional apnarg &aux n (at (call-arg-types (mapcar (lambda (x) (link-rt x t)) (get-arg-types fname)) la apnarg)) (rt (link-rt (get-return-type fname) t)) (clp (cclosure-p fname)) (tail (list rt at clp apnarg))) (cond ((setq n (caddar (member-if (lambda (x) (and (eq (car x) fname) (equal (cdddr x) tail))) *function-links*))) (car (member-if (lambda (x) (let ((x (last x 2))) (when (eq 'link-call (car x)) (eql n (cadr x))))) *inline-functions*))) ((let* ((n (progn (add-object2 (add-symbol fname)) (next-cfun))) (f (flags ans set)) (f (if (single-type-p rt) f (flag-or f svt))) (f (if apnarg (flag-or f aa) f))) (push (list* fname (format nil "LI~d" n) n tail) *function-links*) (car (push (list fname at rt f (g fname n (list at rt) apnarg clp) 'link-call n) *inline-functions*)))))) ;; (defun add-fast-link (fname &optional apnarg ;; &aux n ;; (at (mapcar (lambda (x) (link-rt x t)) (get-arg-types fname))) ;; (rt (link-rt (get-return-type fname) t)) ;; (clp (cclosure-p fname)) ;; (tail (list rt at clp apnarg))) ;; (cond ((setq n (caddar (member-if ;; (lambda (x) ;; (and (eq (car x) fname) ;; (equal (cdddr x) tail))) *function-links*))) ;; (car (member-if ;; (lambda (x) ;; (let ((x (last x 2))) ;; (when (eq 'link-call (car x)) ;; (eql n (cadr x))))) *inline-functions*))) ;; ((let* ((n (next-cfun)) ;; (f (flags ans set)) ;; (f (if (single-type-p rt) f (flag-or f svt))) ;; (f (if apnarg (flag-or f aa) f))) ;; (push (list* fname (format nil "LI~d" n) n tail) *function-links*) ;; (car (push (list fname at rt f ;; (g fname n (list at rt) apnarg clp) ;; 'link-call n) ;; *inline-functions*)))))) (defun declaration-type (type) (if (or (equal type "") (equal type "long ")) "object " type)) ;;make a function which will be called hopefully only once, ;;and will establish the link. (defun wt-function-link (x) (let* ((name (pop x)) (num (pop x)) (n (pop x)) (type (pop x)) (type (or type t));FIXME (args (pop x)) (clp (pop x))) (declare (ignore n)) (cond (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) (let ((d (declaration-type (rep-type (if (link-arg-p type) type t)))));FIXME (if (or args (not (eq t type))) (wt "(object first,...){" d "V1;va_list ap;va_start(ap,first);V1=(" d ")" "call_proc_new(" (vv-str (add-object name)) "," (if clp "1" "0") "," (write-to-string (argsizes args type 0));FIXME ",(void **)(void *)&Lnk" num "," (new-proclaimed-argd args type) ",first,ap);va_end(ap);return V1;}") (wt "(){" d "V1=(" d ")call_proc_new(" (vv-str (add-object name)) "," (if clp "1" "0") "," (write-to-string (argsizes args type 0));FIXME ",(void **)(void *)&Lnk" num "," (new-proclaimed-argd args type) ",0,0);return V1;}"))))) (setq name (function-string 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 (cs-push t t))) ;; (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 &aux (temp (list 'vs (vs-push)))) (let ((*value-to-go* temp)) (c2expr* funob) temp)) ;; (defun save-funob (funob &optional force) ;; (case (car funob) ;; ((call-quote-lambda call-local)) ;; (call-global ;; (unless (and (not force) ;; (inline-possible (caddr funob)) ;; (or (get (caddr funob) 'Lfun) ;; (get (caddr funob) 'Ufun) ;; (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 &optional lastp) (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) ";") (when lastp (wt-nl "{object _x=*--vs_top;for (;_x!=Cnil;_x=_x->c.c_cdr) *vs_top++=_x->c.c_car;}")) (base-used))))) (defun push-args-lispcall (args) (dolist (arg args) (let ((*value-to-go* (list 'vs (vs-push)))) (c2expr* arg)))) gcl27-2.7.0/cmpnew/gcl_cmpcatch.lsp000077500000000000000000000206211454061450500170660ustar00rootroot00000000000000;;; 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 :type #t* :sp-change 1)) tag) (incf *setjmps*) (when (endp args) (too-few-args 'catch 1 0)) (setq tag (c1arg (car args) info)) (let* ((tag (c1arg (pop args) info)) (in (mch)) (body (unwind-protect (c1progn args) (mapc (lambda (x &aux (v (pop x))) (setf (var-type v) (type-or1 (pop x) (var-type v)));FIXME do-setq-tp (push-vbinds v (car x)));FIXME c1throw/c1return-from in)))) (add-info info (cadr body)) (list 'catch info tag body))) ;; (defun c1catch (args &aux (info (make-info :type #t* :sp-change 1)) tag) ;; (incf *setjmps*) ;; (when (endp args) (too-few-args 'catch 1 0)) ;; (setq tag (c1arg (car args) info)) ;; (let (vl (nt (tmpsym))) ;; (dolist (v *vars*) (when (var-p v) ;; (push (list v (var-mt v) (var-tag v)) vl) ;; (setf (var-tag v) nt (var-mt v) (var-type v)))) ;; (setq args ;; (unwind-protect ;; (do (nargs) ;; ((not ;; (let* ((*catch-tags* (cons nt *catch-tags*)) ;; (nv (with-restore-vars ;; (catch nt ;; (setq nargs (c1progn (cdr args))) nil)))) ;; (when nv ;; (do nil ((not (setq nv (pop *tvc*))) t) (setf (var-type nv) (var-mt nv)))))) ;; nargs)) ;; (dolist (v vl) ;; (when (caddr v) ;; (unless (type>= (cadr v) (var-mt (car v))) ;; (pushnew (car v) *tvc*))) ;; (setf (var-mt (car v)) (type-or1 (var-mt (car v)) (cadr v)) ;; (var-tag (car v)) (caddr v)))))) ;; (add-info info (cadr args)) ;; (list 'catch info tag args)) ;; (defun c1catch (args &aux (info (make-info :type #t* :sp-change 1)) tag) ;; (incf *setjmps*) ;; (when (endp args) (too-few-args 'catch 1 0)) ;; (setq tag (c1expr (car args))) ;; (add-info info (cadr tag)) ;; (let (vl (nt (tmpsym))) ;; (dolist (v *vars*) (when (var-p v) ;; (push (list v (var-mt v) (var-tag v)) vl) ;; (setf (var-tag v) nt (var-mt v) (var-type v)))) ;; (setq args ;; (unwind-protect ;; (do (nargs) ;; ((not ;; (let* ((*catch-tags* (cons nt *catch-tags*)) ;; (nv (with-restore-vars ;; (catch nt ;; (setq nargs (c1progn (cdr args))) nil)))) ;; (when nv ;; (do nil ((not (setq nv (pop *tvc*))) t) (setf (var-type nv) (var-mt nv)))))) ;; nargs)) ;; (dolist (v vl) ;; (when (caddr v) ;; (unless (type>= (cadr v) (var-mt (car v))) ;; (pushnew (car v) *tvc*))) ;; (setf (var-mt (car v)) (type-or1 (var-mt (car v)) (cadr v)) ;; (var-tag (car v)) (caddr v)))))) ;; (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) (add-libc "setjmp") (setq *frame-used* t) (wt-nl "frs_push(FRS_CATCH," loc ");")) (defun c1unwind-protect (args &aux (info (make-info :sp-change 1)) form) (incf *setjmps*) (when (endp args) (too-few-args 'unwind-protect 1 0)) (setq form (let ((*blocks* (cons 'lb *blocks*)) (*tags* (cons 'lb *tags*)) (*funs* (cons 'lb *funs*)) (*vars* (cons 'lb *vars*))) (c1expr (car args)))) (or-ccb-assignments (list form)) (add-info info (cadr form)) (setf (info-type info) (info-type (cadr form))) (setq args (c1arg (cons 'progn (cdr args)))) (add-info info (cadr args)) (list 'unwind-protect info form args)) ;; (defun c1unwind-protect (args &aux (info (make-info :sp-change 1)) form) ;; (incf *setjmps*) ;; (when (endp args) (too-few-args 'unwind-protect 1 0)) ;; (setq form (let ((*blocks* (cons 'lb *blocks*)) ;; (*tags* (cons 'lb *tags*)) ;; (*funs* (cons 'lb *funs*)) ;; (*vars* (cons 'lb *vars*))) ;; (c1arg (car args)))) ;; (add-info info (cadr form)) ;; (setq args (c1progn (cdr args))) ;; (add-info info (cadr args)) ;; (list 'unwind-protect info form args)) ;; (defun c1unwind-protect (args &aux (info (make-info :sp-change 1)) form) ;; (incf *setjmps*) ;; (when (endp args) (too-few-args 'unwind-protect 1 0)) ;; (setq form (let ((*blocks* (cons 'lb *blocks*)) ;; (*tags* (cons 'lb *tags*)) ;; (*funs* (cons 'lb *funs*)) ;; (*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 (add-libc "setjmp") (setq *frame-used* t) (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_basec.c_cdr) vs_push(p->c.c_car);") (wt-nl "if (active) {") (wt-nl "unwind(fr,tag);") (unwind-exit nil) (wt-nl "} else {") (unwind-exit 'fun-val nil (if top-data (car top-data))) (wt "}}")) (defun c1no-value (args) (declare (ignore args)) (let ((f (copy-tree (c1nil)))) (setf (cadr f) (make-info :type #tnil)) f)) (si::putprop 'si::no-value 'c1no-value 'c1) (defun c1throw (args &aux (info (make-info :type #tnil :flags (iflags side-effects))) tag) (when (or (endp args) (endp (cdr args))) (too-few-args 'throw 2 (length args))) (unless (endp (cddr args)) (too-many-args 'throw 2 (length args))) (setq tag (c1arg (car args))) (add-info info (cadr tag)) (setq args (c1arg (cadr args))) (add-info info (cadr args)) (list 'throw info tag args)) ;; (defun c1throw (args &aux (info (make-info :type #tnil :flags (iflags side-effects))) tag) ;; (when (or (endp args) (endp (cdr args))) ;; (too-few-args 'throw 2 (length args))) ;; (unless (endp (cddr args)) ;; (too-many-args 'throw 2 (length args))) ;; (setq tag (c1expr (car args))) ;; (add-info info (cadr tag)) ;; (setq args (c1expr (cadr args))) ;; (add-info info (cadr args)) ;; (list 'throw info tag args)) (defun c2throw (tag val &aux (*vs* *vs*) loc) (wt-nl "{frame_ptr fr;") (case (car tag) (LOCATION (setq loc (caddr tag))) (VAR (setq loc (cons 'var (third tag)))) (t (setq loc (list 'vs (vs-push))) (let ((*value-to-go* loc)) (c2expr* tag)))) (wt-nl "fr=frs_sch_catch(" loc ");") (wt-nl "if(fr==NULL) FEerror(\"The tag ~s is undefined.\",1," loc ");") (let ((*value-to-go* 'top)) (c2expr* val)) (wt-nl "unwind(fr," loc ");") (unwind-exit nil) (wt-nl "}")) gcl27-2.7.0/cmpnew/gcl_cmpenv.lsp000077500000000000000000000727371454061450500166130ustar00rootroot00000000000000;;; CMPENV Environments of the Compiler. ;;; ;; 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) ;;; Only these flags are set by the user. ;;; If *safe-compile* is ON, some kind of run-time checks are not ;;; included in the compiled code. The default value is OFF. (defvar *dlinks* (make-hash-table :test 'equal)) (defun init-env () (setq *tmpsyms* +tmpsyms+) (setq *gensym-counter* 0) (setq *next-cvar* 0) (setq *next-cmacro* 0) (setq *next-vv* -1) (setq *next-cfun* 0) (setq *last-label* 0) (setq *src-hash* (make-hash-table :test 'eq)) (setq *fn-src-fn* (make-hash-table :test 'eq)) (setq *objects* (make-hash-table :test 'eq)) (setq *dlinks* (make-hash-table :test 'equal)) (setq *local-funs* nil) (setq *hash-eq* nil) (setq *global-funs* nil) (setq *global-entries* nil) (setq *undefined-vars* nil) (setq *reservations* nil) (setq *top-level-forms* nil) (setq *function-declarations* nil) (setq *inline-functions* nil) (setq *function-links* nil) (setq *inline-blocks* 0) (setq *notinline* nil) ) (defvar *next-cvar* 0) (defvar *next-cmacro* 0) (defvar *next-vv* -1) (defvar *next-cfun* 0) (defvar *tmp-pack* nil) ;;; *next-cvar* holds the last cvar number used. ;;; *next-cmacro* holds the last cmacro number used. ;;; *next-vv* holds the last VV index used. ;;; *next-cfun* holds the last cfun used. (defmacro next-cfun () '(incf *next-cfun*)) (defun add-libc (x) (add-dladdress (strcat "dl" x) (mdlsym x))) (defun add-dladdress (n l) (unless (gethash n *dlinks*) (wt-h "static void *" n #+static"=" #+static(symbol-name l) ";") (setf (gethash n *dlinks*) t) (add-init `(si::mdl ',(symbol-name l) ',(package-name (symbol-package l)) ,(add-address (concatenate 'string "&" n)))))) (defun add-symbol (symbol) (add-object symbol)) (defun add-object2 (object) (let* ((init (if (when (consp object) (eq (car object) '|#,|)) (cdr object) `',object)) (object (if (when (consp init) (eq (car init) 'nani)) (nani (cadr init)) object))) (cond ((gethash object *objects*)) ((push-data-incf nil) (when init (add-init `(setvv ,*next-vv* ,init))) (setf (gethash object *objects*) *next-vv*))))) ;; Write to a string with all the *print-.. levels bound appropriately. (defun wt-to-string (x &aux (*compiler-output-data* (make-string-output-stream)) *fasd-data*) (wt-data1 x) (get-output-stream-string *compiler-output-data*)) (defun nani-eq (x y) (and (consp x) (consp y) (eq (car x) 'si::nani) (eq (car y) 'si::nani) (eq (cadr x) (cadr y)))) (defun add-object (object) (cond ((ltvp object) object) ((and *compiler-compile* (not *keep-gaz*)) (cons '|#,| `(nani ,(address object)))) (object))) (defun add-constant (symbol) (add-object (cons '|#,| symbol))) (defmacro next-cvar () '(incf *next-cvar*)) (defmacro next-cmacro () '(incf *next-cmacro*)) ;;; Tail recursion information. (defvar *do-tail-recursion* t) ;(defvar *tail-recursion-info* nil) ;;; Tail recursion optimization never occurs if *do-tail-recursion* is NIL. ;;; *tail-recursion-info* holds NIL, if tail recursion is impossible. ;;; If possible, *tail-recursion-info* holds ;;; ( fname required-arg .... required-arg ), ;;; where each required-arg is a var-object. (defvar *function-declarations* nil) ;;; *function-declarations* holds : ;;; (... ( { function-name | fun-object } arg-types return-type ) ...) ;;; Function declarations for global functions are ASSOCed by function names, ;;; whereas those for local functions are ASSOCed by function objects. ;;; ;;; The valid argment type declaration is: ;;; ( {type}* [ &optional {type}* ] [ &rest type ] [ &key {type}* ] ) ;;; though &optional, &rest, and &key return types are simply ignored. ;; (defmacro t-to-nil (x) (let ((s (tmpsym))) `(let ((,s ,x)) (if (eq ,s t) nil ,s)))) ;; (defmacro nil-to-t (x) `(or ,x t)) (defun is-global-arg-type (x) (let ((x (promoted-c-type x))) (or (equal x #tt) (member x +c-global-arg-types+)))) (defun is-local-arg-type (x) (let ((x (promoted-c-type x))) (or (equal x #tt) (member x +c-local-arg-types+)))) (defun is-local-var-type (x) (let ((x (promoted-c-type x))) (or (equal x #tt) (member x +c-local-var-types+)))) ;; (defun coerce-to-one-value (type) ;; (or (not type) (type-and type t))) (defun readable-tp (x) (cmp-unnorm-tp (cmp-norm-tp x))) (defun function-arg-types (arg-types) (mapcar 'readable-tp arg-types)) ;; (defun function-arg-types (arg-types &aux vararg (types nil) result) ;; (setq result ;; (do ((al arg-types (cdr al)) ;; (i 0 (the fixnum (+ 1 i)))) ;; ((endp al) ;; (reverse types)) ;; (declare (fixnum i)) ;; (cond ((or (member (car al) '(&optional &rest &key)) ;; (equal (car al) '* )) ;; (setq vararg t) ;; (return (reverse (cons '* types))))) ;; ;; only the first 9 args may have proclaimed type different from T ;; (push (cond ;; ((< i 9) ;; (let ((tem ;; (type-filter (car al)))) ;; (if (is-local-arg-type tem) (nil-to-t (car al)) t)));FIXME ;; (t (if (eq (car al) '*) '* t))) ;; types))) ;; ;;only type t args for var arg so far. ;; (cond (vararg (do ((v result (cdr v))) ;; ((null v)) ;; (setf (car v) (if (eq (car v) '*) '* t))))) ;; result) ;;; The valid return type declaration is: ;;; (( VALUES {type}* )) or ( {type}* ). (defun function-return-type (return-types) (cond ((endp return-types) nil) ((cmpt return-types) (cmp-norm-tp `(,(car return-types) ,@(function-return-type (cdr return-types))))) ((cmpt (car return-types)) (cmp-norm-tp `(,(caar return-types) ,@(function-return-type (cdar return-types))))) ((mapcar 'readable-tp return-types)))) (defun add-function-declaration (fname arg-types return-types) (cond ((symbolp fname) (push (list (sch-local-fun fname) (function-arg-types arg-types) (function-return-type return-types)) *function-declarations*)) (t (warn "The function name ~s is not a symbol." fname)))) (defun get-arg-types (fname &aux x) (cond ((setq x (assoc fname *function-declarations*)) (mapcar 'cmp-norm-tp (cadr x))) ((setq x (local-fun-p fname)) (caar (fun-call x))) ((setq x (gethash fname *sigs*)) (caar x)) ((setq x (si::sig fname)) (car x)) ((setq x (when (symbolp fname) (get fname 'proclaimed-signature))) (car x)) ('(*)))) (defun get-return-type (fname &aux x) (cond ((setq x (assoc fname *function-declarations*)) (cmp-norm-tp (caddr x))) ((setq x (local-fun-p fname)) (cadar (fun-call x))) ((setq x (gethash fname *sigs*)) (cadar x)) ((setq x (si::sig fname)) (cadr x)) ((setq x (when (symbolp fname) (get fname 'proclaimed-signature))) (cadr x)) ('*))) (defun get-sig (fname) (list (get-arg-types fname) (get-return-type fname))) (defun cclosure-p (fname) (not (let ((x (or (fifth (gethash fname *sigs*)) (si::props fname)))) (when x (logbitp 0 x))))) (defun get-local-arg-types (fun &aux x) (if (setq x (assoc fun *function-declarations*)) (cadr x) nil)) (defun get-local-return-type (fun &aux x) (if (setq x (assoc fun *function-declarations*)) (caddr x) nil)) (defvar *vs-base-ori-used* nil) (defvar *sup-used* nil) (defvar *base-used* nil) (defvar *frame-used* nil) (defvar *bds-used* nil) (defun reset-top () (wt-nl "vs_top=sup;") (setq *sup-used* t)) (defmacro base-used () '(setq *base-used* t)) ;;; Proclamation and declaration handling. (defvar *alien-declarations* nil) (defvar *inline* nil) (defvar *notinline* nil) (defun inline-asserted (fname) (unless *compiler-push-events* (or (member fname *inline*) (local-fun-fn fname) (get fname 'cmp-inline) (member (symbol-package fname) (load-time-value (mapcar 'find-package '(:s |libm| |libc| |libgmp|))))))) ;; (defun inline-asserted (fname) ;; (unless *compiler-push-events* ;; (or ;; (member fname *inline*) ;; (local-fun-fn fname) ;; (get fname 'cmp-inline)))) ;; (defun inline-asserted (fname) ;; (unless *compiler-push-events* ;; (or ;; (member fname *inline*) ;; (local-fun-fun fname) ;; (get fname 'cmp-inline)))) (defun inline-possible (fname) (cond ((eq fname 'funcall));FIXME ((eq fname 'apply));FIXME ((not (or *compiler-push-events* (member fname *notinline*) (get fname 'cmp-notinline)))))) ;; (defun inline-possible (fname) ;; (not (or *compiler-push-events* ;; (member fname *notinline*) ;; (get fname 'cmp-notinline)))) (defun max-vtp (tp) (coerce-to-one-value (cmp-norm-tp tp)));FIXME lose coerce? (defun body-safety (others &aux (*compiler-check-args* *compiler-check-args*) (*compiler-new-safety* *compiler-new-safety*) (*compiler-push-events* *compiler-push-events*) (*safe-compile* *safe-compile*)) (mapc (lambda (x) (when (eq (car x) 'optimize) (local-compile-decls (cdr x)))) others) (this-safety-level)) (defun c1body (body doc-p &aux ss is ts others cps) (multiple-value-bind (doc decls ctps body) (parse-body-header body (unless doc-p "")) (dolist (decl decls) (dolist (decl (cdr decl)) (cmpck (not (consp decl)) "The declaration ~s is illegal." decl) (let ((dtype (car decl))) (if (consp dtype) (let* ((dtype (max-vtp dtype)) (stype (if (consp dtype) (car dtype) dtype))) (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))) ((optimize ftype inline notinline) (push decl others)) ((hint type) (cmpck (endp (cdr decl)) "The type declaration ~s is illegal." decl) (let ((type (max-vtp (cadr decl)))) (when type (dolist (var (cddr decl)) (cmpck (not (symbolp var)) "The type declaration ~s contains a non-symbol ~s." decl var) (cond ((unless (get var 'tmp) (eq stype 'hint)) (push (cons var type) cps) ;FIXME (push (cons var (global-type-bump type)) ts)) ((push (cons var type) ts))))))) (class (cmpck (cdddr decl) "The type declaration ~s is illegal." decl) (let ((type (max-vtp (or (caddr decl) (car decl))))) (when type (let ((var (cadr 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))) (otherwise (let ((type (unless (member stype *alien-declarations*) (max-vtp stype)))) (if (unless (eq type t) 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)) (push decl others)))))))))) (dolist (l ctps) (when (and (cadr l) (symbolp (cadr l))) (let ((tp (or (eq (car l) 'assert) (max-vtp (caddr l))))) (unless (eq tp t) (push (cons (cadr l) tp) cps))))) (let ((s (> (body-safety others) (if (top-level-src-p) 0 1)))) (when cps (unless s ; (setq body `((let ,(mapcar (lambda (x) (list (car x) (car x))) cps) ,@body))) (setq ts (nconc cps ts)))) (when ctps (setq body (nconc (if s ctps (mapcan (lambda (x) (when (eq (car x) 'assert) (list (cadr x)))) ctps)) body)))) (values body ss ts is others (when doc-p doc) cps))) ;; (defun c1body (body doc-p &aux ss is ts others cps) ;; (multiple-value-bind ;; (doc decls ctps body) ;; (parse-body-header body (unless doc-p "")) ;; (dolist (decl decls) ;; (dolist (decl (cdr decl)) ;; (cmpck (not (consp decl)) "The declaration ~s is illegal." decl) ;; (let ((dtype (car decl))) ;; (if (consp dtype) ;; (let* ((dtype (max-vtp dtype)) ;; (stype (if (consp dtype) (car dtype) dtype))) ;; (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))) ;; ((optimize ftype inline notinline) ;; (push decl others)) ;; ((hint type) ;; (cmpck (endp (cdr decl)) "The type declaration ~s is illegal." decl) ;; (let ((type (max-vtp (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))))) ;; (class ;; (cmpck (cdddr decl) "The type declaration ~s is illegal." decl) ;; (let ((type (max-vtp (or (caddr decl) (car decl))))) ;; (when type ;; (let ((var (cadr 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))) ;; (otherwise ;; (let ((type (max-vtp stype))) ;; (unless (eq type t) ;; (dolist (var (cdr decl)) ;; (cmpck (not (symbolp var)) "The type declaration ~s contains a non-symbol ~s." ;; decl var) ;; (push (cons var type) ts))))))))))) ;; (dolist (l ctps) ;; (when (and (cadr l) (symbolp (cadr l))) ;; (let ((tp (max-vtp (caddr l)))) ;; (unless (eq tp t) ;; (push (cons (cadr l) tp) cps))))) ;; (let ((s (> (effective-safety (mapcar (lambda (x) `(declare ,x)) others)) 0))) ;; (when cps ;; (unless s ;; ; (setq body `((let ,(mapcar (lambda (x) (list (car x) (car x))) cps) ,@body))) ;; (setq ts (nconc cps ts)))) ;; (when (and ctps s) ;; (setq body (nreconc ctps body)))) ;; (values body ss ts is others (when doc-p doc) cps))) ;; (defun c1body (body doc-p &aux ss is ts others cps) ;; (multiple-value-bind ;; (doc decls ctps body) ;; (parse-body-header body (unless doc-p "")) ;; (dolist (decl decls) ;; (dolist (decl (cdr decl)) ;; (cmpck (not (consp decl)) "The declaration ~s is illegal." decl) ;; (let ((dtype (car decl))) ;; (if (consp dtype) ;; (let* ((dtype (max-vtp dtype)) ;; (stype (if (consp dtype) (car dtype) dtype))) ;; (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))) ;; ((optimize ftype inline notinline) ;; (push decl others)) ;; ((hint type) ;; (cmpck (endp (cdr decl)) "The type declaration ~s is illegal." decl) ;; (let ((type (max-vtp (cadr decl)))) ;; (when type ;; (dolist (var (cddr decl)) ;; (cmpck (not (symbolp var)) "The type declaration ~s contains a non-symbol ~s." ;; decl var) ;; (cond ((eq stype 'hint) (push (cons var type) cps) ;; (push (cons var (global-type-bump type)) ts)) ;; ((push (cons var type) ts))))))) ;; (class ;; (cmpck (cdddr decl) "The type declaration ~s is illegal." decl) ;; (let ((type (max-vtp (or (caddr decl) (car decl))))) ;; (when type ;; (let ((var (cadr 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))) ;; (otherwise ;; (let ((type (max-vtp stype))) ;; (unless (eq type t) ;; (dolist (var (cdr decl)) ;; (cmpck (not (symbolp var)) "The type declaration ~s contains a non-symbol ~s." ;; decl var) ;; (push (cons var type) ts))))))))))) ;; (dolist (l ctps) ;; (when (and (cadr l) (symbolp (cadr l))) ;; (let ((tp (max-vtp (caddr l)))) ;; (unless (eq tp t) ;; (push (cons (cadr l) tp) cps))))) ;; (let ((s (> (effective-safety (mapcar (lambda (x) `(declare ,x)) others)) 0))) ;; (when cps ;; (unless s ;; ; (setq body `((let ,(mapcar (lambda (x) (list (car x) (car x))) cps) ,@body))) ;; (setq ts (nconc cps ts)))) ;; (when (and ctps s) ;; (setq body (nreconc ctps body)))) ;; (values body ss ts is others (when doc-p doc) cps))) (defun c1decl-body (decls body &aux dl) (let ((*function-declarations* *function-declarations*) (*alien-declarations* *alien-declarations*) (*notinline* *notinline*) (*inline* *inline*) (*space* *space*) (*compiler-check-args* *compiler-check-args*) (*compiler-new-safety* *compiler-new-safety*) (*compiler-push-events* *compiler-push-events*) (*safe-compile* *safe-compile*)) (dolist (decl decls dl) (case (car decl) (optimize (dolist (d (cdr decl)) (push d dl)) (local-compile-decls (cdr decl))) (ftype (if (or (endp (cdr decl)) (not (consp (cadr decl))) (not (eq (caadr decl) 'function)) (endp (cdadr decl))) (cmpwarn "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)))) (cmpwarn "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) (pushnew fun *inline*) (setq *notinline* (remove fun *notinline*))) (cmpwarn "The function name ~s is not a symbol." fun)))) (notinline (dolist (fun (cdr decl)) (if (symbolp fun) (progn (push (list 'notinline fun) dl) (pushnew fun *notinline*) (setq *inline* (remove fun *inline*))) (cmpwarn "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*)) (cmpwarn "The declaration specifier ~s is not a symbol." x)))) (otherwise (unless (member (car decl) *alien-declarations*) (cmpwarn "The declaration specifier ~s is unknown." (car decl)))))) (let ((c1b (c1progn body))) (cond ((null dl) c1b) ((unless *safe-compile* (member (car c1b) '(lit var))) c1b) ((eq (car c1b) 'decl-body) (setf (third c1b) (nunion dl (third c1b))) c1b) ((list 'decl-body (copy-info (cadr c1b)) dl c1b)))))) ;; (defun c1decl-body (decls body &aux dl) ;; (let ((*function-declarations* *function-declarations*) ;; (*alien-declarations* *alien-declarations*) ;; (*notinline* *notinline*) ;; (*inline* *inline*) ;; (*space* *space*) ;; (*compiler-check-args* *compiler-check-args*) ;; (*compiler-new-safety* *compiler-new-safety*) ;; (*compiler-push-events* *compiler-push-events*) ;; (*safe-compile* *safe-compile*)) ;; (dolist (decl decls dl) ;; (case (car decl) ;; (optimize ;; (dolist (d (cdr decl)) (push d dl)) ;; (local-compile-decls (cdr decl))) ;; (ftype ;; (if (or (endp (cdr decl)) ;; (not (consp (cadr decl))) ;; (not (eq (caadr decl) 'function)) ;; (endp (cdadr decl))) ;; (cmpwarn "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)))) ;; (cmpwarn "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) ;; (pushnew fun *inline*) ;; (setq *notinline* (remove fun *notinline*))) ;; (cmpwarn "The function name ~s is not a symbol." fun)))) ;; (notinline ;; (dolist (fun (cdr decl)) ;; (if (symbolp fun) ;; (progn (push (list 'notinline fun) dl) ;; (pushnew fun *notinline*) ;; (setq *inline* (remove fun *inline*))) ;; (cmpwarn "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*)) ;; (cmpwarn "The declaration specifier ~s is not a symbol." ;; x)))) ;; (otherwise ;; (unless (member (car decl) *alien-declarations*) ;; (cmpwarn "The declaration specifier ~s is unknown." (car decl)))))) ;; (let ((c1b (c1progn body))) ;; (cond ((null dl) c1b) ;; ((unless *safe-compile* (eq (car c1b) 'lit)) c1b) ;; ((eq (car c1b) 'decl-body) (setf (third c1b) (nunion dl (third c1b))) c1b) ;; ((list 'decl-body (copy-info (cadr c1b)) dl c1b)))))) ;; (defun c1decl-body (decls body &aux (dl nil)) ;; (if (null decls) ;; (c1progn body) ;; (let ((*function-declarations* *function-declarations*) ;; (*alien-declarations* *alien-declarations*) ;; (*notinline* *notinline*) ;; (*inline* *inline*) ;; (*space* *space*) ;; (*compiler-check-args* *compiler-check-args*) ;; (*compiler-new-safety* *compiler-new-safety*) ;; (*compiler-push-events* *compiler-push-events*) ;; (*safe-compile* *safe-compile*)) ;; (dolist (decl decls dl) ;; (case (car decl) ;; (optimize ;; (dolist (d (cdr decl)) (push d dl)) ;; (local-compile-decls (cdr decl))) ;; (ftype ;; (if (or (endp (cdr decl)) ;; (not (consp (cadr decl))) ;; (not (eq (caadr decl) 'function)) ;; (endp (cdadr decl))) ;; (cmpwarn "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)))) ;; (cmpwarn "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) ;; (pushnew fun *inline*) ;; (setq *notinline* (remove fun *notinline*))) ;; (cmpwarn "The function name ~s is not a symbol." fun)))) ;; (notinline ;; (dolist (fun (cdr decl)) ;; (if (symbolp fun) ;; (progn (push (list 'notinline fun) dl) ;; (pushnew fun *notinline*) ;; (setq *inline* (remove fun *inline*))) ;; (cmpwarn "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*)) ;; (cmpwarn "The declaration specifier ~s is not a symbol." ;; x)))) ;; (otherwise ;; (unless (member (car decl) *alien-declarations*) ;; (cmpwarn "The declaration specifier ~s is unknown." (car decl)))))) ;; (setq body (c1progn body)) ;; (cond ((null dl) body) ;; ((eq (car body) 'decl-body) (setf (third body) (nunion dl (third body))) body) ;; ((list 'decl-body (copy-info (cadr body)) dl body)))))) (si:putprop 'decl-body 'c2decl-body 'c2) (defun local-compile-decls (decls) (dolist (decl decls) (unless (consp decl) (setq decl (list decl 3))) (case (car decl) (debug (setq *debug* (cadr decl))) (safety (let* ((tl (this-safety-level))(level (if (>= tl 3) tl (cadr decl)))) (declare (fixnum level)) (when (top-level-src-p) (setq *compiler-check-args* (>= level 1) *safe-compile* (>= level 2) *compiler-new-safety* (>= level 3) *compiler-push-events* (>= level 4)))));FIXME (space (setq *space* (cadr decl))) (notinline (push (cadr decl) *notinline*)) (speed) ;;FIXME (compilation-speed) ;;FIXME (inline (setq *notinline* (remove (cadr decl) *notinline*))) (otherwise (baboon))))) ;; (defun local-compile-decls (decls) ;; (dolist (decl decls) ;; (unless (consp decl) (setq decl (list decl 3))) ;; (case (car decl) ;; (debug (setq *debug* (cadr decl))) ;; (safety ;; (let ((level (cadr decl))) ;; (declare (fixnum level)) ;; (setq *compiler-check-args* (or *compiler-check-args* (>= level 1)) ;; *safe-compile* (or *safe-compile* (>= level 2)) ;; *compiler-new-safety* (or *compiler-new-safety* (>= level 3)) ;; *compiler-push-events* (or *compiler-push-events* (>= level 4)))));FIXME ;; (space (setq *space* (cadr decl))) ;; (notinline (push (cadr decl) *notinline*)) ;; (speed) ;;FIXME ;; (compilation-speed) ;;FIXME ;; (inline (setq *notinline* (remove (cadr decl) *notinline*))) ;; (otherwise (baboon))))) (defun c2decl-body (decls body) (let ((*compiler-check-args* *compiler-check-args*) (*safe-compile* *safe-compile*) (*compiler-push-events* *compiler-push-events*) (*compiler-new-safety* *compiler-new-safety*) (*notinline* *notinline*) (*space* *space*) (*debug* *debug*)) (local-compile-decls decls) (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)))) gcl27-2.7.0/cmpnew/gcl_cmpeval.lsp000077500000000000000000003177141454061450500167470ustar00rootroot00000000000000;;; 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) :si) (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 readable-val (val) (cond ((not (arrayp val))) ((not (si::staticp val))))) (defun setq-p (form l) (cond ((eq form l)) ((atom form) nil) ((or (setq-p (car form) l) (setq-p (cdr form) l))))) (defun atomic-type-constant-value (atp &aux (a (car atp))) (when atp (typecase a ((or function cons array)) (otherwise (c1constant-value a (when (symbolp a) (symbol-package a))))))) ;; (defun atomic-type-constant-value (atp &aux (a (car atp))) ;; (when atp ;; (typecase ;; a ;; ((or function cons array)) ;; (otherwise ;; (unless (eq a +opaque+) ;; (if (when (symbolp a) (get a 'tmp)) ;FIXME cdr ;; (let ((a (get-var a))) ;; (when a (c1var a))) ;; (c1constant-value a (when (symbolp a) (symbol-package a))))))))) ;; (defun atomic-type-constant-value (atp &aux (a (car atp))) ;; (when atp ;; (typecase ;; a ;; ((or function cons array)) ;; (otherwise (c1constant-value a (when (symbolp a) (symbol-package a))))))) (defun c1expr-avct (res) (or (when (ignorable-form res) (atomic-type-constant-value (atomic-tp (info-type (cadr res))))) res)) (defun c1expr (form) (setq form (catch *cmperr-tag* (cond ((symbolp form) (cond ((constantp form) (let ((val (symbol-value form))) (or (c1constant-value val nil) `(location ,(make-info :type (object-type val)) (VV ,(add-constant form)))))) ; ((c1var form)))) ((c1expr-avct (c1var form))))) ;FIXME pcl ((consp form) (let ((fun (car form))) (c1expr-avct (cond ((symbolp fun) (c1symbol-fun form)) ((and (consp fun) (eq (car fun) 'lambda)) (c1symbol-fun (cons 'funcall 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)) ;; (defun c1expr (form) ;; (setq form (catch *cmperr-tag* ;; (cond ((symbolp form) ;; (cond ((constantp form) ;; (let ((val (symbol-value form))) ;; (or ;; (c1constant-value val nil) ;; `(location ,(make-info :type (object-type val)) (VV ,(add-constant form)))))) ;; ((c1var form)))) ;; ; ((c1expr-avct (c1var form))))) ;FIXME pcl ;; ((consp form) ;; (let ((fun (car form))) ;; (c1expr-avct (cond ((symbolp fun) ;; (c1symbol-fun form)) ;; ((and (consp fun) (eq (car fun) 'lambda)) ;; (c1symbol-fun (cons 'funcall 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)) ;; (defun c1expr (form) ;; (setq form (catch *cmperr-tag* ;; (cond ((symbolp form) ;; (cond ((constantp form) ;; (let ((val (symbol-value form))) ;; (or ;; (c1constant-value val nil) ;; `(location ,(make-info :type (object-type val)) (VV ,(add-constant form)))))) ;; ((c1var form)))) ;; ((consp form) ;; (let* ((fun (car form)) ;; (res (cond ((symbolp fun) ;; (c1symbol-fun form)) ;; ((and (consp fun) (eq (car fun) 'lambda)) ;; (c1symbol-fun (cons 'funcall 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)))) ;; (atp (atomic-tp (info-type (cadr res))))) ;; (or (when (ignorable-form res) (atomic-type-constant-value atp)) res))) ;; (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))));FIXME double cmp-eval with c1constant-value (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) ;; (eval (cons 'si::define-structure arg)) ;; (add-object2 (cons '|#,| (cons 'si::define-structure arg))) ;; nil) (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'. (inline-types-function itf) ;; car of ii is a function returning match info (sets-vs-top svt) (normalized-types nt) (apply-arg aa))) (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)) (defmacro flag-or (n flag) `(logior ,(ash 1 (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)))) (when (listp (car opt)) (unless (flag-p (caddr opt) nt) (let ((s (unique-sigs (list (mapcar 'cmp-norm-tp (car opt)) (cmp-norm-tp (cadr opt)))))) (setf (car opt) (car s) (cadr opt) (cadr s) (caddr opt) (logior (caddr opt) (flags nt)))))) 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) (when (and (or (not *compiler-new-safety*) (member f '(unbox box))));FIXME (let* ((be (get f 'type-propagator)) (ba (and be ;(si::dt-apply be (cons f (mapcar 'coerce-to-one-valuea args))))));FIXME (apply be (cons f (mapcar 'coerce-to-one-value args))))));FIXME (when ba (return-from result-type-from-args ba))) (dolist (v '(inline-always inline-unsafe)) (let* ((w (get f v))) (if (and w (symbolp (caar w)) (flag-p (third (car w)) itf)) (return-from result-type-from-args (cadr (apply (caar w) args))) (dolist (w w) (fix-opt w) (when (and (flag-p (third w) result-type-from-args) (>= (length args) (- (length (car w)) (length (member '* (car w))))) (do ((a args (cdr a)) (b (car w) (if (and (eq (cadr b) '*) (endp (cddr b))) b (cdr b)))) ((null a) t) (unless (and (car a) (car b) (type>= (car b) (car a))) (return nil)))) (return-from result-type-from-args (second w))))))))) ;; (defun result-type-from-args (f args) ;; (when (and (or (not *compiler-new-safety*) (member f '(unbox box))));FIXME ;; (let* ((be (get f 'type-propagator)) ;; (ba (and be ;(si::dt-apply be (cons f (mapcar 'coerce-to-one-valuea args))))));FIXME ;; (apply be (cons f (mapcar 'coerce-to-one-value args))))));FIXME ;; (when ba ;; (return-from result-type-from-args (cmp-norm-tp ba)))) ;; (dolist (v '(inline-always inline-unsafe)) ;; (let* ((w (get f v))) ;; (if (and w (symbolp (caar w)) (flag-p (third (car w)) itf)) ;; (return-from result-type-from-args (cadr (apply (caar w) args))) ;; (dolist (w w) ;; (fix-opt w) ;; (when (and ;; (flag-p (third w) result-type-from-args) ;; (>= (length args) (- (length (car w)) (length (member '* (car w))))) ;; (do ((a args (cdr a)) ;; (b (car w) (if (and (eq (cadr b) '*) (endp (cddr b))) b (cdr b)))) ;; ((null a) t) ;; (unless (and (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 arg-appears (x y dep) ; (cond ((atom y) nil) ; ((consp (car y)) ; (or (arg-appears x (cdar y) t) (arg-appears x (cdr y) dep))) ; (t ; (or (and (eq x (car y)) dep) ; (arg-appears x (cdr y) dep))))) (defun cons-to-right (x) (and x (or (consp (car x)) (cons-to-right (cdr x))))) (defun needs-pre-eval (x) (or (and (consp (car x)) (not (eq (caar x) 'quote))) (and (atom (car x)) (not (constantp (car x))) (cons-to-right (cdr x))))) ; (arg-appears (car x) (cdr x) nil)))) (defun bind-before-cons (x y) (and y (consp (car y)) (atom (cadar y)) (if (eq x (cadar y)) (caar y) (bind-before-cons x (cdr y))))) (defun pull-evals-int (x form lets) (if (atom x) (list (nreverse form) (nreverse lets)) (let* ((s (if (needs-pre-eval x) (bind-before-cons (car x) lets) (car x))) (lets (if s lets (cons (list (tmpsym) (car x)) lets))) (s (or s (caar lets)))) (pull-evals-int (cdr x) (cons s form) lets)))) (defun pull-evals (form) (let ((form (pull-evals-int (cdr form) (list (car form)) nil))) (values (car form) (cadr form)))) (defun binary-nest-int (form len) (declare (fixnum len) (list form)) (if (> len 3) (binary-nest-int (cons (car form) (cons (list (car form) (cadr form) (caddr form)) (cdddr form))) (1- len)) form)) (defmacro let-wrap (lets form) `(if ,lets (list 'let* ,lets ,form) ,form)) (defun binary-nest (form env) (declare (ignore env)) (let ((len (length form))) (declare (fixnum len)) (if (> len 3) (let-wrap nil (binary-nest-int form len)) ;; (multiple-value-bind (form lets) (values form nil);(pull-evals form) ;; (let-wrap lets (binary-nest-int form len))) form))) (si::putprop '* 'binary-nest 'si::compiler-macro-prop) (si::putprop '+ 'binary-nest 'si::compiler-macro-prop) (si::putprop 'logand 'binary-nest 'si::compiler-macro-prop) (si::putprop 'logior 'binary-nest 'si::compiler-macro-prop) (si::putprop 'logxor 'binary-nest 'si::compiler-macro-prop) (si::putprop 'max 'binary-nest 'si::compiler-macro-prop) (si::putprop 'min 'binary-nest 'si::compiler-macro-prop) (si::putprop 'gcd 'binary-nest 'si::compiler-macro-prop) (si::putprop 'lcm 'binary-nest 'si::compiler-macro-prop) (si::putprop '- 'binary-nest 'si::compiler-macro-prop) (si::putprop '/ 'binary-nest 'si::compiler-macro-prop) (defun multiple-value-bind-expander (form env) (declare (ignore env)) (if (and (consp (caddr form)) (eq (caaddr form) 'values)) (let ((l1 (length (cadr form))) (l2 (length (cdaddr form)))) `(let (,@(mapcar 'list (cadr form) (cdaddr form)) ,@(when (> l1 l2) (nthcdr l2 (cadr form)))) ,@(when (> l2 l1) (nthcdr l1 (cdaddr form))) ,@(cdddr form))) form)) (si::putprop 'multiple-value-bind 'multiple-value-bind-expander 'si::compiler-macro-prop) ;FIXME apply-expander ;; (defun funcall-expander (form env &aux x);FIXME inlinable-fn? ;; (declare (ignore env)) ;; (cond ((and (consp (cadr form)) (eq (caadr form) 'lambda)) (cdr form)) ;; ((and (consp (cadr form)) (eq (caadr form) 'function) ;; (setq x (si::funid-p (cadadr form)))) ;; `(,x ,@(cddr form))) ;; ((constantp (cadr form)) `(,(cmp-eval (cadr form)) ,@(cddr form))) ;; (form))) ;; (si::putprop 'funcall 'funcall-expander 'si::compiler-macro-prop) (defun logical-binary-nest (form env) (declare (ignore env)) (if (> (length form) 3) (multiple-value-bind (form lets) (pull-evals form) (let (r) (do ((f (cdr form) (cdr f))) ((null (cdr f)) (let-wrap lets (cons 'and (nreverse r)))) (push (list (car form) (car f) (cadr f)) r)))) form)) (si::putprop '> 'logical-binary-nest 'si::compiler-macro-prop) (si::putprop '>= 'logical-binary-nest 'si::compiler-macro-prop) (si::putprop '< 'logical-binary-nest 'si::compiler-macro-prop) (si::putprop '<= 'logical-binary-nest 'si::compiler-macro-prop) (si::putprop '= 'logical-binary-nest 'si::compiler-macro-prop) (si::putprop 'char> 'logical-binary-nest 'si::compiler-macro-prop) (si::putprop 'char>= 'logical-binary-nest 'si::compiler-macro-prop) (si::putprop 'char< 'logical-binary-nest 'si::compiler-macro-prop) (si::putprop 'char<= 'logical-binary-nest 'si::compiler-macro-prop) (si::putprop 'char= 'logical-binary-nest 'si::compiler-macro-prop) (defun logical-outer-nest (form env) (declare (ignore env)) (if (> (length form) 3) (multiple-value-bind (form lets) (pull-evals form) (let (r) (do ((f (cdr form) (cdr f))) ((null (cdr f)) (let-wrap lets (cons 'and (nreverse r)))) (do ((g (cdr f) (cdr g))) ((null g)) (push (list (car form) (car f) (car g)) r))))) form)) (si::putprop '/= 'logical-outer-nest 'si::compiler-macro-prop) (si::putprop 'char/= 'logical-outer-nest 'si::compiler-macro-prop) (defun incr-to-plus (form env) (declare (ignore env)) `(+ ,(cadr form) 1)) (defun decr-to-minus (form env) (declare (ignore env)) `(- ,(cadr form) 1)) (si::putprop '1+ 'incr-to-plus 'si::compiler-macro-prop) (si::putprop '1- 'decr-to-minus 'si::compiler-macro-prop) (defun plusp-compiler-macro (form env) (declare (ignore env)) (if (and (cdr form) (endp (cddr form))) `(> ,(cadr form) 0) form)) (si::putprop 'plusp 'plusp-compiler-macro 'si::compiler-macro-prop) (defun minusp-compiler-macro (form env) (declare (ignore env)) (if (and (cdr form) (endp (cddr form))) `(< ,(cadr form) 0) form)) (si::putprop 'minusp 'minusp-compiler-macro 'si::compiler-macro-prop) (defun zerop-compiler-macro (form env) (declare (ignore env)) (if (and (cdr form) (endp (cddr form))) `(= ,(cadr form) 0) form)) (si::putprop 'zerop 'zerop-compiler-macro 'si::compiler-macro-prop) (defun local-aliases (var excl &aux (bind (get-vbind var)) res) (when bind (let ((e (member-if-not 'var-p *vars*))) (do ((x *vars* (cdr x))) ((eq x e) res) (let ((cx (car x))) (unless (member cx excl) (when (eq bind (get-vbind cx)) (push cx res)))))))) (defun c1infer-tp (args) (let* ((n (pop args)) (v (c1vref n)) (x (car v)) (tpi (ensure-known-type (pop args))) (tp (type-and (var-type x) tpi)) (l (local-aliases x nil)) (tp (reduce 'type-and l :key 'var-type :initial-value tp)) (l (mapc (lambda (x) (do-setq-tp x nil tp)) l)) (res (c1expr (car args))) (ri (cadr res))) (if (exit-to-fmla-p) (let ((info (make-info))) (add-info info ri) (setf (info-type info) (info-type ri)) `(infer-tp ,info ,l ,tpi ,res)) res))) (defun c2infer-tp (x tp fm) (declare (ignore x tp)) (c2expr fm)) (si::putprop 'infer-tp 'c1infer-tp 'c1) (si::putprop 'infer-tp 'c2infer-tp 'c2) (defconstant +cnum-tp-alist+ `((,#tfixnum . ,(c-type 0)) (,#tbignum . ,(c-type (1+ most-positive-fixnum))) (,#tratio . ,(c-type 1/2)) (,#tshort-float . ,(c-type 0.0s0)) (,#tlong-float . ,(c-type 0.0)) (,#tfcomplex . ,(1+ si::c-type-max)) (,#tdcomplex . ,(+ 2 si::c-type-max)) (,#t(complex rational) . ,(c-type #c(0 1))))) (defconstant +hash-index-type+ #t(or (integer -1 -1) seqind)) (defun identity-expander (form env) (declare (ignore env)) (if (cddr form) form (cadr form))) (si::putprop 'identity 'identity-expander 'si::compiler-macro-prop) ;; (defun seqind-wrap (form) ;; (if *safe-compile* ;; form ;; `(the seqind ,form))) (defun fboundp-expander (form env) (declare (ignore env)) `(si::fboundp-sym (si::funid-sym ,(cadr form)))) (si::putprop 'fboundp 'fboundp-expander 'si::compiler-macro-prop) ;; (defun maphash-expander (form env) ;; (declare (ignore env)) ;; (let ((block (tmpsym))(tag (gensym)) (ind (gensym)) (key (gensym)) (val (gensym))) ;; `(block ;; ,block ;; (let ((,ind -1)) ;; (declare (,+hash-index-type+ ,ind)) ;; (tagbody ;; ,tag ;; (when (< (setq ,ind (si::next-hash-table-index ,(caddr form) (1+ ,ind))) 0) ;; (return-from ,block)) ;; (let ((,key (si::hash-key-by-index ,(caddr form) ,ind)) ;; (,val (si::hash-entry-by-index ,(caddr form) ,ind))) ;; (funcall ,(cadr form) ,key ,val)) ;; (go ,tag)))))) ;; (si::putprop 'maphash 'maphash-expander 'si::compiler-macro-prop) ;; (defun array-row-major-index-expander (form env &optional (it 0)) ;; (declare (fixnum it)(ignorable env)) ;; (let ((l (length form))) ;; (cond ((= l 2) 0) ;; ((= l 3) (seqind-wrap (caddr form))) ;; (t (let ((it (1+ it)) ;; (fn (car form)) ;; (ar (cadr form)) ;; (first (seqind-wrap (caddr form))) ;; (second (seqind-wrap (cadddr form))) ;; (rest (cddddr form))) ;; (array-row-major-index-expander ;; `(,fn ,ar ,(seqind-wrap ;; `(+ ;; ,(seqind-wrap ;; `(* ,first (array-dimension ,ar ,it))) ,second)) ,@rest) ;; nil it)))))) ;;(si::putprop 'array-row-major-index 'array-row-major-index-expander 'si::compiler-macro-prop) ;; (defmacro with-pulled-array (bindings form &body body) ;FIXME ;; `(let ((,(car bindings) (cadr ,form))) ;; (let ((,(cadr bindings) `((,(tmpsym) ,,(car bindings))))) ;; (let ((,(caddr bindings) (or (caar ,(cadr bindings)) ,(car bindings)))) ;; ,@body)))) ;; (defun aref-expander (form env) ;; (declare (ignore env)) ;; (with-pulled-array ;; (ar lets sym) form ;; (let ((isym (tmpsym))) ;; (let ((lets (append lets `((,isym (array-row-major-index ,sym ,@(cddr form))))))) ;; (let-wrap lets `(compiler::cmp-aref ,sym ,isym)))))) ;; (si::putprop 'aref 'aref-expander 'si::compiler-macro-prop) ;; (si::putprop 'row-major-aref 'aref-expander 'si::compiler-macro-prop) ;; (defun aset-expander (form env) ;; (declare (ignore env)) ;; (let ((form (if (eq (car form) 'si::aset-wrap) form ;; (cons (car form) (append (cddr form) (list (cadr form)))))));FIXME ;; (with-pulled-array ;; (ar lets sym) form ;; (let ((isym (tmpsym))) ;; (let ((lets (append lets `((,isym (array-row-major-index ,sym ,@(butlast (cddr form)))))))) ;; (let-wrap lets `(compiler::cmp-aset ,sym ,isym ,(car (last form))))))))) ;; (si::putprop 'si::aset 'aset-expander 'si::compiler-macro-prop) ;; (si::putprop 'si::aset-wrap 'aset-expander 'si::compiler-macro-prop) ;FIXME -- test and install this and svref, CM 20050106 ;(si::putprop 'svset 'aset-expander 'si::compiler-macro-prop) ;; (defun array-dimension-expander (form env) ;; (declare (ignore env)) ;; (with-pulled-array ;; (ar lets sym) form ;; (let-wrap lets `(compiler::cmp-array-dimension ,sym ,(caddr form))))) ;;(si::putprop 'array-dimension 'array-dimension-expander 'si::compiler-macro-prop) (defmacro inlinable-fn (a) `(or (constantp ,a) (and (consp ,a) (member (car ,a) '(function lambda))))) (defun and-compiler-macro (form env) (declare (ignore env)) (cond ((endp (cdr form))) ((endp (cddr form)) (cadr form)) ((cmp-macroexpand form)))) ; (`(if ,(cadr form) ,(and-compiler-macro `(and ,@(cddr form)) nil))))) (si::putprop 'and 'and-compiler-macro 'si::compiler-macro-prop) (defun or-compiler-macro (form env) (declare (ignore env)) (cond ((endp (cdr form)) nil) ((endp (cddr form)) (cadr form)) ((cmp-macroexpand `(,(car form) ,(cadr form) (or ,@(cddr form))))))) (si::putprop 'or 'or-compiler-macro 'si::compiler-macro-prop) (defvar *basic-inlines* nil) (defun c1comment (args) (list 'comment (make-info :type nil) (with-output-to-string (s) (princ (car args) s)))) (defun c2comment (comment) (wt-nl "/*" comment "*/")) (si::putprop 'comment 'c1comment 'c1) (si::putprop 'comment 'c2comment 'c2) (defun c1inline (args env inls) (let* ((cl (pop args)) (fm (pop args)) (nargs (under-env env (c1let-* (cdr fm) t inls))) (s cl)) (assert (and (eq (car fm) 'let*) (not args))) (cond ((eq (car nargs) 'var) nargs) ((list 'inline (copy-info (cadr nargs)) s nargs))))) (defvar *annotate* nil) (defun c2inline (comment expr) (when *annotate* (wt-nl "/*")(princ comment *compiler-output1*)(wt "*/")) (c2expr expr) (when *annotate* (wt-nl "/* END ")(princ comment *compiler-output1*)(wt "*/"))) (si::putprop 'inline 'c1inline 'c1) (si::putprop 'inline 'c2inline 'c2) ;; (defun c1size (form) ;; (cond ((atom form) 0) ;; ((1+ (+ (c1size (car form)) (c1size (cdr form))))))) ;; (defvar *inline-forms* nil) ;; (defun copy-vars (form) ;; (cond ((var-p form) (setf (var-store form) (var-kind form))) ;; ((consp form) (copy-vars (car form)) (copy-vars (cdr form))))) ;; (defun set-vars (form) ;; (cond ((var-p form) (setf (var-kind form) (var-store form))) ;; ((consp form) (set-vars (car form)) (set-vars (cdr form))))) ;; (defun global-ref-p (form) ;; (cond ((and (var-p form) (member (var-kind form) '(global special)))) ;; ((atom form) nil) ;; ((or (global-ref-p (car form)) (global-ref-p (cdr form)))))) ;; (defun closure-p (form) ;; (and (eq (car form) 'function) ;; (eq (caaddr form) 'lambda) ;; (or (do-referred (s (cadr (caddr form))) ;; (unless (member s (caaddr (caddr form))) (return t))) ;; (global-ref-p form)))) ;; (defun vv-p (form) ;; (cond ((atom form) nil) ;; ((and (eq (car form) 'location) (listp (caddr form)) ;; (or (eq (caaddr form) 'vv) ;; (and (member (caaddr form) '(fixnum-value character-value long-float-value short-float-value fcomplex-value dcomplex-value)) ;; (cadr (caddr form)))))) ;; ((or (vv-p (car form)) (vv-p (cdr form)))))) ;;FIXME ;(dolist (l '(typep coerce constantly complement open load delete-package import compile compile-file ; error cerror warn break get-setf-method make-list)) ; (si::putprop l t 'cmp-no-src-inline)) ;; (defvar *prop-hash* nil) ; (make-hash-table :test 'equal)) (defvar *src-inline-recursion* nil) (defvar *prev-sri* nil) (defvar *src-hash* (make-hash-table :test 'eq)) ;; (defun src-inlineable (form) ;; (let ((n (car form))) ;; (and (symbolp n) ;; (not (get n 'cmp-no-src-inline)) ;; (fboundp n) ;; (or (gethash n *src-hash*) ;; (setf (gethash n *src-hash*) ;; (let ((fn (symbol-function n))) (when (functionp fn) (function-lambda-expression fn))))) ;; (or (inline-asserted n) ;; (eq (symbol-package n) (load-time-value (find-package 'c))) ;; (multiple-value-bind (s k) (find-symbol (symbol-name n) 'lisp) ;; (when (eq n s) (eq k :external))))))) ;; (defun mark-for-hash-inlining (fms) ;; (let ((i 0) ;; (c1t (c1t)) ;; (c1nil (c1nil))) ;; (mapl (lambda (x) ;; (when (car x) ;; (when (or (eq (car x) c1t) (eq (car x) c1nil)) ;; (setf (car x) (list (caar x) (copy-info (cadar x)) (caddar x)))) ;; (setf (info-unused1 (cadar x)) (incf i)))) fms))) ;; (defun inline-hasheable (form fms c1) ;; (let ((cp (member-if 'closure-p fms)) ;; (vvp (vv-p (if (eq (car (fourth c1)) 'let*) (cddddr (fourth c1)) c1))) ;; (rec (and (boundp '*recursion-detected*) (eq *recursion-detected* t)))) ;; (when cp (keyed-cmpnote 'inline-hash "not hashing ~s due to closure~%" form)) ;; (when vvp (keyed-cmpnote 'inline-hash "not hashing ~s due to vv objs~%" form)) ;; (when rec (keyed-cmpnote 'inline-hash "not hashing ~s due to recursion~%" form)) ;; (not (or cp vvp rec)))) ;; (defun info-form-alist (o n) ;; (mapcan (lambda (o) ;; (when o ;; (let ((n (car (member (info-unused1 (cadr o)) n :key (lambda (x) (when x (info-unused1 (cadr x)))))))) ;; (when n (list (cons o n)))))) o)) ;; (defun array-replace (x y z) ;; (do ((i 0 (1+ i))) ((>= i (length x))) ;; (when (eq y (aref x i)) ;; (setf (aref x i) z)))) ;; (defun info-replace-var (x y z) ;; (array-replace (info-referred-array x) y z) ;; (array-replace (info-changed-array x) y z)) ;; (defun info-replace-var (x y z) ;; (nsubst z y (info-ref x)) ;; (nsubst z y (info-ch x))) ;; (defun info-var-match (i v) ;; (or (is-referred v i) (is-changed v i))) ;; (defun collect-matching-vars (ov f) ;; (cond ((var-p f) (when (or (member f ov) (list-split (var-aliases f) ov)) (list f))) ;; ((info-p f) (let (r) ;; (dolist (ov ov r) ;; (when (info-var-match f ov) (push ov r))))) ;; ((atom f) nil) ;; ((nunion (collect-matching-vars ov (car f)) (collect-matching-vars ov (cdr f)))))) ;; (defun collect-matching-info (ov f) ;; (cond ((info-p f) (when (member-if (lambda (x) (info-var-match f x)) ov) (list f))) ;; ((atom f) nil) ;; ((nunion (collect-matching-info ov (car f)) (collect-matching-info ov (cdr f)))))) ;; (defun fms-fix (f fms) ;; (let* ((vv (collect-matching-vars (third f) fms)) ;; (ii (collect-matching-info vv fms)) ;; (nv (mapcar 'copy-var vv)) ;; (a (mapcar 'cons vv nv)) ;; (nv (mapc (lambda (x) (setf (var-aliases x) (sublis a (var-aliases x)))) nv)) ;; (ni (mapcar 'copy-info ii)) ;; (ni (mapc (lambda (x) (mapc (lambda (y z) (info-replace-var x y z)) vv nv)) ni))) ;; (sublis (nconc a (mapcar 'cons ii ni)) fms))) ;; (defun get-inline-h (form prop fms) ;; (let ((h (when *prop-hash* (gethash prop *prop-hash*)))) ;; (when h ;; (unless (acceptable-inline h form (cddr prop)) ;; (return-from get-inline-h (cons nil (cdr h)))) ;; (let* ((f (car h)) ;; (fms (fms-fix (fourth f) fms)) ;; (al (info-form-alist (car (last h)) fms)) ;; (nfs (mapcar 'cdr al)) ;; (oi (cadr f)) ;; (info (make-info)) ;; (al (cons (cons oi info) al)) ;; (al (cons (cons (caddr f) (with-output-to-string (s) (princ form s))) al))) ;; (set-vars f) ;; (setf (info-type info) (info-type oi)) ;; (dolist (l nfs) (add-info info (cadr l))) ;; (cons (sublis al f) (cdr h)))))) ;; (defun acceptable-inline (h form tpis) ;; (let* ((c1 (car h)) ;; (sz (cadr h)) ;; (d (and c1 ;; (inline-possible (car form)) ;; (or (< sz (* 1000 (- 3 (max 0 *space*)))) ;; (and (< *space* 3) (member-if (lambda (x) (and (atomic-tp (car x)) (functionp (cadar x)))) tpis)))))) ;; (if d ;; (keyed-cmpnote 'inline "inlining ~s ~s~%" form (not (not h))) ;; (keyed-cmpnote 'inline "not inlining ~s ~s ~s ~s~%" form sz (* 1000 (- 3 (max 0 *space*))) tpis)) ;; d)) ;; (defun fms-callees (fms) ;; (mapcan ;; (lambda (x) ;; (when (eq (car x) 'function) ;; (let ((fun (caaddr x))) ;; (when (fun-p fun) ;; (cadr (fun-call fun)))))) fms)) ;; (defun push-callees (fms) ;; (let ((fc (fms-callees fms))) ;; (setq *callees* (nunion *callees* fc :test 'eq :key 'car)))) ;; (defun bind-all-vars-int (form nf bindings) ;; (cond ((null form) ;; (list bindings (nreverse nf))) ;; ((consp (car form)) ;; (let ((lwf (bind-all-vars-int (cdar form) (list (caar form)) bindings))) ;; (bind-all-vars-int (cdr form) (cons (cadr lwf) nf) (car lwf)))) ;; (t ;; (let* ((sym (if (symbolp (car form)) (cdr (assoc (car form) bindings)) (car form))) ;; (bindings (if sym bindings (cons (cons (car form) (tmpsym)) bindings))) ;; (sym (or sym (cdar bindings)))) ;; (bind-all-vars-int (cdr form) (cons sym nf) bindings))))) ;; (defun bind-all-vars (form) ;; (if (atom form) form ;; (let ((res (bind-all-vars-int (cdr form) (list (car form)) nil))) ;; (if (car res) ;; (list 'let* (mapcar (lambda (x) (list (cdr x) (car x))) (nreverse (car res))) ;; (cadr res)) ;; (cadr res))))) ;; (defun if-protect-fun-inf (form env) ;; (declare (ignore env)) ;; (cons (car form) ;; (cons (cadr form) ;; (cons (bind-all-vars (caddr form)) ;; (if (cadddr form) (list (bind-all-vars (cadddr form)))))))) (defvar *in-inline* nil) ;(defvar *callees* nil) (defun maybe-reverse-type-prop (dt f) (unless (or *safe-compile* (when (consp f) (eq (car f) 'lit)));FIXME push-vbind/c1var copy (set-form-type f (coerce-to-one-value dt)))) ;; (defun maybe-reverse-type-prop (dt f) ;; (unless *safe-compile* ;; (set-form-type f dt))) (defun cll (fn) (car (member (sir-name fn) *src-inline-recursion* :key 'caar))) (defun inline-sym-src (n) (and (inline-possible n) (or (inline-asserted n) (get n 'consider-inline) (multiple-value-bind (s k) (find-symbol (symbol-name n) :cl) (when (eq n s) (eq k :external)))) (or (local-fun-src n) (let ((fn (when (fboundp n) (symbol-function n)))) (when (functionp fn) (unless (typep fn 'funcallable-std-instance);FIXME really just need to check/handle for closure (values (or (gethash fn *src-hash*) (setf (gethash fn *src-hash*) (function-lambda-expression fn)))))))))) ;; (defun inline-sym-src (n) ;; (and (inline-possible n) ;; (or (inline-asserted n) ;; (eq (symbol-package n) (load-time-value (find-package :c))) ;; (eq (symbol-package n) (load-time-value (find-package :libm))) ;; (eq (symbol-package n) (load-time-value (find-package :libc))) ;; (multiple-value-bind (s k) (find-symbol (symbol-name n) :cl) ;; (when (eq n s) (eq k :external)))) ;; (or (local-fun-src n) ;; (let ((fn (when (fboundp n) (symbol-function n)))) ;; (when (functionp fn) ;; (unless (typep fn 'generic-function) ;; (values (or (gethash fn *src-hash*) (setf (gethash fn *src-hash*) (function-lambda-expression fn)))))))))) ;; (defun inline-sym-src (n) ;; (and (inline-possible n) ;; (or (inline-asserted n) ;; (eq (symbol-package n) (load-time-value (find-package 'c))) ;; (eq (symbol-package n) (load-time-value (find-package "libm"))) ;; (eq (symbol-package n) (load-time-value (find-package "libc"))) ;; (multiple-value-bind (s k) (find-symbol (symbol-name n) 'lisp) ;; (when (eq n s) (eq k :external)))) ;; (or (local-fun-src n) ;; (let ((fn (when (fboundp n) (symbol-function n)))) ;; (when (functionp fn) (values (function-lambda-expression fn))))))) ;; (defun inline-sym-src (n) ;; (and (inline-possible n) ;; (or (inline-asserted n) ;; (eq (symbol-package n) (load-time-value (find-package 'c))) ;; (multiple-value-bind (s k) (find-symbol (symbol-name n) 'lisp) ;; (when (eq n s) (eq k :external)))) ;; (or (local-fun-src n) ;; (gethash n *src-hash*) ;; (setf (gethash n *src-hash*) ;; (let ((fn (when (fboundp n) (symbol-function n)))) ;; (when (functionp fn) (function-lambda-expression fn))))))) (defun inline-src (fn) (unless *compiler-new-safety* (when (> *speed* 0) (cond ((symbolp fn) (inline-sym-src fn)) ((functionp fn) (local-fun-src fn)) ((and (consp fn) (eq (car fn) 'lambda)) fn))))) (defun ttl-tag-src (src tag &optional block &aux (h (pop src)) (ll (pop src))) (multiple-value-bind (doc decls ctps body) (parse-body-header src) (let* ((aux (member '&aux ll));FIXME centralize with new-defun-args (ll (ldiff ll aux)) (non-aux (mapcan (lambda (x &aux (lp (listp x))) (cons (if lp (if (listp (car x)) (cadar x) (car x)) x) (when (when lp (cddr x)) (list (caddr x))))) ll)) (non-aux (set-difference non-aux '(&optional &rest &key &allow-other-keys))) (od (split-decls non-aux decls)) (rd (cons `(declare (optimize (safety ,(decl-safety decls)))) (pop od))) (oc (split-ctps non-aux ctps)) (rc (pop oc)) (n (blocked-body-name body)) (body (if n (cddar body) body)) (n (or n block)) ;rebind args beneath ttl tag for tail recursion with closures (bind (when block (mapcar 'list non-aux non-aux))) (bind (nconc bind (cdr aux))) ; (bind (nconc (mapcar 'list non-aux non-aux) (cdr aux))) (body `(block ,n (tagbody ,tag (return-from ,n (let* ,bind ,@(when block rd) ,@(car od) ,@(when block rc) ,@(car oc) ,@body)))))) `(,h ,ll ,@(when doc (list doc)) ,@rd ,@rc ,body)))) ;; (defun ttl-tag-src (src &optional (tag (tmpsym)) (block (tmpsym)) &aux (h (pop src)) (ll (pop src))) ;; (setf (get tag 'ttl-tag) t) ;; (multiple-value-bind ;; (doc decls ctps body) ;; (parse-body-header src) ;; (let* ((aux (member '&aux ll));FIXME centralize with new-defun-args ;; (ll (ldiff ll aux)) ;; (regs (mapcar (lambda (x) (cond ((symbolp x) x) ((symbolp (car x)) (car x)) ((cadar x)))) ll)) ;; (regs (set-difference regs '(&optional &rest &key &allow-other-keys))) ;; (od (split-decls regs decls)) ;; (rd (cons `(declare (optimize (safety ,(decl-safety decls)))) (pop od))) ;; (oc (split-ctps regs ctps)) ;; (rc (pop oc)) ;; (n (blocked-body-name body)) ;; (body (if n (cddar body) body)) ;; (n (or n block)) ;; (body `(block ,n (tagbody ,tag (return-from ,n (let* ,(cdr aux) ,@(car od) ,@(car oc) ,@body)))))) ;; `(,h ,ll ,@(when doc (list doc)) ,@rd ,@rc ,body)))) ;; (defun ttl-tag-src (src &optional (tag (tmpsym)) block &aux (h (pop src)) (ll (pop src))) ;; (setf (get tag 'ttl-tag) t) ;; (multiple-value-bind ;; (doc decls ctps body) ;; (parse-body-header src) ;; (let* ((aux (member '&aux ll)) ;; (ll (ldiff ll aux)) ;; (aux (cdr aux)) ;; (auxv (mapcar (lambda (x) (if (consp x) (car x) x)) aux)) ;; (ad (split-decls auxv decls)) ;; (od (cadr ad)) ;; (ad (car ad)) ;; (ac (split-ctps auxv ctps)) ;; (oc (cadr ac)) ;; (ac (car ac)) ;; (n (blocked-body-name body)) ;; (body (if n (cddar body) body)) ;; (n (or n block)) ;; (body `(block ,n (tagbody ,tag (return-from ,n (let* ,aux ,@ad ,@ac ,@body)))))) ;; `(,h ,ll ,@(when doc (list doc)) ,@od ,@oc ,body)))) (defvar *int* nil) (defmacro ttm (fn &body body) `(let* ((st (get-internal-real-time)) (res ,@body) (end (- (get-internal-real-time) st)) (dd (or (cdr (assoc ,fn *int*)) (cdar (push (list ,fn 0 0) *int*))))) (incf (car dd)) (incf (cadr dd) end) res)) (defun mi4 (fn args la src env inls) (c1inline (list (cons fn (append args la)) (blla (cadr src) args la (cddr src))) env inls)) ;; (defun mi4 (fn args la src env inls &aux *callees*) ;; (let* (;(*compiler-check-args* (>= (this-safety-level) 2)) ;; (src (assert-safety fn (blla (cadr src) args la (cddr src))))) ;; (c1inline (list (cons fn (append args la)) src) env inls))) ;; (defun mi4 (fn args la src env inls &aux *callees*) ;; (let* ((*compiler-check-args* (>= (this-safety-level) 2)) ;; (src (assert-safety (blla (cadr src) args la (cddr src))))) ;; (c1inline (list (cons fn (append args la)) src) env inls))) ;; (defun mi4 (fn args la src env &aux *callees*) ;; (let* ((*compiler-check-args* (>= (this-safety-level) 2)) ;; (src (blla (cadr src) args la (cddr src)))) ;; (assert-safety src) ;; (under-env env (c1inline (list (cons fn (append args la)) src))))) (defun sir-tag (sir) (cadar (member-if (lambda (x) (and (eq (caar x) (car sir)) (cdddr x))) (reverse *src-inline-recursion*)))) (defun discrete-tp (tp &optional (i 0)) (when (< i 5);FIXME (cond ((atomic-tp tp)) ((when (consp tp) (eq (car tp) 'or)) (not (member-if-not (lambda (x) (discrete-tp x (incf i))) (cdr tp))))))) (defun bbump-tp (tp) (cond ((car (member tp '(#tnull #t(and seqbnd (not (integer 0 0))) #tseqbnd #t(or null (and seqbnd (not (integer 0 0)))) #t(or null seqbnd)) :test 'type<=))) ((discrete-tp tp) tp) ((bump-tp tp)))) (defun cln (x &optional (i 0)) (if (atom x) i (cln (cdr x) (1+ i)))) (defun new-type-p (a b) (cond ((binding-p a) nil);;FIXME ???? ((binding-p b) nil) ((eql a b) nil) ((atom a)) ((atom b)) ((or (new-type-p (car a) (car b)) (new-type-p (cdr a) (cdr b)))))) (defun tm (a b &aux (ca (cons-count a))) (when (< ca (if (< ca (cons-count b)) 50 32));FIXME, catch si::+array-typep-alist+ (new-type-p a b))) ;; (defun arg-types-match (tps sir &optional ctp) ;; (if tps ;; (and (= (length tps) (length sir));FIXME unroll strategy ;; (every (lambda (x y) ;; (or (type>= x y) ;; (and (type>= #tinteger x) (type>= #tinteger y)) ;; (when ctp ;; (let ((ax (car (atomic-tp x)))(ay (car (atomic-tp y)))) ;; (when (consp ay) ;(setq aax ax aay ay) ;(print (list aax aay))(break) ;; (not ;; (tm ay ax) ;; ; (when (and (consp ax) (<= (length ax) 15)) (tailp ay ax)) ;; )))))) tps sir)) ;; (not (member-if 'atomic-tp sir)))) ;; (defun top-tagged-sir (sir &aux tagged-sir) ;; (mapc (lambda (x) (when (eq (caar x) (car sir)) (when (cdddr x) (setq tagged-sir x)))) ;; *src-inline-recursion*) ;; tagged-sir) ;; (defun prev-sir (sir &aux (f (name-sir sir))(tp sir)(n (pop tp)) ;; (p (member n *src-inline-recursion* :key 'caar))) ;; (when p ;; (when (or (arg-types-match (cdaar p) tp) ;; (member-if (lambda (x) (when (eq n (caar x)) (arg-types-match (cdar x) tp t))) (cdr p))) ;; (let ((tagged-sir (unless (or (tail-recursion-possible f) (member-if 'atomic-tp tp)) ;; (top-tagged-sir sir)))) ;; (if tagged-sir ;; (throw tagged-sir *src-inline-recursion*) ;; t))))) ;; (defun prev-sir (sir &aux (f (name-sir sir))(tp sir)(n (pop tp)) sub) ;; (let ((p (member-if (lambda (x) ;; (when (eq n (caar x)) ;; (when (cdddr x) ;; (arg-types-match (cdar x) tp (prog1 sub (setq sub t)))))) ;; *src-inline-recursion*))) ;; (when p ;; (cond ((tail-recursion-possible f) t) ;; ((member-if 'atomic-tp tp) t) ;; ((throw (car p) *src-inline-recursion*)))))) ;; (defun arg-types-match (tps sir &optional ctp) ;; (if t;tps ;; (and (= (length tps) (length sir));FIXME unroll strategy ;; (every (lambda (x y) ;; (or (si::type= x y) ;; (and (type>= #tinteger x) (type>= #tinteger y)) ;; ;; (when ctp ;; ;; (let ((ax (car (atomic-tp x)))(ay (car (atomic-tp y)))) ;; ;; (when (consp ay) ;(setq aax ax aay ay) ;(print (list aax aay))(break) ;; ;; (not ;; ;; (tm ay ax) ;; ;; ; (when (and (consp ax) (<= (length ax) 15)) (tailp ay ax)) ;; ;; )))) ;; )) tps sir)) ;; (progn (break "foo")(not (member-if 'atomic-tp sir))))) ;; (defun too-complicated-p (sir) ;; (> ;; (max (count (car sir) *src-inline-recursion* :key 'caar) ;; (reduce (lambda (y x &aux (x (car (atomic-tp x)))) ;; (max y (if (listp x) (length x) 0))) ;; (cdr sir) :initial-value 0)) ;; 20)) ;; (defun prev-sir (sir &aux (f (name-sir sir))(tp sir)(n (pop tp)) sub) ;; ; (print (list n (count n *src-inline-recursion* :key 'caar))) ;; ;; (let ((x (mapcan (lambda (x) (when (consp x) (list x (length x)))) ;; ;; (remove nil (mapcar (lambda (x) (car (atomic-tp x))) tp))))) ;; ;; (when x (print x))) ;; (let* ((p (member-if (lambda (x) ;; (when (eq n (caar x)) ;; (when (cdddr x) ;; (arg-types-match (cdar x) tp)))); (prog1 sub (setq sub t)) ;; *src-inline-recursion*)) ;; (ts (top-tagged-sir sir)) ;; (c (when ts (when (too-complicated-p sir) (list ts)))) ;; ; (c (when ts (when (member-if 'complicated-cons-type-p tp) (list ts)))) ;; (p (or p c))) ;; (when p ;; (cond ((unless c (tail-recursion-possible f)) t) ;; ((unless c (member-if 'atomic-tp tp)) (break "bar") t) ;; ((throw (car p) *src-inline-recursion*)))))) ;; (defun arg-types-match (tps sir) ;; (and (= (length tps) (length sir)) ;; (every (lambda (x y) ;; (or (si::type= x y) ;; (and (type>= #tinteger x) (type>= #tinteger y)))) ;; tps sir))) ;; (defun too-complicated-p (sir) ;; (mapc (lambda (x) (when (eq (car sir) (caar x)) ;; (when (cddr x) ;; (when (some (lambda (x y &aux (x (car (atomic-tp x)))(y (car (atomic-tp y)))) ;; (and (consp x) (consp y) (tailp x y) (> (length y) 20))) ;; (cdr sir) (cdar x)) ;; ; (print sir)(break) ;; (return-from too-complicated-p t))))) ;; *src-inline-recursion*) ;; (> ;; (count (car sir) *src-inline-recursion* :key 'caar) ;; 20)) ;; (defun top-tagged-sir (sir &aux tagged-sir tts) ;; (mapc (lambda (x) (when (eq (caar x) (car sir)) (when (cdddr x) (setq tts tagged-sir tagged-sir x)))) ;; *src-inline-recursion*) ;; tagged-sir) ;; (defun top-tagged-sir (sir &aux tagged-sir tts) ;; (mapc (lambda (x) (when (eq (caar x) (car sir)) (when (cdddr x) (setq tts tagged-sir tagged-sir x)))) ;; *src-inline-recursion*) ;; tts) ;; (defun top-tagged-sir (sir &aux tagged-sir tts) ;; (mapc (lambda (x) (when (eq (caar x) (car sir)) (when (cdddr x) (setq tts tagged-sir tagged-sir x)))) ;; *src-inline-recursion*) ;; (if (member-if 'atomic-tp tagged-sir) tts tagged-sir)) ;; (defun top-tagged-sir (sir &aux last-tagged-sir penultimate-tagged-sir) ;; (mapc (lambda (x) ;; (when (eq (caar x) (car sir)) ;; (when (cdddr x) ;; (setq penultimate-tagged-sir last-tagged-sir last-tagged-sir x)))) ;; *src-inline-recursion*) ;; (or (unless (member-if 'atomic-tp (cdr last-tagged-sir)) last-tagged-sir) ;; penultimate-tagged-sir)) ;; (defun prev-sir (sir &aux (f (name-sir sir))(tp sir)(n (pop tp)) sub) ;; (let* ((p (member-if (lambda (x) ;; (when (eq n (caar x)) ;; (when (cdddr x) ;; (arg-types-match (cdar x) tp)))) ;; *src-inline-recursion*)) ;; (ts (top-tagged-sir sir)) ;; (c (when ts (when (too-complicated-p sir) (list ts)))) ;; (p (or p c))) ;; (when p ;; (cond ((unless c (tail-recursion-possible f)) t) ;; ((unless c (member-if 'atomic-tp tp)) t) ;; ((throw (car p) *src-inline-recursion*)))))) ;; (defun last-or-penultimate (sir filter &aux (n (car sir)) last penultimate) ;; (mapc (lambda (x) (when (and (eq n (caar x)) (cdddr x) (funcall filter x)) ;; (setq penultimate last last x))) ;; *src-inline-recursion*) ;; (or last ;(unless (member-if 'atomic-tp last) last) ;inline at least one of these ;; penultimate)) ;; (defun prev-sir (sir &aux (f (name-sir sir))(tp sir)(n (pop tp)) sub) ;; (let* ((p (last-or-penultimate sir (lambda (x) (arg-types-match (cdar x) tp)))) ;; (c (unless p ;; (when (too-complicated-p sir) ;; (last-or-penultimate sir 'identity)))) ;; (p (or p c))) ;; (when p ;; (or (unless c (tail-recursion-possible f)) ;; (unless c (member-if 'atomic-tp tp)) ;; (throw p *src-inline-recursion*))))) ;; (defun top-tagged-sir (sir &aux last penul) ;; (mapc (lambda (x) (when (eq (caar x) (car sir)) (when (cdddr x) (setq penul last last x)))) ;; *src-inline-recursion*) ;; (cond ((member-if 'atomic-tp (car last)) penul) ;; ((eql (length (car last)) (length (car penul))) last);types t? ;; (penul))) ;; (defun top-tagged-sir (sir &aux last penul) ;; (mapc (lambda (x) (when (eq (caar x) (car sir)) (when (cdddr x) (setq penul last last x)))) ;; *src-inline-recursion*) ;; (cond ;((member-if 'atomic-tp (car last)) penul) ;; ;((eql (length (car last)) (length (car penul))) last);types t? ;; (penul))) ;; (defun prev-sir (sir &aux (f (name-sir sir))(tp sir)(n (pop tp))) ;; (let* ((p (car (member-if ;; (lambda (x) ;; (when (eq n (caar x)) ;; (when (cdddr x) ;; (arg-types-match (cdar x) tp)))) ;; *src-inline-recursion*))) ;; (c (unless p (when (too-complicated-p sir) (top-tagged-sir sir)))) ;; (p (or p c))) ;; (when p ;; (cond ((unless c (tail-recursion-possible f)) t) ;; ((unless c (member-if 'atomic-tp tp)) t) ;; ((throw p *src-inline-recursion*)))))) (defvar *src-loop-unroll-limit* 20) (defun arg-types-match (tps sir) (and (= (length tps) (length sir)) (every (lambda (x y) (or (si::type= x y) (and (type>= #tinteger x) (type>= #tinteger y)) (let ((cx (car (atomic-tp x)))(cy (car (atomic-tp y)))) (and (consp cx) (consp cy) (if (tailp cy cx) (> (length cx) *src-loop-unroll-limit*) (tailp cx cy)))))) tps sir))) (defun prior-inline-similar-types (n tp) (car (member-if (lambda (x) (when (eq n (caar x)) (when (cdddr x) (arg-types-match (cdar x) tp)))) *src-inline-recursion*))) (defun inline-too-complex (sir list &aux (i 0) last penul) (mapc (lambda (x) (when (eq (caar x) (car sir)) (when (cdddr x) (incf i) (setq penul last last x)))) list) (when (> i *src-loop-unroll-limit*) (let ((p (cond ;(last) ((member-if 'atomic-tp (cdar last)) penul) ((eql (length (car last)) (length (car penul))) last);types t? (penul)))) (if p (throw p list) t)))) (defun prev-sir (sir &aux (f (name-sir sir))(tp sir)(n (pop tp)) p) (cond ((setq p (prior-inline-similar-types n tp)) (or (tail-recursion-possible f) (throw p *src-inline-recursion*))) ((inline-too-complex sir *src-inline-recursion*)) ((inline-too-complex sir *prev-sri*)))) ;; (let* ((p (car (member-if ;; (lambda (x) ;; (when (eq n (caar x)) ;; (when (cdddr x) ;; (arg-types-match (cdar x) tp t)))) ;; *src-inline-recursion*))) ;; ; (p (when p (or (top-tagged-sir sir) p)));ldiff ;; (c (unless p (when (too-complicated-p sir) (top-tagged-sir sir)))) ;; (p (or p c))) ;; (when p ;; ;; (print (list n (caar c) (count (car sir) *src-inline-recursion* :key 'caar) (length *src-inline-recursion*) ;; ;; (or (unless c (tail-recursion-possible f)) (unless c (member-if 'atomic-tp tp))) )) ;; (cond ((unless c (tail-recursion-possible f)) t) ;; ; ((unless c (member-if 'atomic-tp tp)) t) ;; ((throw p *src-inline-recursion*)))))) (defun make-tagged-sir (sir tag ll &optional (ttag nil ttag-p)) (list* sir tag ll (when ttag-p (list ttag)))) (defun maybe-cons-tagged-sir (tagged-sir src env &aux (id (name-sir (car tagged-sir)))) (cond ((and (eq src (local-fun-src id)) (not (let ((*funs* (if env (fifth env) *funs*)));FIXME? (eq src (local-fun-src id))))); flet not labels *src-inline-recursion*) ((cons tagged-sir *src-inline-recursion*)))) (defun maybe-cons-sir (sir tag ttag src env &aux (id (name-sir sir))) (cond ((and (eq src (local-fun-src id)) (not (let ((*funs* (if env (fifth env) *funs*)));FIXME? (eq src (local-fun-src id))))) *src-inline-recursion*) ((cons (list sir tag (cadr src) ttag) *src-inline-recursion*)))) (defun sir-name (id) (cond ((local-fun-p id)) ((symbolp id) id) ((alloc-spice))));FIXME, do not push anonymous? (defun name-sir (sir &aux (f (car sir))) (if (fun-p f) (fun-name f) f)) (defun infer-tp-p (f) (cond ((eq f 'infer-tp)) ((atom f) nil) ((or (infer-tp-p (car f)) (infer-tp-p (cdr f)))))) (defun cons-count (f) (cond ((atom f) 0) ((+ 1 (cons-count (car f)) (cons-count (cdr f)))))) (defun type-fm (fun fms) (case fun ((si::tpi typep coerce) (cadr fms)) (si::num-comp (caddr fms)) (make-sequence (car fms)))) (defun constant-type-p (tp) (typecase tp (symbol t) (binding nil) (atom t) (cons (and (constant-type-p (car tp)) (constant-type-p (cdr tp)))))) (defun known-type-p (fm) (let ((tp (atomic-tp (info-type (cadr fm))))) (when tp (constant-type-p (car tp))))) (defun maybe-inline-src (fun fms src &aux fm) (when src (cond ((member fun *inline*)) ((setq fm (type-fm fun fms)) (known-type-p fm)) ((member fun '(row-major-aref si::row-major-aset si::row-major-aref-int si::set-array array-element-type si::0-byte-array-self si::set-0-byte-array-self));FIXME (flet ((tst (tp) (not (or (type>= tp #tarray) (type>= tp #tvector))))) (tst (info-type (if (eq fun 'si::row-major-aset) (cadadr fms) (cadar fms)))))) ; ((< (cons-count src) 30)) ((not (symbolp fun))) ((let* ((n (symbol-package fun))(n (when n (package-name n)))(p (find-package :lib))) (when n (or (when p (find-symbol n p)) (string-equal "S" n)))));FIXME ((local-fun-p fun)) ((intersection-p '(&key &rest) (cadr src))) ((member-if-not (lambda (x) (type>= (car x) (cdr x))) (mapcar (lambda (x y) (cons (info-type (cadr x)) (coerce-to-one-value y))) fms (get-arg-types fun)))) ((when (exit-to-fmla-p) (infer-tp-p src))) ((< (cons-count src) 50)))));100 (dolist (l '(upgraded-array-element-type row-major-aref row-major-aset si::set-array array-element-type)) (setf (get l 'consider-inline) t)) ;; (defun maybe-inline-src (fun fms src) ;; (when src ;; (or ;; (not (symbolp fun)) ;; (inline-asserted fun) ;; (not (get fun 'consider-inline)) ;; (let* ((y (get-arg-types fun)) ;; (y (or (car y) #tt)) ;; (y (if (eq y '*) #tt y)) ;; (x (info-type (cadar fms))) ;; (x (if (eq x #tvector) #tarray x)) ;; (x (if (or (type>= #tarray x) (atomic-tp x)) x #tt)));FIXME ;; (not (type>= x y)))))) (defun mi3a (env fun fms) (under-env env (let ((src (inline-src fun))) (when (maybe-inline-src fun fms src) src)))) (defun mi3 (fun args la fms ttag envl inls &aux (src (mi3a (pop envl) fun fms)) (env (car envl))) (when src (let ((sir (cons (sir-name fun) (mapcar (lambda (x) (when x (info-type (cadr x)))) fms)))) (unless (prev-sir sir) (let* ((tag (make-ttl-tag));(tmpsym) (tsrc (ttl-tag-src src tag)) (tagged-sir (make-tagged-sir sir tag (cadr src) ttag)) (*src-inline-recursion* (maybe-cons-tagged-sir tagged-sir src env))) (catch tagged-sir (mi4 fun args la tsrc env inls))))))) ;; (defun mi3 (fun args la fms ttag envl inls &aux (src (under-env (pop envl) (inline-src fun))) (env (car envl))) ;; (when (maybe-inline-src fun fms src) ;; (let ((sir (cons (sir-name fun) (mapcar (lambda (x) (when x (info-type (cadr x)))) fms)))) ;; (unless (prev-sir sir) ;; (let* ((tag (tmpsym)) ;; (tsrc (ttl-tag-src src tag)) ;; (*src-inline-recursion* (maybe-cons-sir sir tag ttag src env))) ;; (catch tag (mi4 fun args la tsrc env inls))))))) ;; (defun mi3 (fun args la fms ttag envl inls &aux (src (under-env (pop envl) (inline-src fun))) (env (car envl))) ;; (when (maybe-inline-src fun fms src) ;; (let ((sir (cons (sir-name fun) (mapcar (lambda (x) (when x (info-type (cadr x)))) fms)))) ;; (unless (prev-sir sir) ;; (let* ((tag (tmpsym)) ;; (tsrc (ttl-tag-src src tag)) ;; (*src-inline-recursion* (maybe-cons-sir sir tag ttag src env))) ;; (with-restore-vars ;; (prog1 (catch tag (mi4 fun args la tsrc env inls)) ;; (keep-vars)))))))) ;; (defun mi3 (fun args la fms ttag envl inls &aux (src (under-env (pop envl) (inline-src fun))) (env (car envl))) ;; (when (maybe-inline-src fun fms src) ;; (let ((sir (cons (sir-name fun) (mapcar (lambda (x) (when x (info-type (cadr x)))) fms)))) ;; (if (prev-sir sir) ;; (let ((tag (sir-tag sir))) (when tag (throw tag nil))) ;; (let* ((tag (tmpsym)) ;; (tsrc (ttl-tag-src src tag)) ;; (*src-inline-recursion* (maybe-cons-sir sir tag ttag src env))) ;; (with-restore-vars ;; (prog1 (catch tag (mi4 fun args la tsrc env inls)) ;; (keep-vars)))))))) ;; (defun mi3 (fun args la fms ttag envl inls &aux (src (under-env (pop envl) (inline-src fun))) (env (car envl))) ;; (when src ;; (let ((sir (cons (sir-name fun) (mapcar (lambda (x) (when x (info-type (cadr x)))) fms)))) ;; (if (prev-sir sir) ;; (let ((tag (sir-tag sir))) (when tag (throw tag nil))) ;; (let* ((tag (tmpsym)) ;; (tsrc (ttl-tag-src src tag)) ;; (*src-inline-recursion* (maybe-cons-sir sir tag ttag src env))) ;; (with-restore-vars ;; (prog1 (catch tag (mi4 fun args la tsrc env inls)) ;; (keep-vars)))))))) ;; (defun mi3 (fun args la fms ttag envl &aux (src (under-env (pop envl) (inline-src fun))) (env (car envl))) ;; (when src ;; (let ((sir (cons (sir-name fun) (mapcar (lambda (x) (when x (info-type (cadr x)))) fms)))) ;; (if (prev-sir sir) ;; (let ((tag (sir-tag sir))) (when tag (throw tag nil))) ;; (let* ((tag (tmpsym)) ;; (tsrc (ttl-tag-src src tag)) ;; (*src-inline-recursion* (maybe-cons-sir sir tag ttag src env))) ;; (with-restore-vars ;; (prog1 (catch tag (mi4 fun args la tsrc env)) ;; (keep-vars)))))))) ;; (defun mi3 (fun args la fms ttag envl &aux (src (under-env (pop envl) (inline-src fun))) (env (car envl))) ;; (when src ;; (let ((sir (cons (if (symbolp fun) fun (tmpsym)) ;; (mapcar (lambda (x) (when x (info-type (cadr x)))) fms)))) ;; (if (prev-sir sir) ;; (let ((tag (sir-tag sir))) (when tag (throw tag nil))) ;; (let* ((tag (tmpsym)) ;; (tsrc (ttl-tag-src src tag)) ;; (*src-inline-recursion* (maybe-cons-sir sir tag ttag src env))) ;; (with-restore-vars ;; (prog1 (catch tag (mi4 fun args la tsrc env)) ;; (keep-vars)))))))) ;; (defun mod-env (ce e l);FIXME ;; (if ce (append e l) l)) ;; (defun mod-env (ce e l);FIXME ;; (if ce e l)) (defun mod-env (e l) (setq *lexical-env-mask* (nconc (remove-if (lambda (x) (or (symbolp x) (is-fun-var x))) (ldiff l e)) *lexical-env-mask*)) l) ;; (defun mod-env (ce e l);FIXME ;; (if ce (append (remove-if-not (lambda (x) (or (symbolp x) (is-fun-var x))) (ldiff l e)) e) l)) ;; (defun mod-env (ce e l);FIXME ;; (if ce (append (remove-if (lambda (x) (or (symbolp x) (is-fun-var x))) e) l) l)) ;; (defun mod-env (ce e l);FIXME ;; (let* ((r (if ce (append (remove-if-not (lambda (x) (or (symbolp x) (is-fun-var x))) (ldiff l e)) e) l)) ;; ;; (vp (member-if 'var-p l)) ;; ;; (ol (when vp (mapcar (lambda (x) (cond ((var-p x) (var-name x)) (x))) l))) ;; ;; (or (when vp (mapcar (lambda (x) (cond ((var-p x) (var-name x)) (x))) r))) ;; ) ;; ; (unless (equal or ol) (print ol) (print or)) ;; r)) (defvar *lexical-env-mask* nil) (defmacro under-env (env &rest forms &aux (e (tmpsym))) `(let* ((,e ,env) (*lexical-env-mask* (pop ,e)) (*vars* (mod-env (pop ,e) *vars*)) (*blocks* (mod-env (pop ,e) *blocks*)) (*tags* (mod-env (pop ,e) *tags*)) (*funs* (mod-env (pop ,e) *funs*))) ,@forms)) ;; (defmacro under-env (env &rest forms &aux (e (tmpsym))) ;; `(let* ((,e ,env) ;; (*vars* (mod-env ,e (pop ,e) *vars*)) ;; (*blocks* (mod-env ,e (pop ,e) *blocks*)) ;; (*tags* (mod-env ,e (pop ,e) *tags*)) ;; (*funs* (mod-env ,e (pop ,e) *funs*))) ;; ,@forms)) ;; (defmacro under-env (env form &aux (e (tmpsym))) ;; `(let* ((,e ,env) ;; (*vars* (mod-env ,e (pop ,e) *vars*)) ;; (*blocks* (mod-env ,e (pop ,e) *blocks*)) ;; (*tags* (mod-env ,e (pop ,e) *tags*)) ;; (*funs* (mod-env ,e (pop ,e) *funs*))) ;; ,form)) ;; (defmacro under-env (env form &aux (e (tmpsym))) ;; `(let* ((,e ,env) ;; (*vars* (if ,e (pop ,e) *vars*)) ;; (*blocks* (if ,e (pop ,e) *blocks*)) ;; (*tags* (if ,e (pop ,e) *tags*)) ;; (*funs* (if ,e (pop ,e) *funs*))) ;; ,form)) (defun barrier-cross-p (fun &aux (f (local-fun-p fun))) (not (tailp (member-if-not 'fun-p *funs*) (member f *funs*)))) (defun tail-recursion-possible (fun &aux (f (assoc fun *c1exit*))) (when f (unless (barrier-cross-p fun) (do ((l *vars* (cdr l))(e (caddr f))) ((eq l e) t) (let ((v (car l))) (when (var-p v) (unless (eq 'lexical (var-kind v)) (unless (member v *lexical-env-mask*) (return nil))))))))) (defun mi2 (fun args la fms envl) (let* ((sir (cll fun)) (tag (cadr sir)) (targs (if la (append args (list la)) args)) (inls (mapcar 'cons targs fms)) (inl (mi3 fun args la fms tag envl inls))) (cond ((info-p (cadr inl)) (keyed-cmpnote (list 'inline (if (fun-p fun) (fun-name fun) fun)) "inlining ~s ~s ~s" fun (mapcar (lambda (x) (info-type (cadr x))) fms) la) inl) (inl (setq inl (mapcar (lambda (x) (name-sir (car x))) (ldiff inl *src-inline-recursion*))) (keyed-cmpnote (list* 'inline 'inline-abort inl) "aborting inline of ~s" inl) (setq *notinline* (nunion inl *notinline*));FIXME too extreme? nil) ((and sir (tail-recursion-possible fun)) (keyed-cmpnote (list 'tail-recursion fun) "tail recursive call to ~s replaced with iteration" fun) (c1let-* (cdr (blla-recur tag (caddr sir) args la)) t inls))))) ;; (defun mi2 (fun args la fms envl) ;; (let* ((sir (cll fun)) ;; (tag (cadr sir)) ;; (targs (if la (append args (list la)) args)) ;; (*inline-forms* (mapcar 'cons targs fms)) ;; (inl (mi3 fun args la fms tag envl))) ;; (cond (inl ;; (mapc (lambda (x) (add-info (cadr inl) (cadr x))) fms);FIXME ;; (when (eq (car (fifth inl)) 'let*) ;; (setf (cadr (fifth inl)) (copy-info (cadr inl)))) ;; (keyed-cmpnote (list 'inline fun) "inlining ~s ~s ~s" fun args la) ;; inl) ;; ((and sir (member fun *c1exit*)) ;; (keyed-cmpnote (list 'tail-recursion fun) ;; "tail recursive call to ~s replaced with iteration" fun) ;; (c1expr (blla-recur tag (caddr sir) args la)))))) ;; (defun mi2 (fun args la fms envl) ;; (let* ((sir (cll fun)) ;; (tag (cadr sir)) ;; (targs (if la (append args (list la)) args)) ;; (*inline-forms* (mapcar 'cons targs fms)) ;; (inl (mi3 fun args la fms tag envl))) ;; (cond (inl ;; (mapc (lambda (x) (add-info (cadr inl) (cadr x))) fms);FIXME ;; (when (eq (car (fifth inl)) 'let*) ;; (setf (cadr (fifth inl)) (copy-info (cadr inl)))) ;; (keyed-cmpnote (list 'inline fun) "inlining ~s ~s ~s" fun args la) ;; inl) ;; ((and sir (member fun *c1exit*)) ;; (keyed-cmpnote (list 'tail-recursion fun) ;; "tail recursive call to ~s replaced with iteration" fun) ;; (c1expr (blla-recur tag (caddr sir) args la)))))) ;(defvar *provisional-inline* nil) (defun make-c1forms (fn args last info) (let* ((at (get-arg-types fn)) (nargs (c1args args info)) (c1l (when last (c1arg last info))) (nargs (if (when last (not (type>= #tnull (info-type (cadr c1l))))) (progn (add-info info (cadr c1l)) (nconc nargs (list c1l))) nargs)) (nat (mapcar (lambda (x) (info-type (cadr x))) nargs)) (ss (gethash fn *sigs*));FIXME? (at (if (and ss (not (car ss))) nat at))) (mapc (lambda (x) (setf (info-type (cadr x)) (coerce-to-one-value (info-type (cadr x))))) nargs) (unless (or last (local-fun-p fn) (eq fn (cadr *current-form*)));FIXME (when (do (p ;n (a at (if (eq (car a) '*) a (cdr a))) (r args (cdr r)) (f nargs (cdr f))) ((or p (endp f) (endp a)) (or p f (and a (not (eq (car a) '*))))) ; (when (setq nargs (nreverse n)) nil))) (unless (or (eq '* (car a)) (type-and (car a) (info-type (cadar f)))) (cmpwarn "The type of the form ~s is not ~s, but ~s." (car r) (cmp-unnorm-tp (car a)) (cmp-unnorm-tp (info-type (cadar f)))) (setq p t))) (cmpwarn "inlining of ~a prevented due to argument type mismatch: ~a ~a~%" fn (mapcar 'cmp-unnorm-tp at) (mapcar 'cmp-unnorm-tp nat)) (setf (info-type info) nil))) (do ((a at (if (eq '* (car a)) a (cdr a))) (r args (cdr r)) (f (if last (butlast nargs) nargs) (cdr f))) ((or (endp f) (endp a)) nargs) (maybe-reverse-type-prop (car a) (car f))))) ;; (defun make-c1forms (fn args last info) ;; (let* ((at (get-arg-types fn)) ;; (nargs (c1args args info)) ;; (c1l (when last (c1expr last))) ;; (nargs (if (when last (not (type>= #tnull (info-type (cadr c1l))))) ;; (progn (add-info info (cadr c1l)) (nconc nargs (list c1l))) ;; nargs)) ;; (nat (mapcar (lambda (x) (info-type (cadr x))) nargs)) ;; (ss (gethash fn *sigs*));FIXME? ;; (at (if (and ss (not (car ss))) nat at))) ;; (mapc (lambda (x) (setf (info-type (cadr x)) (coerce-to-one-value (info-type (cadr x))))) nargs) ;; (unless (or last (local-fun-p fn) (eq fn (cadr *current-form*)));FIXME ;; (when (do (p ;n ;; (a at (if (eq (car a) '*) a (cdr a))) ;; (r args (cdr r)) ;; (f nargs (cdr f))) ;; ((or p (endp f) (endp a)) ;; (or p f (and a (not (eq (car a) '*))))) ; (when (setq nargs (nreverse n)) nil))) ;; (check-form-type (car a) (car f) (car r)) ;; ; (push (and-form-type (or (car a) '*) (car f) (car r)) n) ;; (setq p (when (info-type (cadar f)) (null (info-type (cadar f)))))) ;; (cmpwarn "inlining of ~a prevented due to argument type mismatch: ~a ~a~%" ;; fn at nat) ;; (setf (info-type info) nil))) ;; (do ((a at (if (eq '* (car a)) a (cdr a))) ;; (r args (cdr r)) ;; (f nargs (cdr f))) ;; ((or (endp f) (endp a)) nargs) ;; (maybe-reverse-type-prop (car a) (car f))))) ;; (defun make-c1forms (fn args last info &aux (*provisional-inline* t)) ;; (let* ((at (get-arg-types fn)) ;; (nargs (c1args (append args (when last (list last))) info)) ;; (nat (mapcar (lambda (x) (info-type (cadr x))) nargs)) ;; (ss (gethash fn *sigs*));FIXME? ;; (at (if (and ss (not (car ss))) nat at))) ;; (mapc (lambda (x) (setf (info-type (cadr x)) (coerce-to-one-value (info-type (cadr x))))) nargs) ;; (unless (or (local-fun-p fn) (eq fn (cadr *current-form*)));FIXME ;; (when (do (p ;n ;; (a at (if (eq (car a) '*) a (cdr a))) ;; (r args (cdr r)) ;; (f nargs (cdr f))) ;; ((or p (endp f) (endp a)) ;; (or p f (and a (not (eq (car a) '*))))) ; (when (setq nargs (nreverse n)) nil))) ;; (check-form-type (car a) (car f) (car r)) ;; ; (push (and-form-type (or (car a) '*) (car f) (car r)) n) ;; (setq p (when (info-type (cadar f)) (null (info-type (cadar f)))))) ;; (cmpwarn "inlining of ~a prevented due to argument type mismatch: ~a ~a~%" ;; fn at nat) ;; (setf (info-type info) nil))) ;; (do ((a at (if (eq '* (car a)) a (cdr a))) ;; (r args (cdr r)) ;; (f nargs (cdr f))) ;; ((or (endp f) (endp a)) nargs) ;; (maybe-reverse-type-prop (car a) (car f))))) (defun make-ordinary (fn &aux *c1exit*);FIXME *c1exit* (let* ((s (sgen "ORDS"))(g (sgen "ORDG")) (e (c1let-* `(((,s ,g)) ;(check-type ,s (not list)) FIXME bootstrap (if (functionp ,s) ,s (funcallable-symbol-function ,s)) ; (coerce ,s 'function) ) t (list (cons g fn)))); (coerce ,s 'function) ; (e (c1let-* `(((,s ,g)) (etypecase ,s ((and symbol (not boolean)) (fsf ,s)) (function ,s))) t (list (cons g fn)))); (coerce ,s 'function) (info (make-info))) (add-info info (cadr e)) (list 'ordinary info e))) ;; (defun make-ordinary (fn) ;; (let* ((s (tmpsym))(g (tmpsym)) ;; (e (c1let-* `(((,s ,g)) (etypecase ,s (symbol (fsf ,s)) (function ,s))) t (list (cons g fn)))) ;; (info (make-info))) ;; (add-info info (cadr e)) ;; (list 'ordinary info e))) ;; (defun make-ordinary (fn) ;; (let* ((s (tmpsym))(g (tmpsym)) ;; (e (c1let-* `(((,s ,g)) (etypecase ,s (symbol (fsf ,s)) (function ,s))) t nil (list (cons g fn)))) ;; (info (make-info))) ;; (add-info info (cadr e)) ;; (list 'ordinary info e))) ;; (defun make-ordinary (fn) ;; (let* ((s (tmpsym))(g (tmpsym)) ;; (*inline-forms* (list (cons g fn))) ;; (e (c1expr `(let* ((,s ,g)) (etypecase ,s (symbol (fsf ,s)) (function ,s)))))) ;; (list 'ordinary (cadr e) e))) ;; (defun make-ordinary (fn) ;; (let* ((s (tmpsym))(g (tmpsym)) ;; (*inline-forms* (list (cons g fn))) ;; (e (c1expr `(let* ((,s ,g)) (if (symbolp ,s) (fsf ,s) ,s))))) ;; (list 'ordinary (cadr e) e))) ;; (defun or-ccb-assignments (fms) ;; (mapc (lambda (v) ;; (when (var-p v) ;; (let ((tp (get (var-store v) 'ccb-tp)));FIXME setq tp nil? ;; (when tp ;; (do-setq-tp v '(ccb-ref) (type-or1 (var-type v) (get (var-store v) 'ccb-tp))) ;; (setf (var-store v) +opaque+))))) *vars*)) (defun do-ccb-ch (ccb-ch) (mapc (lambda (x &aux (v (pop x))) (do-setq-tp v '(ccb-ch) (type-or1 (var-type v) (info-type (cadr x)))) (push-vbind v x t)) ccb-ch)) (defun or-ccb-assignments (fms) (mapc (lambda (x) (do-ccb-ch (info-ch-ccb (cadr x)))) fms)) (defun mi6 (fn fms) (or-ccb-assignments fms) (unless (and (symbolp fn) (get fn 'c1no-side-effects)) (dolist (f fms) (when (and (consp f) (eq (car f) 'var)) (let* ((ft (info-type (cadr f))) (p (when (and ft (type>= #tcons ft)) #tcons)) (p (when (and p (type>= #tproper-cons ft)) #tproper-cons))) (when (and p (not (type>= ft p))) (bump-pcons (caaddr f) p))))))) ;; (defun mi6 (fn fms) ;; (unless (and (symbolp fn) (get fn 'c1no-side-effects)) ;; (dolist (f fms) ;; (when (and (consp f) (eq (car f) 'var)) ;; (let* ((ft (info-type (cadr f))) ;; (p (when (and ft (type>= #tcons ft)) #tcons)) ;; (p (when (and p (type>= #tproper-cons ft)) #tproper-cons))) ;; (when (and p (not (type>= ft p))) ;; (bump-pcons (caaddr f) p))))))) (defun binding-forms (st) (mapcan (lambda (x &aux (z (binding-form x))) (when z (list z))) st)) (defun global-var-stores (&aux z) (reduce (lambda (y x) (or-binds (when (var-p x) (unless (eq (var-kind x) 'lexical) (var-store x))) y)) *vars* :initial-value z)) (defun mi5 (fn info fms la &aux (ll (when la (list (length fms)))) fd) (mi6 fn fms) (let ((r (assoc fn *recursion-detected*))) (when r (setf (cdr r) t))) (cond ((consp fn) (let ((ord (make-ordinary fn))) (add-info info (cadr ord)) (or-ccb-assignments (list fn)) `(,(if la 'apply 'funcall) ,info ,ord ,fms))) ((setq fd (c1local-fun fn)) (add-info info (cadr fd)) (setf (info-type info) (info-type (cadr fd))) (let ((fm (fifth fd))) (when fm (or-ccb-assignments (list fm))) `(call-local ,info ,(nconc (caddr fd) ll) ,(cadddr fd) ,fm ,fms)));FIXME (t (or-ccb-assignments (binding-forms (global-var-stores))) (push fn (info-ref info)) `(call-global ,info ,fn ,fms nil ,@ll)))) ;; (defun mi5 (fn info fms la &aux (ll (when la (list (length fms)))) fd) ;; (mi6 fn fms) ;; (when (eq fn (cadr *current-form*)) (setq *recursion-detected* t)) ;; (cond ((consp fn) ;; (let ((ord (make-ordinary fn))) ;; (add-info info (cadr ord)) ;; `(,(if la 'apply 'funcall) ,info ,ord ,fms))) ;; ((setq fd (c1local-fun fn)) ;; (add-info info (cadr fd)) ;; (setf (info-type info) (if (eq (info-type (cadr fd)) 'boolean) #tboolean (info-type (cadr fd))));FIXME ;; `(call-local ,info ,(nconc (caddr fd) ll) ,(cadddr fd) ,(fifth fd) ,fms));FIXME ;; (`(call-global ,info ,fn ,fms nil ,@ll)))) ;; (defun mi5 (fn info fms la ;; &aux (nlast (when la (type>= #tnull (info-type (cadr (car (last fms))))))) ;; (fms (if nlast (butlast fms) fms)) ;; (la (unless nlast la)) ;; (ll (when la (list (length fms))))) ;; (mi6 fn fms) ;; (when (eq fn (cadr *current-form*)) (setq *recursion-detected* t)) ;; (cond ((consp fn) `(,(if la 'apply 'funcall) ,info ,(make-ordinary fn) ,fms)) ;; ((let ((fd (c1local-fun fn))) ;; (when fd ;; (add-info info (cadr fd)) ;; (setf (info-type info) (if (eq (info-type (cadr fd)) 'boolean) #tboolean (info-type (cadr fd)))) ;; `(call-local ,info ,(append (caddr fd) ll) ,fms)))) ;; (`(call-global ,info ,fn ,fms nil ,@ll)))) ;; (defun mi5 (fn info fms la &aux (ll (when la (list (length fms))))) ;; (mi6 fn fms) ;; (when (eq fn (cadr *current-form*)) (setq *recursion-detected* t)) ;; (cond ((consp fn) `(,(if la 'apply 'funcall) ,info ,(make-ordinary fn) ,fms)) ;; ((let ((fd (c1local-fun fn))) ;; (when fd ;; (add-info info (cadr fd)) ;; (setf (info-type info) (if (eq (info-type (cadr fd)) 'boolean) #tboolean (info-type (cadr fd)))) ;; `(call-local ,info ,(append (caddr fd) ll) ,fms)))) ;; (`(call-global ,info ,fn ,fms nil ,@ll)))) (defun type-from-args (fun fms last info &aux x) (when (symbolp fun) (setf (info-type info) (type-and (or (get-return-type fun) '*) (info-type info))) (unless (get fun 'c1no-side-effects) (setf (info-flags info) (logior (info-flags info) (iflags side-effects)))));FIXME (cond ((setq x (member-if-not 'identity fms :key (lambda (x) (info-type (cadr x))))) (keyed-cmpnote (list fun 'nil-arg) "Setting return type on call to ~s to nil due to nil-typed form ~s" fun x) (setf (info-type info) nil)) (last) ((and (symbolp fun) (not (local-fun-p fun))) (let ((tp (result-type-from-args fun (mapcar (lambda (x) (info-type (cadr x))) fms)))) (when tp (setf (info-type info) (type-and (info-type info) tp)))))) (info-type info)) (defun coerce-ff (ff) (coerce-to-funid (car (atomic-tp (info-type (cadr ff))))));(when (member (car ff) '(foo location var)) )) (defun coerce-to-local-fn (ob) (if (functionp ob) ob (local-fun-fn ob))) (defun ff-env (ff) (cond ((not ff) nil) ((symbolp ff) (ff-env (local-fun-fn ff))) ((consp ff) (let ((x (car (atomic-tp (info-type (cadr ff)))))) (unless (consp x) (ff-env x))));FIXME ((functionp ff) (list (or (fn-get ff 'ce) (current-env)) (fn-get ff 'df))))) ;; (let* ((fn (when ff (coerce-to-local-fn (car (atomic-tp (info-type (cadr ff)))))))) ;; (when fn ;; (let* ((ce (fn-get fn 'ce)) ;; (df (fn-get fn 'df))) ;; (list ce df))))) ;; (defun ff-env (ff) ;; (when ff ;; (values (gethash (coerce-to-local-fn (car (atomic-tp (info-type (cadr ff))))) *fun-ev-hash*)))) ;; (defun coerce-to-local-fun (ob) ;; (if (functionp ob) ob (local-fun-fun ob))) ;; (defun ff-env (ff) ;; (when ff ;; (gethash (coerce-to-local-fun (car (atomic-tp (info-type (cadr ff))))) *fun-ev-hash*))) ;; (case (car ff) ;; (location (gethash (local-fun-fun (car (atomic-tp (info-type (cadr ff))))) *fun-ev-hash*)) ;; (foo (gethash (car (atomic-tp (info-type (cadr ff)))) *fun-ev-hash*)))) ; (when (member (car ff) '(foo location)) (gethash (car (atomic-tp (info-type (cadr ff)))) *fun-ev-hash*))) (defun mi1c (fun args last info &optional ff prov &aux (*in-inline* t)(*prov* prov)) (let* ((otp (info-type info)) (fms (make-c1forms fun args last info)) (last (when (and last (nth (length args) fms)) last)) (tp (type-from-args fun fms last info)) (inl (when (or tp (eq otp tp)) (mi2 fun args last fms (ff-env (or ff fun)))))) (or inl (mi5 (or (when (symbolp fun) fun) ff) info fms last)))) (defun mi1b (fun args last info &optional ff) (with-restore-vars (let ((res (mi1c fun args last info ff t))) (cond ((iflag-p (info-flags (cadr res)) provisional) (keyed-cmpnote 'provisional "~s has provisional functions, res address ~s" fun (address res))) (t (keep-vars) res))))) (defun mi1a (fun args last info &optional ff &aux (i1 (copy-info info)));FIXME side-effects on info (or (mi1b fun args last info ff) (prog1 (mi1c fun args last i1 ff) (setf (info-type info) (info-type i1))))) ;; (defun mi1a (fun args last info &optional ff &aux (*in-inline* t)) ;; (let* ((otp (info-type info)) ;; (fms (make-c1forms fun args last info)) ;; (last (when (and last (nth (length args) fms)) last)) ;; (tp (type-from-args fun fms last info)) ;; (inl (when (or tp (eq otp tp)) (mi2 fun args last fms (ff-env (or ff fun)))))) ;; (or inl (mi5 (or (when (symbolp fun) fun) ff) info fms last)))) ;; (defun mi1a (fun args last info &aux (*in-inline* t)) ;; (let* ((af (member fun '(apply funcall))) ;; (ff (when af (c1arg (pop args) info))) ;; (fun (if ff (coerce-ff ff) fun));FIXME, e.g. when funcall ;; (otp (info-type info)) ;; (fms (make-c1forms fun args last info)) ;; (last (when (and last (nth (length args) fms)) last)) ;; (tp (type-from-args fun fms last info)) ;; (inl (when (or tp (eq otp tp)) (mi2 fun args last fms (ff-env (or ff fun)))))) ;; (or inl (mi5 (or (when (symbolp fun) fun) ff) info fms last)))) ;; (defun mi1a (fun args last info &aux (*in-inline* t)) ;; (let* ((af (member fun '(apply funcall))) ;; (ff (when af (c1expr (pop args)))) ;; (fun (if ff (coerce-ff ff) fun));FIXME, e.g. when funcall ;; (otp (info-type info)) ;; (fms (make-c1forms fun args last info)) ;; (last (when (and last (nth (length args) fms)) last)) ;; (tp (type-from-args fun fms last info)) ;; (inl (when (or tp (eq otp tp)) (mi2 fun args last fms (ff-env (or ff fun)))))) ;; (or inl (mi5 (or (when (symbolp fun) fun) ff) info fms last)))) ;; (defun mi1a (fun args last info &aux (*in-inline* t) *provisional-inline*) ;; (let* ((fms (make-c1forms fun args last info)) ;; (af (member fun '(apply funcall))) ;; (args (if af (cdr args) args)) ;; (ff (when af (pop fms))) ;; (fun (if ff (coerce-ff ff) fun)) ;; (tp (type-from-args fun fms last info)) ;; (inl (when tp (mi2 fun args last fms (ff-env ff))))) ;; (or (uui inl) (mi5 (or (when (symbolp fun) fun) (uu ff)) info (uu fms) last)))) ;; (defun mi1a (fun args last info &aux (*in-inline* t)) ;; (let* ((fms (make-c1forms fun args last info)) ;; (af (member fun '(apply funcall))) ;; (args (if af (cdr args) args)) ;; (ff (when af (pop fms))) ;; (fun (if ff (coerce-ff ff) fun)) ;; (tp (type-from-args fun fms last info)) ;; (inl (when tp (mi2 fun args last fms (ff-env ff))))) ;; (uu (or inl (mi5 (or (when (symbolp fun) fun) ff) info fms last))))) (defun unprovfn (w &optional b fun &aux (f (cddr w)) (args (pop f)) (env (caar f))) (let ((r (under-env env (c1function args nil b fun)))) (mapl (lambda (x y) (setf (car x) (car y))) w r) (setf (cdddr w) nil) w)) ;; (defun unprovfn (f &optional b fun &aux (args (pop f)) (env (caar f))) ;; (under-env env (c1function args nil b fun))) ;; (defun unfoo (f) ;; (c1function (caddr f) nil (cadddr f))) (defun current-env nil (list *lexical-env-mask* *vars* *blocks* *tags* *funs*)) (defun uui (inl &aux (m inl)) (when (eq (car m) 'inline) (when (eq (car (setq m (car (last m)))) 'let*) (uu (fourth m)))) inl) (defun uu (f) (cond ((atom f) f) ((eq (car f) 'provfn) (unprovfn f)) (t (uu (car f)) (uu (cdr f)) f))) ;; (defun uu (f) ;; (cond ((atom f) f) ;; ((eq (car f) 'provfn) (unprovfn (cddr f))) ;; ((setf (car f) (uu (car f)) (cdr f) (uu (cdr f)) f f)))) ;; (defun uu (f) ;; (cond ((atom f) f) ;; ((eq (car f) 'foo) (unfoo f)) ;; ((let* ((a (car f))(d (cdr f)) (ua (uu a))(ud (uu d))) ;; (if (and (eq a ua) (eq d ud)) f (cons ua ud)))))) (defun mi1 (fn args &optional last ff) (let* ((tp (get-return-type fn)) (sp (if (when (symbolp fn) (get fn 'no-sp-change)) 0 1)) (info (make-info :type tp :sp-change sp)) (res (mi1a fn args last info ff))) (when tp (let ((t1 (info-type (cadr res)))(t2 (info-type info))) (when (exit-to-fmla-p) (labels ((tb (tp) (type-or1 (when (type-and #tnull tp) #tnull) (when (type-and #t(not null) tp) #ttrue)))) (setq t1 (tb t1) t2 (tb t2)))) (setf (info-type (cadr res)) (type-and t1 t2)))) res)) ;; (defun mi1 (fn args &optional last) ;; (let* ((tp (get-return-type fn)) ;; (sp (if (get fn 'no-sp-change) 0 1)) ;; (info (make-info :type tp :sp-change sp)) ;; (res (mi1a fn args last info))) ;; (when tp ;; (let ((t1 (info-type (cadr res)))(t2 (info-type info))) ;; (when (exit-to-fmla-p) ;; (labels ((tb (tp) (type-or1 (when (type-and #tnull tp) #tnull) ;; (when (type-and #t(not null) tp) #t(member t))))) ;; (setq t1 (tb t1) t2 (tb t2)))) ;; (setf (info-type (cadr res)) (type-and t1 t2)))) ;; res)) ;; (defun mi1 (fn args &optional last) ;; (let* ((tp (get-return-type fn)) ;; (sp (if (get fn 'no-sp-change) 0 1)) ;; (info (make-info :type tp :sp-change sp)) ;; (res (mi1a fn args last info))) ;; (when tp (setf (info-type (cadr res)) (type-and (info-type info) (info-type (cadr res)))));FIXME ;; res)) ;; (defun mi1 (fn args &optional last) ;; (let* ((tp (get-return-type fn)) ;; (sp (if (get fn 'no-sp-change) 0 1)) ;; (info (make-info :type tp :sp-change sp)) ;; (res (mi1a fn args last info))) ;; (setf (info-type (cadr res)) (type-and (info-type info) (info-type (cadr res)))) ;; res)) (defun local-fun-p (fname) (car (member-if (lambda (x) (when (fun-p x) (or (eq fname x) (eq fname (fun-fn x)) (when (eq fname (fun-name x)) (not (member x *lexical-env-mask*)))))) *funs*))) (defun local-fun-call (id) (let* ((fun (local-fun-p id))) (when fun (fun-call fun)))) (defun cmp-expand-macro-w (fd x) (macroexpand-helper (and *record-call-info* (add-macro-callee (car x))) `(funcall *macroexpand-hook* ',fd ',x ',*macrolet-env*) x)) (defun c1symbol-fun (whole &aux (fname (car whole)) (args (cdr whole)) fd) (values (cond ((setq fd (get fname 'c1special)) (funcall fd args)) ((and (setq fd (get fname 'co1special)) (funcall fd fname args))) ((setq fd (caddar (member fname (cadr *macrolet-env*) :key 'car))) (c1expr (cmp-expand-macro-w fd whole)));FIXME scope level with local funs ((local-fun-p fname) (mi1 fname args)) ((let ((fn (get fname 'si::compiler-macro-prop)) (res (cons fname args))) (and fn (not (member fname *notinline*)) (let ((fd (funcall fn res nil)));(cmp-eval `(funcall ',fn ',res nil)))) (and (not (eq res fd)) (c1expr fd)))))) ((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 'c1g)) (inline-possible fname)) (funcall fd fname args)) ((and (setq fd (get fname 'c1conditional)) (inline-possible fname) (funcall (car fd) args)) (funcall (cdr fd) args)) ((setq fd (macro-function fname)) (c1expr (cmp-expand-macro-w fd whole))) ((eq fname 'si:|#,|) (cmperr "Sharp-comma-macro was found in a bad place.")) ((mi1 fname args))))) (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 remove-doc-string (body) ;; (nconc (do (d doc) ((or (not body) (if (stringp (car body)) ;; (or (endp (cdr body)) doc) ;; (or (not (consp (car body))) (not (eq 'declare (caar body)))))) ;; (nreverse d)) ;; (let ((x (pop body))) (if (stringp x) (unless doc (push x doc)) (push x d)))) body)) (defun c1funcallable-symbol-function (args &aux a) (let* ((info (make-info :type #tfunction)) (nargs (c1args args info))) (cond ((setq a (atomic-tp (info-type (cadar nargs)))) (c1expr `(function ,(let ((x (coerce-to-funid (car a)))) (if (functionp x) (fn-get x 'id) x))))) ((list 'call-global info 'funcallable-symbol-function nargs))))) (si::putprop 'funcallable-symbol-function 'c1funcallable-symbol-function 'c1) ;; (defun c1lambda-fun (lambda-expr args) ;; (c1expr (blla (car lambda-expr) args nil (cdr lambda-expr)))) (defun c2expr (form) (values (if (eq (car form) 'call-global) (c2call-global (caddr form) (cadddr form) nil (info-type (cadr form)) (sixth 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 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;")) (let* ((cm *reservation-cmacro*) (vstu (if *mv-var* (let ((loc (write-to-string (var-loc *mv-var*)))) (concatenate 'string " if ((b_)>=-1) vs_top=V" loc " ? (object *)V" loc "+(b_) : base;")) " vs_top=base;"))) (wt-h "#define VMRV" cm "(a_,b_)" vstu " return(a_);") (wt-h "#define VMR" cm "(a_) VMRV" cm "(a_,0);")) (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))) ;; ((let ((info (make-info))) ;; (do ((forms forms (cdr forms))) ((not forms)) ;; (let* ((*c1exit* (unless (cdr forms) *c1exit*)) ;; (form (c1expr (car forms)))) ;; (push form fl) ;; (add-info info (cadr form)))) ;; (setf (info-type info) (info-type (cadar fl))) ;; (list 'progn info (nreverse fl)))))) (defun truncate-progn-at-nil-return-p (rp forms) (when (and rp (not (info-type (cadar rp)))) (keyed-cmpnote 'nil-return "progn truncated at nil return, eliminating ~s" forms) t)) (defun c1progn (forms &optional c1forms &aux r rp (info (make-info))) (when c1forms (assert (eql (length forms) (length c1forms)))) (flet ((collect (f i) (setq rp (last (if rp (rplacd rp f) (setq r f)))) (add-info info i))) (do ((forms forms (cdr forms))) ((or (not forms) (truncate-progn-at-nil-return-p rp forms))) (let ((form (or (pop c1forms) (if (cdr forms) (c1arg (car forms)) (c1expr (car forms)))))) (cond ((and (cdr forms) (ignorable-form form))) ((eq (car form) 'progn) (collect (third form) (cadr form))) ((collect (cons form nil) (cadr form)))))) (cond ((cdr r) (setf (info-type info) (info-type (cadar rp))) (list 'progn info r)) ((car r)) ((c1nil))))) ;; (defun c1progn (forms &aux r rp) ;; (cond ((endp forms) (c1nil)) ;; ((endp (cdr forms)) (c1expr (car forms))) ;; ((let ((info (make-info))) ;; (flet ((collect ;; (f i) ;; (setq rp (last (if rp (rplacd rp f) (setq r f)))) ;; (add-info info i))) ;; (do ((forms forms (cdr forms))) ((not forms)) ;; (let ((form (if (cdr forms) (c1arg (car forms)) (c1expr (car forms))))) ;; (cond ((and (cdr forms) (ignorable-form form))) ;; ((eq (car form) 'progn) (collect (third form) (cadr form))) ;; ((collect (cons form nil) (cadr form)))))) ;; (cond ((cdr r) ;; (setf (info-type info) (info-type (cadar rp))) ;; (list 'progn info r)) ;; ((car r)) ;; ((c1nil)))))))) ;; (defun c1progn (forms &aux r rp) ;; (cond ((endp forms) (c1nil)) ;; ((endp (cdr forms)) (c1expr (car forms))) ;; ((let ((info (make-info))) ;; (flet ((collect ;; (f i) ;; (setq rp (last (if rp (rplacd rp f) (setq r f)))) ;; (add-info info i))) ;; (do ((forms forms (cdr forms))) ((not forms)) ;; (let* ((*c1exit* (unless (cdr forms) *c1exit*)) ;; (form (c1expr (car forms)))) ;; (cond ((and (cdr forms) (ignorable-form form))) ;; ((eq (car form) 'progn) (collect (third form) (cadr form))) ;; ((collect (cons form nil) (cadr form)))))) ;; (cond ((cdr r) ;; (setf (info-type info) (info-type (cadar rp))) ;; (list 'progn info r)) ;; ((car r)) ;; ((c1nil)))))))) ;(defun c1progn (forms &aux (fl nil)) ; (let ((info (make-info))) ; (dolist (form forms) ; (setq form (c1expr form)) ; (push form fl) ; (add-info info (cadr form))) ; (unless fl (push (c1nil) fl)) ; (setf (info-type info) (info-type (cadar fl))) ; (list 'progn info (reverse 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)) (when l (c2expr (car l)))) (let* ((*value-to-go* 'trash) (*exit* (next-label)) (*unwind-exit* (cons *exit* *unwind-exit*))) (c2expr (car l)) (wt-label *exit*)))) (defun c1arg (form &optional (info (make-info)) &aux *c1exit*) (c1expr* form info)) (defun c1args (forms info) (mapcar (lambda (form) (c1arg form info)) forms)) ;; (defun c1args (forms info &aux *c1exit*) ;; (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. (cond (*safe-compile* (c1expr `(si::structure-ref ,form ',name ,index))) ((let* ((sd (get name 'si::s-data)) (aet-type (aref (si::s-data-raw sd) index)) (sym (find-symbol (si::string-concatenate (or (si::s-data-conc-name sd) "") (car (nth index (si::s-data-slot-descriptions sd)))))) (tp (if sym (get-return-type sym) '*)) (tp (type-and tp (nth aet-type +cmp-array-types+)))) (setf (info-type info) (if (and (eq name 'si::s-data) (= index 2));;FIXME -- this belongs somewhere else. CM 20050106 #t(vector unsigned-char) tp)) (list 'structure-ref info (c1arg form info) (add-symbol name) index sd))))) ;; (defun c1structure-ref1 (form name index &aux (info (make-info))) ;; ;;; Explicitly called from c1expr and c1structure-ref. ;; (cond (*safe-compile* (c1expr `(si::structure-ref ,form ',name ,index))) ;; ((let* ((sd (get name 'si::s-data)) ;; (aet-type (aref (si::s-data-raw sd) index)) ;; (sym (find-symbol (si::string-concatenate ;; (or (si::s-data-conc-name sd) "") ;; (car (nth index (si::s-data-slot-descriptions sd)))))) ;; (tp (if sym (get-return-type sym) '*)) ;; (tp (type-and tp (nth aet-type +cmp-array-types+)))) ;; (setf (info-type info) (if (and (eq name 'si::s-data) (= index 2));;FIXME -- this belongs somewhere else. CM 20050106 ;; #t(vector unsigned-char) ;; tp)) ;; (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 (nth aet-type +cmp-array-types+))) (cond ((eq (inline-type type) 'inline) (or (= aet-type +aet-type-object+) (error "bad type ~a" type)))) (setf (info-type (car arg)) type) (coerce-loc (list (inline-type type) (flags) 'my-call (list (car (inline-args (list (car form)) '(t))) 'joe index sd)) 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 (nth (aref (si::s-data-raw sd) index) +cmp-array-types+))) (unwind-exit (list (inline-type type) (flags) 'my-call (list loc name-vv index sd)))) (close-inline-blocks) ) (defun c1str-ref (args) (let* ((info (make-info)) (nargs (c1args args info))) (list* 'str-ref info nargs))) (setf (get 'str-ref 'c1) 'c1str-ref) (defun c2str-ref (loc nm off) (let* ((nm (car (atomic-tp (info-type (cadr nm))))) (sd (get nm 'si::s-data)) (loc (car (inline-args (list loc) '(t)))) (off (car (atomic-tp (info-type (cadr off)))))) (unless (and off sd (not *compiler-push-events*)) (baboon)) (unwind-exit (list (inline-type (nth (aref (si::s-data-raw sd) off) +cmp-array-types+)) (flags) 'my-call (list loc nil off sd))) (close-inline-blocks))) (setf (get 'str-ref 'c2) 'c2str-ref) (defun my-call (loc name-vv ind sd);FIXME get-inline-loc above (declare (ignore name-vv)) (let* ((raw (si::s-data-raw sd)) (spos (si::s-data-slot-position sd))) (if *compiler-push-events* (wfs-error) (wt "STREF(" (aet-c-type (nth (aref raw ind) +cmp-array-types+) ) "," loc "," (aref spos ind) ")")))) (defun c1structure-set (args &aux (info (make-info :flags (iflags side-effects)))) (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 (c1arg (car args) info)) (y (c1arg (cadddr args) info))) (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)))) ;; (defun c1structure-set (args &aux (info (make-info :flags (iflags side-effects)))) ;; (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)) (declare (ignore name-vv)) (let* ((raw (si::s-data-raw sd)) (type (nth (aref raw ind) +cmp-array-types+)) (spos (si::s-data-slot-position sd)) (tftype 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 sv-wrap (x) `(symbol-value ',x)) (defun infinite-val-symbol (val) (or (car (member val '(+inf -inf nan +sinf -sinf snan) :key 'symbol-value)) (baboon))) (defun printable-long-float (val) (labels ((scl (val s) `(* ,(/ val (symbol-value s)) ,s))) (let ((nval (cond ((not (isfinite val)) `(symbol-value ',(infinite-val-symbol val))) ((> (abs val) (/ most-positive-long-float 2)) (scl val 'most-positive-long-float)) ((< 0.0 (abs val) (* least-positive-normalized-long-float 1.0d20)) (scl val 'least-positive-normalized-long-float))))) (add-object (if nval (cons '|#,| nval) val))))) (defun printable-short-float (val) (labels ((scl (val s) `(* ,(/ val (symbol-value s)) ,s))) (let ((nval (cond ((not (isfinite val)) `(symbol-value ',(infinite-val-symbol val))) ((> (abs val) (/ most-positive-short-float 2)) (scl val 'most-positive-short-float)) ((< 0.0 (abs val) (* least-positive-normalized-short-float 1.0d20)) (scl val 'least-positive-normalized-short-float))))) (add-object (if nval (cons '|#,| nval) val))))) (defun ltvp (val) (when (consp val) (eq (car val) '|#,|))) (defun c1constant-value-object (val always) (typecase val (char `(char-value nil ,val)) (immfix `(fixnum-value nil ,val)) (character `(character-value nil ,(char-code val))) (long-float `(vv ,(printable-long-float val))) (short-float `(vv ,(printable-short-float val)));FIXME ((or fixnum complex) `(vv ,(add-object val))) (otherwise (when (or always (ltvp val)) `(vv ,(add-object val)))))) (defun c1constant-value (val always &aux (val (if (exit-to-fmla-p) (not (not val)) val))) (case val ((nil) (c1nil)) ((t) (c1t)) (otherwise (let ((l (c1constant-value-object val (or always (when *compiler-compile* (not *keep-gaz*)))))) (when l `(location ,(make-info :type (or (ltvp val) (object-type (if (functionp val) (afe (cons 'df nil) (mf (fle val))) val)))) ,l)))))) ;; (defun c1constant-value (val always-p &aux (val (if (exit-to-fmla-p) (not (not val)) val))) ;; (cond ;; ((eq val nil) (c1nil)) ;; ((eq val t) (c1t)) ;; ((typep val 'char) ;; (list 'LOCATION (make-info :type (object-type val)) (list 'CHAR-VALUE nil val))) ;; ((si:fixnump val) ;; (list 'LOCATION (make-info :type (object-type val)) (list 'FIXNUM-VALUE (unless (si::seqindp val) (add-object val)) val))) ;; ((characterp val) ;; (list 'LOCATION (make-info :type (object-type val)) (list 'CHARACTER-VALUE nil (char-code val)))) ;; ((typep val 'long-float) ;; ;; We can't read in long-floats which are too big: ;; (let* (sc ;; (vv ;; (cond ((= val +inf) (add-object (cons 'si::|#,| `(symbol-value ','+inf))));This cannot be a constant list ;; ((= val -inf) (add-object (cons 'si::|#,| `(symbol-value ','-inf)))) ;; ((not (isfinite val)) (add-object (cons 'si::|#,| `(symbol-value ','nan)))) ;; ((> (abs val) (/ most-positive-long-float 2)) ;; (add-object (cons 'si::|#,| `(* ,(/ val most-positive-long-float) most-positive-long-float)))) ;; ((< 0.0 (abs val) (* least-positive-long-float 1.0d20)) ;; (add-object (cons `si::|#,| `(* ,(/ val least-positive-long-float) least-positive-long-float)))) ;; ((setq sc t) (add-object val))))) ;; ; (unless (isfinite val) (setf (info-type info) #tlong-float)) ;; `(location ,(make-info :type (object-type val)) ,(if sc `(long-float-value ,vv ,val) `(vv ,vv))))) ;; ((typep val 'short-float) ;; (list 'LOCATION (make-info :type (object-type val)) ;; (list 'SHORT-FLOAT-VALUE (add-object val) val))) ;; ((typep val #tfcomplex) ;; (list 'LOCATION (make-info :type (object-type val)) ;; (list 'FCOMPLEX-VALUE (add-object val) val))) ;; ((typep val #tdcomplex) ;; (list 'LOCATION (make-info :type (object-type val)) ;; (list 'DCOMPLEX-VALUE (add-object val) val))) ;; ((and (consp val) (eq (car val) 'si::|#,|)) ;; ; (setf (info-type info) t);(object-type (cmp-eval (cdr val)))) ;; (list 'LOCATION (make-info :type t) (list 'VV (add-object val)))) ;; ((and *compiler-compile* (not *keep-gaz*)) ;; ; (setf (info-type info) (object-type val)) ;; (list 'LOCATION (make-info :type (object-type val)) (list 'VV (add-object (cons 'si::|#,| `(si::nani ,(si::address val))))))) ;; ((and (arrayp val) (not (si::staticp val)) (eq (array-element-type val) t)) ;; This must be readable ;; (list 'LOCATION (make-info :type (object-type val)) (list 'VV (add-object val)))) ;; (always-p ;; (list 'LOCATION (make-info :type (object-type val)) (list 'VV (add-object val)))))) ;; (defun c1constant-value (val always-p); &aux (info (make-info :type (object-type val)))) ;; ; :referred-array +empty-info-array+ ;; ; :changed-array +empty-info-array+))) ;; (cond ;; ((eq val nil) (c1nil)) ;; ((eq val t) (c1t)) ;; ((typep val 'char) ;; (list 'LOCATION (make-info :type (object-type val)) (list 'CHAR-VALUE nil val))) ;; ((si:fixnump val) ;; (list 'LOCATION (make-info :type (object-type val)) (list 'FIXNUM-VALUE (unless (si::seqindp val) (add-object val)) val))) ;; ((characterp val) ;; (list 'LOCATION (make-info :type (object-type val)) (list 'CHARACTER-VALUE nil (char-code val)))) ;; ((typep val 'long-float) ;; ;; We can't read in long-floats which are too big: ;; (let* (sc ;; (vv ;; (cond ((= val +inf) (add-object (cons 'si::|#,| `(symbol-value ','+inf))));This cannot be a constant list ;; ((= val -inf) (add-object (cons 'si::|#,| `(symbol-value ','-inf)))) ;; ((not (isfinite val)) (add-object (cons 'si::|#,| `(symbol-value ','nan)))) ;; ((> (abs val) (/ most-positive-long-float 2)) ;; (add-object (cons 'si::|#,| `(* ,(/ val most-positive-long-float) most-positive-long-float)))) ;; ((< 0.0 (abs val) (* least-positive-long-float 1.0d20)) ;; (add-object (cons `si::|#,| `(* ,(/ val least-positive-long-float) least-positive-long-float)))) ;; ((setq sc t) (add-object val))))) ;; ; (unless (isfinite val) (setf (info-type info) #tlong-float)) ;; `(location ,(make-info :type (object-type val)) ,(if sc `(long-float-value ,vv ,val) `(vv ,vv))))) ;; ((typep val 'short-float) ;; (list 'LOCATION (make-info :type (object-type val)) ;; (list 'SHORT-FLOAT-VALUE (add-object val) val))) ;; ((typep val #tfcomplex) ;; (list 'LOCATION (make-info :type (object-type val)) ;; (list 'FCOMPLEX-VALUE (add-object val) val))) ;; ((typep val #tdcomplex) ;; (list 'LOCATION (make-info :type (object-type val)) ;; (list 'DCOMPLEX-VALUE (add-object val) val))) ;; ((and (consp val) (eq (car val) 'si::|#,|)) ;; ; (setf (info-type info) t);(object-type (cmp-eval (cdr val)))) ;; (list 'LOCATION (make-info :type t) (list 'VV (add-object val)))) ;; ((and *compiler-compile* (not *keep-gaz*)) ;; ; (setf (info-type info) (object-type val)) ;; (list 'LOCATION (make-info :type (object-type val)) (list 'VV (add-object (cons 'si::|#,| `(si::nani ,(si::address val))))))) ;; ((and (arrayp val) (not (si::staticp val)) (eq (array-element-type val) t)) ;; This must be readable ;; (list 'LOCATION (make-info :type (object-type val)) (list 'VV (add-object val)))) ;; (always-p ;; (list 'LOCATION (make-info :type (object-type val)) (list 'VV (add-object val)))))) ;FIXME check readability (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 (member 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 co1structure-predicate (f args &aux tem) (cond ((and (symbolp f) (setq tem (get f 'si::struct-predicate)) args (not (cdr args))) (c1expr `(typep ,(car args) ',tem))))) ;;New C ffi ; (defmacro defdlfun ((crt name &optional (lib "")) &rest tps &aux (tsyms (load-time-value (mapl (lambda (x) (setf (car x) (gensym "DEFDLFUN"))) (make-list call-arguments-limit))))) (unless (>= (length tsyms) (length tps)) (baboon)) (flet ((cc (x) (if (consp x) (car x) x))) (let* ((sym (mdlsym name lib)) (dls (strcat "DL" name)) (ttps (mapcan (lambda (x) (if (atom x) (list x) (list (list (car x)) (cadr x)))) tps)) (args (mapcar (lambda (x) (declare (ignore x)) (pop tsyms)) ttps)) (cast (apply 'strcat (maplist (lambda (x) (strcat (cc (car x)) (if (cdr x) "," ""))) tps))) (cast (strcat "(" crt "(*)(" cast "))"))) `(defun ,sym ,args (declare (optimize (safety 2))) ,@(mapcar (lambda (x y) `(check-type ,x ,(get (cc y) 'lisp-type))) args ttps) (cadd-dladdress ,dls ,sym) (lit ,crt ,@(when (eq crt :void) `("(")) "(" ,cast "(" ,dls "))(" ,@(mapcon (lambda (x y) `((,(cc (car x)) ,(car y)) ,(if (cdr x) (if (consp (car x)) "+" ",") ""))) ttps args) ")" ,@(when (eq crt :void) `(",Cnil)"))))))) (defun c1cadd-dladdress (args) (list 'cadd-dladdress (make-info :type #tnull) args)) (defun c2cadd-dladdress (args) (apply 'add-dladdress args)) (si::putprop 'cadd-dladdress 'c1cadd-dladdress 'c1) (si::putprop 'cadd-dladdress 'c2cadd-dladdress 'c2) (defun c1clines (args) (list 'clines (make-info :type nil) (with-output-to-string (s) (princ (car args) s)))) (defun c2clines (clines) (wt-nl clines)) (si::putprop 'clines 'c1clines 'c1) (si::putprop 'clines 'c2clines 'c2) ;; (define-compiler-macro typep (&whole form &rest args &aux (info (make-info))(nargs (c1args args info))) ;; (let* ((info (make-info)) ;; (nargs (with-restore-vars (c1args args info))) ;; (tp (info-type (cadar nargs))) ;; (a (atomic-tp (info-type (cadadr nargs)))) ;; (c (cmp-norm-tp (car a)))) ;; (if (when a (constant-type-p (car a))) ;; (cond ((type>= c tp) (print (list c tp t)) t) ;; ((not (type-and c tp)) (print (list c tp nil)) nil) ;; (form));FIXME hash here ;; form))) (define-compiler-macro fset (&whole form &rest args) (when *sig-discovery* (let* ((info (make-info)) (nargs (with-restore-vars (c1args args info))) (ff (cadr nargs)) (fun (when (eq (car ff) 'function) (caaddr ff))) (fun (when (fun-p fun) fun)) (sym (car (atomic-tp (info-type (cadar nargs)))))) (when (and sym fun);FIXME (push (cons sym (apply 'si::make-function-plist (fun-call fun))) si::*sig-discovery-props*)))) form) (define-compiler-macro typep (&whole form &rest args) (with-restore-vars (let* ((info (make-info)) (nargs (c1args args info)) (tp (info-type (cadar nargs))) (a (atomic-tp (info-type (cadadr nargs)))) (c (if (when a (constant-type-p (car a))) (cmp-norm-tp (car a)) '*))) (cond ((eq c '*) form) ((member-if-not 'ignorable-form nargs) form) ((type>= c tp) (keep-vars) t) ((not (type-and c tp)) (keep-vars) nil) ((when (consp (car a)) (eq (caar a) 'or)) `(typecase ,(car args) (,(car a) t))) (form)))));FIXME hash here (define-compiler-macro vector-push-extend (&whole form &rest args) (let* ((vref (when (symbolp (cadr args)) (c1vref (cadr args)))) (var (car vref))) (when vref (do-setq-tp var form (reduce (lambda (y x) (if (type-and y x) (type-or1 y x) y)) '#.(mapcar (lambda (x) (cmp-norm-tp `(,(cdr x) 1))) si::*all-array-types*) :initial-value (var-type var))))) form) gcl27-2.7.0/cmpnew/gcl_cmpflet.lsp000077500000000000000000001250721454061450500167440ustar00rootroot00000000000000;; -*-Lisp-*- ;;; 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 (:print-function (lambda (x s i) (s-print 'fun (fun-name x) (si::address x) s)))) 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)))) (call (make-list 6));FIXME vv src c1 c1cb fn) (defun local-fun-fn (id) (let* ((fun (local-fun-p id))) (when fun (fun-fn fun)))) ;; (defun local-fun-fun (id) ;; (let* ((fun (local-fun-p id))) ;; (when fun (car (atomic-tp (info-type (cadr (fun-prov fun)))))))) ;; (defun local-fun-src (id) ;; (let ((fun (local-fun-fun id)));FUN-SRC? ;; (when fun (function-lambda-expression fun)))) (defun local-fun-src (id) (let ((fun (local-fun-p id))) (when fun (fun-src fun)))) (si::freeze-defstruct 'fun) (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). (defvar *restore-vars-env* nil) (defmacro with-restore-vars (&rest body &aux (rv (sgen "WRV-"))(wns (sgen "WRVW-"))) `(let (,rv (,wns *warning-note-stack*)) (declare (ignorable ,rv)) (labels ((keep-vars nil (setq ,rv *restore-vars*)(keep-warnings)) (keep-warnings nil (setq ,wns *warning-note-stack*)) (pop-restore-vars nil (setq *warning-note-stack* ,wns) (mapc (lambda (l &aux (v (pop l))(tp (pop l))(st (car l))) (keyed-cmpnote (list (var-name v) 'type-propagation 'type) "Restoring var type on ~s from ~s to ~s" (var-name v) (cmp-unnorm-tp (var-type v)) (cmp-unnorm-tp tp)) (setf (var-type v) tp (var-store v) st)) (ldiff-nf *restore-vars* ,rv)))) (prog1 (let (*restore-vars* (*restore-vars-env* *vars*)) (unwind-protect (progn ,@body) (pop-restore-vars))) (mapc (lambda (l) (when (member (car l) *restore-vars-env*) (pushnew l *restore-vars* :key 'car))) ,rv))))) (defun ref-environment (&aux inner) (dolist (fun *funs*) (when (or (eq fun 'cb) (eq fun 'lb)) (setq inner (or inner fun)))) (when (eq inner 'cb) (ref-inner inner))) (defun bump-closure-lam-sig (lam) (flet ((nt (x) (type-or1 x #tt))) (mapc (lambda (x) (setf (var-type x) (nt (var-type x)))) (caaddr lam)) (let ((i (cadar (last lam)))) (setf (info-type i) (nt (info-type i)))) (lam-e-to-sig lam))) (defun process-local-fun (b fun def tp) (let* ((name (fun-name fun)) (lam (do-fun name (cons name (cdr def)) (fun-call fun) (member fun *funs*) b)) (res (list fun lam))) ;closures almost always called anonymously which will be slow unless argd is 0 (unless (tailp (member-if-not 'fun-p *funs*) (member fun *funs*)) (setf (car (fun-call fun)) (bump-closure-lam-sig lam))) (ref-environment);FIXME? (setf (fun-cfun fun) (next-cfun)) (add-info (fun-info fun) (cadr lam));FIXME copy-info? (setf (info-type (fun-info fun)) (cadar (fun-call fun))) (setf (info-type (cadr lam)) tp) res)) ;; (defun process-local-fun (b fun def tp) ;; (let* ((name (fun-name fun)) ;; (lam (do-fun name (cons name (cdr def)) (fun-call fun) (member fun *funs*) b)) ;; ; (cvs (let (r) (do-referred (v (cadr lam)) (when (and (var-p v) (var-cbb v)) (push v r))) r)) ;; (res (list fun lam)) ;; ; (l (si::interpreted-function-lambda (cadr tp))) ;; ) ;; ;closures almost always called anonymously which will be slow unless argd is 0 ;; (when (or (eq b 'cb) (fun-ref-ccb fun)) (setf (car (fun-call fun)) (bump-closure-lam-sig lam))) ;; (ref-environment) ;; (setf (fun-cfun fun) (next-cfun)) ;; ; (setf (cadr l) cvs) ;; (add-info (fun-info fun) (cadr lam));FIXME copy-info? ;; (setf (info-type (fun-info fun)) (cadar (fun-call fun))) ;; (setf (info-type (cadr lam)) tp) ;; res)) (defun ref-funs (form funs) (ref-obs form funs (lambda (x) (setf (fun-ref-ccb x) t)) (lambda (x)) (lambda (x) (setf (fun-ref x) t)) 'fun-name "Fun" (lambda (x &aux (y (pop x))) (when (eq y 'call-local) (butlast (cadr x)))))) ;; (defun ref-funs1 (form funs &aux (i (cadr form))) ;; (dolist (fun funs) ;; (when (member fun (info-fref-ccb i)) ;; (setf (fun-ref-ccb fun) t)) ;; (when (member fun (info-fref i)) ;; (setf (fun-ref fun) t)))) ;; (defun ref-funs (form funs &optional l) ;; (cond ((not l) ;; (cond (*fast-ref* (ref-funs1 form funs)) ;; ((let* ((l (list (info-fref (cadr form)) (info-fref-ccb (cadr form)))) ;; (l (mapcar (lambda (x) (intersection x funs)) l)) ;; (l (mapcar (lambda (y) (mapcar (lambda (x) (cons x nil)) y)) l))) ;; (ref-funs form funs l) ;; (let* (y (x (member-if (lambda (x) (setq y (member nil x :key 'cdr))) l))) ;; (when y ;; (cmpwarn "~s Fun ~s reffed in info but not in form" (length (ldiff l x)) (var-name (caar y))))))))) ;; ((atom form)) ;; ((eq (car form) 'call-local) ;; (let* ((fref (caddr form)) ;; (f (pop fref)) ;; (ccb (car fref))) ;; (when (member f funs) ;; (if ccb (setf (fun-ref-ccb f) t) (setf (fun-ref f) t)) ;; (let* ((x (if ccb (cadr l) (car l)))(x (assoc f x))) ;; (if x (rplacd x t) (cmpwarn "~a Fun ~s reffed in form but not in info" (if ccb "ccb" "nil") (fun-name f)))) ;; (keyed-cmpnote (list 'fun-ref (fun-name f)) "Fun ~s is referred with barrier ~s" (fun-name f) (when ccb 'cb))) ;; (ref-funs (cdddr form) funs l))) ;; (t (ref-funs (car form) funs l) (ref-funs (cdr form) funs l)))) (defun effective-safety-src (src &aux (n (pop src))(ll (pop src))) (multiple-value-bind (doc decls ctps body) (parse-body-header src) `(,n ,ll ,@(when doc (list doc)) ,@(cons `(declare (optimize (safety ,(this-safety-level)))) decls) ,@ctps ,@body))) (defvar *local-fun-inline-limit* 200) (defun c1flet-labels (labels args &aux body ss ts is other-decl (info (make-info)) defs1 fnames (ofuns *funs*) (*funs* *funs*)) (when (endp args) (too-few-args 'flet 1 0)) (dolist (def (car args) (setq defs1 (nreverse defs1))) (let* ((x (car def))(y (si::funid-sym x))) (unless (eq x y) (setq def (cons y (cdr def))))) (cmpck (or (endp def) (endp (cdr def))) "The function definition ~s is illegal." def) (when labels (cmpck (member (car def) fnames) "The function ~s was already defined." (car def)) (push (car def) fnames)) (let* ((def (effective-safety-src def)) (src (si::block-lambda (cadr def) (car def) (cddr def))) (fun (make-fun :name (car def) :src src :info (make-info :type nil :sp-change 1)))) (push fun *funs*) (unless (< (cons-count src) *local-fun-inline-limit*) (keyed-cmpnote (list (car def) 'notinline) "Blocking inline of large local fun ~s" (car def)) (pushnew (car def) *notinline*)) (push (list fun (cdr def)) defs1))) (let ((*funs* (if labels *funs* ofuns))) ; (mapc (lambda (x &aux (x (car x))) (setf (fun-fn x) (afe (cons 'df (current-env)) (mf (fun-name x))))) defs1)) (mapc (lambda (x &aux (x (car x))) (setf (fun-fn x) (mf (fun-name x)))) defs1)) (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t)) (c1add-globals ss) (check-vdecl nil ts is) (setq body (c1decl-body other-decl body)) (let ((nf (mapcar 'car defs1))) (ref-funs body nf) (when labels (do (fun) ((not (setq fun (car (member-if (lambda (x) (or (fun-ref x) (fun-ref-ccb x))) nf))))) (setq nf (remove fun nf)) (when (fun-ref fun) (ref-funs (fun-c1 fun) nf)) (when (fun-ref-ccb fun) (ref-funs (fun-c1cb fun) nf))))) (add-info info (cadr body)) (setf (info-type info) (info-type (cadr body))) (let* ((funs (mapcar 'car defs1)) (fns (mapcar (lambda (x) (caddr (fun-c1 x))) (remove-if-not 'fun-ref funs))) (cls (mapcar (lambda (x) (caddr (fun-c1cb x))) (remove-if-not 'fun-ref-ccb funs)))) (if (or fns cls) (list (if labels 'labels 'flet) info fns cls body) body))) ;; (defun c1flet-labels (labels args &aux body ss ts is other-decl (info (make-info)) ;; defs1 fnames (ofuns *funs*) (*funs* *funs*)) ;; (when (endp args) (too-few-args 'flet 1 0)) ;; (dolist (def (car args) (setq defs1 (nreverse defs1))) ;; (let* ((x (car def))(y (si::funid-sym x))) (unless (eq x y) (setq def (cons y (cdr def))))) ;; (cmpck (or (endp def) (endp (cdr def))) "The function definition ~s is illegal." def) ;; (when labels ;; (cmpck (member (car def) fnames) "The function ~s was already defined." (car def)) ;; (push (car def) fnames)) ;; (let* ((src (si::block-lambda (cadr def) (car def) (cddr def))) ;; (fun (make-fun :name (car def) :src src :info (make-info :type nil :sp-change 1)))) ;; (push fun *funs*) ;; (push (list fun (cdr def)) defs1))) ;; (let ((*funs* (if labels *funs* ofuns))) ;; ; (mapc (lambda (x &aux (x (car x))) (setf (fun-fn x) (afe (cons 'df (current-env)) (mf (fun-name x))))) defs1)) ;; (mapc (lambda (x &aux (x (car x))) (setf (fun-fn x) (mf (fun-name x)))) defs1)) ;; (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t)) ;; (c1add-globals ss) ;; (check-vdecl nil ts is) ;; (setq body (c1decl-body other-decl body)) ;; (let ((nf (mapcar 'car defs1))) ;; (ref-funs body nf) ;; (when labels ;; (do (fun) ((not (setq fun (car (member-if (lambda (x) (or (fun-ref x) (fun-ref-ccb x))) nf))))) ;; (setq nf (remove fun nf)) ;; (when (fun-ref fun) ;; (ref-funs (fun-c1 fun) nf)) ;; (when (fun-ref-ccb fun) ;; (ref-funs (fun-c1cb fun) nf))))) ;; (add-info info (cadr body)) ;; (setf (info-type info) (info-type (cadr body))) ;; (let ((funs (mapcar 'car defs1))) ;; (list (if labels 'labels 'flet) info ;; (mapcar (lambda (x) (caddr (fun-c1 x))) (remove-if-not 'fun-ref funs)) ;; (mapcar (lambda (x) (caddr (fun-c1cb x))) (remove-if-not 'fun-ref-ccb funs)) ;; body))) ;; (defun c1flet-labels (labels args &aux body ss ts is other-decl (info (make-info)) ;; defs1 fnames (ofuns *funs*) (*funs* *funs*)) ;; (when (endp args) (too-few-args 'flet 1 0)) ;; (dolist (def (car args) (setq defs1 (nreverse defs1))) ;; (let* ((x (car def))(y (si::funid-sym x))) (unless (eq x y) (setq def (cons y (cdr def))))) ;; (cmpck (or (endp def) (endp (cdr def))) "The function definition ~s is illegal." def) ;; (when labels ;; (cmpck (member (car def) fnames) "The function ~s was already defined." (car def)) ;; (push (car def) fnames)) ;; (let* ((src (si::block-lambda (cadr def) (car def) (cddr def))) ;; (fun (make-fun :name (car def) :src src :info (make-info :type nil :sp-change 1) :fn (funid-to-fn (car def))))) ;; (push fun *funs*) ;; (push (list fun (cdr def)) defs1))) ;; (let ((*funs* (if labels *funs* ofuns))) ;; (mapc (lambda (x &aux (x (car x))) ;; (setf (fun-c1 x) (c1function (list (fun-src x)) t) ;; (fun-c1cb x) (copy-list (fun-c1 x)))) defs1)) ;; (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t)) ;; (c1add-globals ss) ;; (check-vdecl nil ts is) ;; (setq body (c1decl-body other-decl body)) ;; (mapc (lambda (x) (add-info info (fun-info (car x)))) defs1) ;; (add-info info (cadr body)) ;; (setf (info-type info) (info-type (cadr body))) ;; (let ((funs (mapcar 'car defs1))) ;; (list (if labels 'labels 'flet) info ;; (mapcar (lambda (x) (caddr (fun-c1 x))) (remove-if-not 'fun-ref funs)) ;; (mapcar (lambda (x) (caddr (fun-c1cb x))) (remove-if-not 'fun-ref-ccb funs)) ;; body))) ;; (defun c1flet-labels (labels args &aux body ss ts is other-decl (info (make-info)) ;; defs1 fnames (ofuns *funs*) (*funs* *funs*)) ;; (when (endp args) (too-few-args 'flet 1 0)) ;; (dolist (def (car args) (setq defs1 (nreverse defs1))) ;; (let* ((x (car def))(y (si::funid-sym x))) (unless (eq x y) (setq def (cons y (cdr def))))) ;; (cmpck (or (endp def) (endp (cdr def))) "The function definition ~s is illegal." def) ;; (when labels ;; (cmpck (member (car def) fnames) "The function ~s was already defined." (car def)) ;; (push (car def) fnames)) ;; (let* ((src (si::block-lambda (cadr def) (car def) (cddr def))) ;; (fun (make-fun :name (car def) :src src :info (make-info :type nil :sp-change 1) :fn (funid-to-fn src)))) ;; (push fun *funs*) ;; (push (list fun (cdr def)) defs1))) ;; (let ((*funs* (if labels *funs* ofuns))) ;; (mapc (lambda (x &aux (x (car x))) (setf (fun-prov x) (c1function (list (fun-src x)) t))) defs1)) ;; ; (mapc (lambda (x) (setf (fun-denv (car x)) (current-env))) defs1)) ;; (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t)) ;; (c1add-globals ss) ;; (check-vdecl nil ts is) ;; (setq body (c1decl-body other-decl body)) ;; (mapc (lambda (x) (add-info info (fun-info (car x)))) defs1) ;; (add-info info (cadr body)) ;; (setf (info-type info) (info-type (cadr body))) ;; (let ((funs (mapcar 'car defs1))) ;; (list (if labels 'labels 'flet) info ;; (mapcar 'fun-c1 (remove-if-not 'fun-ref funs)) ;; (mapcar 'fun-c1cb (remove-if-not 'fun-ref-ccb funs)) ;; body))) (defun c1flet (args) (c1flet-labels nil args)) (defun c2flet-labels (labels local-funs closures body &aux (*vs* *vs*) (oclink *clink*) (*clink* *clink*) (occb-vs *ccb-vs*) (*ccb-vs* *ccb-vs*)) (mapc (lambda (def &aux (fun (car def))) (setf (fun-ref fun) (vs-push)) (clink (fun-ref fun)) (setf (fun-ref-ccb fun) (ccb-vs-push))) closures) (mapc (lambda (def &aux (fun (car def))) (when (eq (fun-ref fun) t) (setf (fun-ref fun) (vs-push)))) local-funs) (let ((*clink* (if labels *clink* oclink)) (*ccb-vs* (if labels *ccb-vs* occb-vs))) (mapc (lambda (def &aux (fun (pop def))) (setf (fun-level fun) *level*) (push (list nil *clink* *ccb-vs* fun (car def) *initial-ccb-vs*) *local-funs*)) local-funs) (when (or local-funs closures) (base-used));fixme (dolist (def closures) (let* ((fun (pop def)) (lam (car def)) (cl (update-closure-indices (fun-call fun))) (sig (car cl)) (at (car sig)) (rt (cadr sig))) (push (list 'closure (if (null *clink*) nil (cons 0 0)) *ccb-vs* fun lam) *local-funs*) (wt-nl) (wt-vs* (fun-ref fun)) (wt "=") (setf (fun-vv fun) (cons '|#,| (export-call-struct cl))) (wt-make-cclosure (fun-cfun fun) (fun-name fun) (fun-vv fun) (new-proclaimed-argd at rt) (argsizes at rt (xa lam)) *clink*) (wt ";") (wt-nl)))) (c2expr body)) ;; (defun c2flet-labels (labels local-funs closures body ;; &aux (*vs* *vs*) (oclink *clink*) (*clink* *clink*) ;; (occb-vs *ccb-vs*) (*ccb-vs* *ccb-vs*)) ;; (mapc (lambda (def &aux (fun (car def))) ;; (setf (fun-ref fun) (vs-push)) ;; (clink (fun-ref fun)) ;; (setf (fun-ref-ccb fun) (ccb-vs-push))) closures) ;; (mapc (lambda (def &aux (fun (car def))) ;; (when (eq (fun-ref fun) t) (setf (fun-ref fun) (vs-push)))) local-funs) ;; (let ((*clink* (if labels *clink* oclink)) ;; (*ccb-vs* (if labels *ccb-vs* occb-vs))) ;; (mapc (lambda (def &aux (fun (pop def))) ;; (setf (fun-level fun) *level*) ;; (push (list nil *clink* *ccb-vs* fun (car def) *initial-ccb-vs*) *local-funs*)) local-funs) ;; (when (or local-funs closures) (base-used));fixme ;; (dolist (def closures) ;; (let* ((fun (pop def)) ;; (lam (car def)) ;; (cl (fun-call fun)) ;; (sig (car cl)) ;; (at (car sig)) ;; (rt (cadr sig))) ;; (push (list 'closure (if (null *clink*) nil (cons 0 0)) *ccb-vs* fun lam) *local-funs*) ;; (wt-nl) ;; (wt-vs* (fun-ref fun)) ;; (wt "=") ;; (setf (fun-vv fun) ;; (cons '|#,| `(let ((si::f #'(lambda nil nil))) ;; (si::add-hash si::f ,@(mapcar (lambda (x) `',x) (export-call cl))) ;; ; (si::call si::f) ;; si::f))) ;; (wt-make-cclosure (fun-cfun fun) (fun-name fun) ;; (fun-vv fun) (new-proclaimed-argd at rt) (argsizes at rt (xa lam)) *clink*) ;; (wt ";") ;; (wt-nl)))) ;; (c2expr body)) ;; (defun c2flet-labels (labels local-funs closures body ;; &aux (*vs* *vs*) (oclink *clink*) (*clink* *clink*) ;; (occb-vs *ccb-vs*) (*ccb-vs* *ccb-vs*)) ;; (mapc (lambda (def &aux (fun (car def))) ;; (setf (fun-ref fun) (vs-push)) ;; (clink (fun-ref fun)) ;; (setf (fun-ref-ccb fun) (ccb-vs-push))) closures) ;; (mapc (lambda (def &aux (fun (car def))) ;; (when (eq (fun-ref fun) t) (setf (fun-ref fun) (vs-push)))) local-funs) ;; (let ((*clink* (if labels *clink* oclink)) ;; (*ccb-vs* (if labels *ccb-vs* occb-vs))) ;; (mapc (lambda (def &aux (fun (pop def))) ;; (setf (fun-level fun) *level*) ;; (push (list nil *clink* *ccb-vs* fun (car def) *initial-ccb-vs*) *local-funs*)) local-funs) ;; (when (or local-funs closures) (base-used));fixme ;; (dolist (def closures) ;; (let* ((fun (pop def)) ;; (lam (car def)) ;; (cl (fun-call fun)) ;; (sig (car cl)) ;; (at (car sig)) ;; (rt (cadr sig))) ;; (push (list 'closure (if (null *clink*) nil (cons 0 0)) *ccb-vs* fun lam) *local-funs*) ;; (wt-nl) ;; (wt-vs* (fun-ref fun)) ;; (wt "=") ;; (wt-make-cclosure (fun-cfun fun) (fun-name fun) ;; (1+ *next-vv*) (new-proclaimed-argd at rt) (argsizes at rt (xa lam)) *clink*) ;; (wt ";") ;; (wt-nl) ;; (push-data-incf nil) ;; (add-init ;; `(si::setvv ,*next-vv* ;; (let ((si::f #'(lambda nil nil))) ;; (si::add-hash si::f ,@(mapcar (lambda (x) `',x) (export-call cl))) ;; (si::call si::f))) t)))) ;; (c2expr body)) ;; (defun c2flet-labels (labels local-funs closures body ;; &aux (*vs* *vs*) (oclink *clink*) (*clink* *clink*) ;; (occb-vs *ccb-vs*) (*ccb-vs* *ccb-vs*)) ;; (dolist (def closures) ;; (let ((fun (car def))) ;; (setf (fun-ref fun) (vs-push)) ;; (clink (fun-ref fun)) ;; (setf (fun-ref-ccb fun) (ccb-vs-push)))) ;; (let ((*clink* (if labels *clink* oclink)) ;; (*ccb-vs* (if labels *ccb-vs* occb-vs))) ;; (dolist (def local-funs) ;; (setf (fun-level (car def)) *level*) ;; (push (list nil *clink* *ccb-vs* (car def) (cadr def) *initial-ccb-vs*) *local-funs*)) ;; (when (or local-funs closures) (base-used));fixme ;; (dolist (def closures) ;; (push (list 'closure (if (null *clink*) nil (cons 0 0)) *ccb-vs* (car def) (cadr def)) *local-funs*) ;; (let* ((fun (car def)) ;; (cl (fun-call fun)) ;; (sig (car cl)) ;; (at (car sig)) ;; (rt (cadr sig))) ;; (wt-nl) ;; (wt-vs* (fun-ref fun)) ;; (wt "=") ;; (wt-make-cclosure (fun-cfun fun) (fun-name fun) ;; (1+ *next-vv*) (new-proclaimed-argd at rt) (argsizes at rt (xa (cadr def))) *clink*) ;; (wt ";") ;; (wt-nl) ;; (push-data-incf nil) ;; (add-init ;; `(si::setvv ,*next-vv* ;; (let ((si::f #'(lambda nil nil))) ;; (si::add-hash si::f ,@(mapcar (lambda (x) `',x) (cons (export-sig (car cl)) (cdr cl)))) ;; (si::call si::f))) t)))) ;; (c2expr body)) (defun c2flet (local-funs closures body) (c2flet-labels nil local-funs closures body)) (defun c1labels (args) (c1flet-labels t args)) (defun c2labels (local-funs closures body) (c2flet-labels t local-funs closures body)) (defvar *macrolet-env* nil) (defun c1macrolet (args &aux body ss ts is other-decl env (*funs* *funs*) (*vars* *vars*) (*macrolet-env* *macrolet-env*)) (when (endp args) (too-few-args 'macrolet 1 0)) (dolist (def (car args)) (let* ((x (car def))(y (si::funid-sym x))) (unless (eq x y) (setq def (cons y (cdr def))))) (cmpck (or (endp def) (endp (cdr def))) "The macro definition ~s is illegal." def) (let* ((n (car def)) (b (eval (si::defmacro-lambda n (cadr def) (cddr def))))) (push (list n 'macro b) env))) (when env (setq *macrolet-env* (list nil (append (cadr *macrolet-env*) (nreverse env)) nil))) (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 ref-inner (b) (when (eq b 'cb) (let* ((bv (member b *vars*)) (fv (member-if 'is-fun-var (nreverse (ldiff *vars* bv))))) (when fv (setf (var-ref (car fv)) t))))) ;; (defun ref-inner (b) ;; (when (eq b 'cb) ;; (let* ((bv (member b *vars*)) ;; (fv (member-if 'is-fun-var *vars*))) ;; (when fv ;; (when (tailp bv fv) ;; (setf (var-ref (car fv)) t)))))) ;(defvar *local-fun-recursion* nil) ;; (defun c1local-fun (fname &aux ccb prev inner) ;; (dolist (fun *funs*) ;; (cond ((eq fun 'cb) (setq ccb t inner (or inner 'cb))) ;; ((eq fun 'lb) (setq inner (or inner 'lb))) ;; ((eq (fun-name fun) fname) ;; (cond (ccb (ref-inner inner) (setf prev (fun-ref-ccb fun) (fun-ref-ccb fun) t)) ;; ((setf prev (fun-ref fun) (fun-ref fun) t))) ;; (unless prev ;; (unless (member fname *local-fun-recursion*) ;; (let* ((*local-fun-recursion* (cons fname *local-fun-recursion*))) ;; (setf (fun-c1 fun) (unfoo (fun-prov fun) (if ccb 'cb 'lb) fun))))) ;; (setf (info-type (fun-info fun)) (cadar (fun-call fun))) ;; (return (list 'call-local (fun-info fun) (list fun ccb))))))) ;; (defun make-fun-c1 (fun b env &optional osig) ;; (let* ((res (under-env env (c1function (list (fun-src fun) b fun)))) ;; (sig (car (fun-call fun)))) ;; (if (and (is-referred fun (cadr res)) (not (eq (cadr osig) (cadr sig)))) ;; (make-fun-c1 fun b env sig)) ;; res)) ;; (defmacro make-local-fun (c1 b f env) ;; `(progn ;; (unless (,c1 ,f) (setf (,c1 ,f) t (,c1 ,f) (make-fun-c1 ,f ',b ,env))) ;; (when (listp (,c1 ,f)) (,c1 ,f)))) (defvar *force-fun-c1* nil) (defvar *fun-stack* nil) (defun ifunp (key pred l) (car (member-if (lambda (x) (when (fun-p x) (funcall pred x (funcall key x)))) l))) (defun ifunm (pred i) (or (ifunp 'fun-c1 pred (info-ref i)) (ifunp 'fun-c1cb pred (info-ref-ccb i)))) (defun all-callees (i) (when i (nconc (mapcan (lambda (x) (when (fun-p x) (list (list x)))) (info-ref i)) (mapcan (lambda (x) (when (fun-p x) (list (list x t)))) (info-ref-ccb i))))) (defun callee-sigs (i) (mapcar (lambda (x) (cons x (car (fun-call (car x))))) (all-callees i))) (defun invalidate (s) (unless (eq s *fun-stack*) (let* ((k (car (car s)))) (keyed-cmpnote (list (fun-name (car k)) 'local) "invalidating local fun ~s" k) (if (cdr k) (setf (fun-c1cb (car k)) nil) (setf (fun-c1 (car k)) nil)) (let ((*fun-stack* s)) (mapc 'invalidate (fourth (car s)))) (invalidate (cdr s))))) (defun recursive-loop-funs (s) (unless (eq s *fun-stack*) (let* ((k (car (car s)))) (let ((*fun-stack* s)) (mapc 'recursive-loop-funs (fourth (car s)))) (pushnew (car k) (recursive-loop-funs (cdr s))))));FIXME (defun fun-stack (key res) (list key (car (fun-call (car key))) (callee-sigs (cadr res)) nil res)) (defun make-fun-c1 (fun ccb env &optional prev &aux (c1 (if ccb (fun-c1cb fun) (fun-c1 fun))) (key (cons fun ccb)) tmp) (labels ((set (fun val) (if ccb (setf (fun-c1cb fun) val) (setf (fun-c1 fun) val)))) (cond (c1 (keyed-cmpnote (list (fun-name fun) 'local) "returning finalized value for local fun ~s" key) c1) ((setq tmp (assoc key *fun-stack* :test 'equal)) (keyed-cmpnote (list (fun-name fun) 'local) "returning trial value for local fun ~s" key) (pushnew *fun-stack* (fourth tmp)) (fifth tmp)) ((let* ((i (keyed-cmpnote (list (fun-name fun) 'local) "processing local fun ~s" key)) (*fun-stack* (cons (fun-stack key prev) *fun-stack*)) (res (under-env env (c1function (list (fun-src fun)) (if ccb 'cb 'lb) fun))) (fun-stack-prev (pop *fun-stack*)) (recursive-p (fourth fun-stack-prev)) (i (cadr res)) (callees (all-callees i))) (declare (ignore i)) (when recursive-p (setf (info-flags (fun-info fun)) (logior (info-flags (fun-info fun)) (iflags compiler)))) (cond ((iflag-p (info-flags i) provisional) (keyed-cmpnote (list (fun-name fun) 'provisional 'local) "local fun ~s provisionally processed" key) res) ((unless (member-if (lambda (x) (assoc x *fun-stack* :test 'equal)) callees) (when recursive-p (or (not (equal (cadr fun-stack-prev) (car (fun-call fun)))) ; (member-if-not (lambda (x &aux (y (assoc x (caddr fun-stack-prev) :test 'equal))) (when y (equal (cdr y) (car (fun-call (car x)))))) callees) ))) (mapc 'invalidate (fourth fun-stack-prev)) (keyed-cmpnote (list (fun-name fun) 'local) "reprocessing unfinished local fun ~s on sig mismatch: ~s" key (list (butlast fun-stack-prev 2) (butlast (fun-stack key res) 2))) (make-fun-c1 fun ccb env res)) (t (keyed-cmpnote (list (fun-name fun) 'local) "finalizing local fun ~s" key) (set fun res)))))))) ;; (defun make-fun-c1 (fun ccb env &optional osig ;; &aux (c1 (if ccb (fun-c1cb fun) (fun-c1 fun))) tmp (*fun-stack* (cons (cons fun ccb) *fun-stack*))) ;; (labels ((set (fun val) (if ccb (setf (fun-c1cb fun) val) (setf (fun-c1 fun) val))) ;; (ifunp (key pred l) (car (member-if (lambda (x) (when (fun-p x) (funcall pred x (funcall key x)))) l))) ;; (ifunm (pred i) (or (ifunp 'fun-c1 pred (info-ref i)) (ifunp 'fun-c1cb pred (info-ref-ccb i)))) ;; (calls-blocked-fun-p (fun i) (ifunm (lambda (x y) (unless (eq x fun) (eq y t))) i)) ;; (unfinished-p (fun i) (ifunm (lambda (x y) (not y)) i)) ;; (blocked-above nil (member-if (lambda (x &aux (y (pop x))) (eq t (if x (fun-c1cb y) (fun-c1 y)))) (cdr *fun-stack*)))) ;; ; (recursive-p (fun i) (ifunm (lambda (x y) (when y (eq x fun))) i))) ;; (cond ((eq c1 t) ;; (keyed-cmpnote (list (fun-name fun) 'recursion) "recursive call to local fun ~s" (fun-name fun)) ;; nil) ;; ((unless osig c1)) ;; ((let* ((c1 (or c1 (set fun t))) ;; (res (under-env env (c1function (list (fun-src fun)) (if ccb 'cb 'lb) fun))) ;; (i (cadr res)) ;; (sig (car (fun-call fun)))) ;; (cond ((setq tmp (calls-blocked-fun-p fun i)) ;; (keyed-cmpnote (list (fun-name fun) 'recursion) "local fun ~s calls unfinalized funs ~s" (fun-name fun) tmp) ;; (set fun nil)) ;; ((setq tmp (unfinished-p fun i)) ;; (cond ((blocked-above) ;; (keyed-cmpnote (list (fun-name fun) 'recursion) "setting unfinished fun ~s to nil, ufun ~s" (fun-name fun) tmp) ;; (set fun nil)) ;; ((eq c1 t) ;; (keyed-cmpnote (list (fun-name fun) 'recursion) "reprocessing unfinished local fun ~s: ~s" (fun-name fun) tmp) ;; (set fun res) ;; (make-fun-c1 fun ccb env sig)) ;; ((set fun res) ))) ;; ;; ((when (recursive-p fun i) (not (eq (cadr osig) (cadr sig))));FIXME bump? ;; ;; (keyed-cmpnote (list (fun-name fun) 'recursion) "reprocessing recursive local fun ~s: ~s ~s" (fun-name fun) osig sig) ;; ;; (set fun res) ;; ;; (make-fun-c1 fun ccb env sig)) ;; ((set fun res)))))))) ;; (defun make-fun-c1 (fun ccb env &optional osig ;; &aux (c1 (if ccb (fun-c1cb fun) (fun-c1 fun))) tmp (*fun-stack* (cons (cons fun ccb) *fun-stack*))) ;; (labels ((set (fun val) (if ccb (setf (fun-c1cb fun) val) (setf (fun-c1 fun) val))) ;; (ifunp (key pred l) (car (member-if (lambda (x) (when (fun-p x) (funcall pred x (funcall key x)))) l))) ;; (ifunm (pred i) (or (ifunp 'fun-c1 pred (info-ref i)) (ifunp 'fun-c1cb pred (info-ref-ccb i)))) ;; (calls-blocked-fun-p (fun i) (ifunm (lambda (x y) (unless (eq x fun) (eq y t))) i)) ;; (unfinished-p (fun i) (ifunm (lambda (x y) (not y)) i)) ;; (blocked-above nil (member-if (lambda (x &aux (y (pop x))) (eq t (if x (fun-c1cb y) (fun-c1 y)))) (cdr *fun-stack*))) ;; (recursive-p (fun i) (ifunm (lambda (x y) (when y (eq x fun))) i))) ;; (cond ((eq c1 t) ;; (keyed-cmpnote (list (fun-name fun) 'recursion) "recursive call to local fun ~s" (fun-name fun)) ;; nil) ;; ((unless osig c1)) ;; ((let* ((c1 (or c1 (set fun t))) ;; (res (under-env env (c1function (list (fun-src fun)) (if ccb 'cb 'lb) fun))) ;; (i (cadr res)) ;; (sig (car (fun-call fun)))) ;; (cond ((setq tmp (calls-blocked-fun-p fun i)) ;; (keyed-cmpnote (list (fun-name fun) 'recursion) "local fun ~s calls unfinalized funs ~s" (fun-name fun) tmp) ;; (set fun nil)) ;; ((setq tmp (unfinished-p fun i)) ;; (cond ((blocked-above) ;; (keyed-cmpnote (list (fun-name fun) 'recursion) "setting unfinished fun ~s to nil, ufun ~s" (fun-name fun) tmp) ;; (set fun nil)) ;; ((eq c1 t) ;; (keyed-cmpnote (list (fun-name fun) 'recursion) "reprocessing unfinished local fun ~s: ~s" (fun-name fun) tmp) ;; (set fun res) ;; (make-fun-c1 fun ccb env sig)) ;; ((set fun res) ))) ;; ((when (recursive-p fun i) (not (eq (cadr osig) (cadr sig))));FIXME bump? ;; (keyed-cmpnote (list (fun-name fun) 'recursion) "reprocessing recursive local fun ~s: ~s ~s" (fun-name fun) osig sig) ;; (set fun res) ;; (make-fun-c1 fun ccb env sig)) ;; ((set fun res)))))))) ;; (defun make-fun-c1 (fun ccb env &optional osig &aux (c1 (if ccb (fun-c1cb fun) (fun-c1 fun)))) ;; (labels ((set (fun val) (if ccb (setf (fun-c1cb fun) val) (setf (fun-c1 fun) val))) ;; (ifunp (key pred l) (member-if (lambda (x) (when (fun-p x) (funcall pred x (funcall key x)))) l)) ;; (ifunm (pred i) (or (ifunp 'fun-c1 pred (info-ref i)) (ifunp 'fun-c1cb pred (info-ref-ccb i)))) ;; (calls-blocked-fun-p (fun i) (ifunm (lambda (x y) (unless (eq x fun) (eq y t))) i)) ;; (recursive-p (fun i) (ifunm (lambda (x y) (or (not y) (eq x fun))) i))) ;; (cond ((eq c1 t) ;; (keyed-cmpnote (list (fun-name fun) 'recursion) "recursive call to local fun ~s" (fun-name fun)) ;; nil) ;; ((unless osig c1) c1) ;; ((let* ((c1 (or c1 (set fun t))) ;; (res (under-env env (c1function (list (fun-src fun)) (if ccb 'cb 'lb) fun))) ;; (i (cadr res)) ;; (sig (car (fun-call fun)))) ;; (declare (ignore c1));FIXME ;; (cond ((calls-blocked-fun-p fun i) ;; (keyed-cmpnote (list (fun-name fun) 'recursion) "local fun ~s calls unfinalized funs" (fun-name fun)) ;; (set fun nil)) ;; ((when (recursive-p fun i) (not (eq (cadr osig) (cadr sig))));FIXME bump? ;; (set fun res) ;; (keyed-cmpnote (list (fun-name fun) 'recursion) "reprocessing recursive local fun ~s: ~s ~s" (fun-name fun) osig sig) ;; (make-fun-c1 fun ccb env sig)) ;; ((set fun res)))))))) ;; (defun make-fun-c1 (fun ccb env &optional osig &aux (c1 (if ccb (fun-c1cb fun) (fun-c1 fun)))) ;; (labels ((set (fun val) (if ccb (setf (fun-c1cb fun) val) (setf (fun-c1 fun) val))) ;; (ifunp (key pred fun l) (member-if (lambda (x) (when (fun-p x) (funcall pred x (funcall key x) fun))) l)) ;; (ifunm (pred fun i) (or (ifunp 'fun-c1 pred fun (info-ref i)) (ifunp 'fun-c1cb pred fun (info-ref-ccb i)))) ;; ; (calls-blocked-fun-p (fun i) (ifunm (lambda (x y) (unless (eq x fun) (eq y t))) i)) FIXME ;; (calls-blocked-fun-p (fun i) (ifunm (lambda (x y z) (unless (eq x z) (eq y t))) fun i)) ;; (recursive-p (fun i) (ifunm (lambda (x y z) (or (not y) (eq x z))) fun i))) ;; (cond ((eq c1 t) ;; (keyed-cmpnote (list (fun-name fun) 'recursion) "recursive call to local fun ~s" (fun-name fun)) ;; nil) ;; ((unless osig c1) c1) ;; ((let* ((c1 (or c1 (set fun t))) ;; (res (under-env env (c1function (list (fun-src fun)) (if ccb 'cb 'lb) fun))) ;; (i (cadr res)) ;; (sig (car (fun-call fun)))) ;; (declare (ignore c1));FIXME ;; (cond ((calls-blocked-fun-p fun i) ;; (keyed-cmpnote (list (fun-name fun) 'recursion) "local fun ~s calls unfinalized funs" (fun-name fun)) ;; (set fun nil)) ;; ((when (recursive-p fun i) (not (eq (cadr osig) (cadr sig))));FIXME bump? ;; (set fun res) ;; (keyed-cmpnote (list (fun-name fun) 'recursion) "reprocessing recursive local fun ~s: ~s ~s" (fun-name fun) osig sig) ;; (make-fun-c1 fun ccb env sig)) ;; ((set fun res)))))))) (defun c1local-fun (fname &optional cl &aux ccb inner) (dolist (fun *funs*) (cond ((not (fun-p fun)) (setq ccb (or (eq fun 'cb) ccb) inner (or inner fun))) ((when (eq (fun-name fun) fname) (not (member fun *lexical-env-mask*))) (let* ((cl (or ccb cl)) (env (fn-get (fun-fn fun) 'df)) (fm (make-fun-c1 fun cl env)) (info (if fm (copy-info (cadr fm)) (make-info))) (c1fv (when ccb (c1inner-fun-var)))) (setf (info-type info) (cadar (fun-call fun)));FIXME (if cl (pushnew fun (info-ref-ccb info)) (pushnew fun (info-ref info))) (when c1fv (add-info info (cadr c1fv))) (return (list 'call-local info (list fun cl ccb) c1fv fm))))))) ;; (defun c1local-fun (fname &optional cl &aux ccb inner) ;; (dolist (fun *funs*) ;; (cond ((not (fun-p fun)) (setq ccb (or (eq fun 'cb) ccb) inner (or inner fun))) ;; ((eq (fun-name fun) fname) ;; (let* ((cl (or ccb cl)) ;; (env (fn-get (fun-fn fun) 'df)) ;; (fm (make-fun-c1 fun cl env)) ;; (lam (cadr (caddr fm))) ;; (info (if lam (copy-info (cadr lam)) (make-info))) ;; (c1fv (when ccb (c1inner-fun-var))));FIXME fm ;; (setf (info-type info) (cadar (fun-call fun)));FIXME ;; (if cl (pushnew fun (info-ref-ccb info)) (pushnew fun (info-ref info))) ;; (when c1fv (add-info info (cadr c1fv))) ;; (return (list 'call-local info (list fun cl ccb) c1fv lam))))))) ;; (defun c1local-fun (fname &optional cl &aux ccb inner) ;; (dolist (fun *funs*) ;; (cond ((not (fun-p fun)) (setq ccb (or (eq fun 'cb) ccb) inner (or inner fun))) ;; ((eq (fun-name fun) fname) ;; (let* ((cl (or ccb cl)) ;; (env (fn-get (fun-fn fun) 'df)) ;; (fm (if cl (make-local-fun fun-c1cb cb fun env) (make-local-fun fun-c1 lb fun env))) ;; (lam (cadr (caddr fm))) ;; (info (if lam (copy-info (cadr lam)) (make-info))) ;; (c1fv (when ccb (c1inner-fun-var))));FIXME fm ;; (setf (info-type info) (cadar (fun-call fun)));FIXME ;; (if cl (pushnew fun (info-ref-ccb info)) (pushnew fun (info-ref info))) ;; (when c1fv (add-info info (cadr c1fv))) ;; (return (list 'call-local info (list fun cl ccb) c1fv lam))))))) ;; (defun c1local-fun (fname &optional cl &aux ccb inner) ;; (dolist (fun *funs*) ;; (cond ((not (fun-p fun)) (setq ccb (or (eq fun 'cb) ccb) inner (or inner fun))) ;; ((eq (fun-name fun) fname) ;; (let* ((cl (or ccb cl)) ;; (env (fn-get (fun-fn fun) 'df)) ;; (fm (if cl (make-local-fun fun-c1cb cb fun env) (make-local-fun fun-c1 lb fun env))) ;; (lam (cadr (caddr fm))) ;; (info (if lam (copy-info (cadr lam)) (make-info))) ;; (c1fv (when ccb (c1inner-fun-var))));FIXME fm ;; (setf (info-type info) (cadar (fun-call fun)));FIXME ;; (if cl (pushnew fun (info-fref-ccb info)) (pushnew fun (info-fref info))) ;; (when c1fv (add-info info (cadr c1fv))) ;; (return (list 'call-local info (list fun cl ccb) c1fv lam))))))) ;; (defun c1local-fun (fname &optional cl &aux ccb inner) ;; (macrolet ((pf (fun ref c1 b) ;; `(unless (,ref ,fun) ;; (setf (,ref ,fun) t) ;; (when (eq (car (,c1 ,fun)) 'provfn) ;; (unprovfn (,c1 ,fun) ,b ,fun))))) ;; (dolist (fun *funs*) ;; (cond ((not (fun-p fun)) (setq ccb (or (eq fun 'cb) ccb) inner (or inner fun))) ;; ((eq (fun-name fun) fname) ;; (cond ((or ccb cl) ;; (ref-inner inner) ;; (pf fun fun-ref-ccb fun-c1cb 'cb)) ;; ((pf fun fun-ref fun-c1 'lb))) ;; (setf (info-type (fun-info fun)) (cadar (fun-call fun))) ;; (return (list 'call-local (fun-info fun) (list fun ccb)))))))) ;; (defun c1local-fun (fname &optional cl &aux ccb inner) ;; (macrolet ((pf (fun ref c1 b &aux (s (tmpsym))) ;; `(let ((,s (fun-prov ,fun))) ;; (unless (,ref ,fun) ;; (setf (,ref ,fun) t ;; (,c1 ,fun) (process-local-fun-env (fourth ,s) ,b ,fun (fun-src ,fun) (info-type (cadr ,s)))))))) ;; (dolist (fun *funs*) ;; (cond ((not (fun-p fun)) (setq ccb (or (eq fun 'cb) ccb) inner (or inner fun))) ;; ((eq (fun-name fun) fname) ;; (cond ((or ccb cl) ;; (ref-inner inner) ;; (pf fun fun-ref-ccb fun-c1cb 'cb)) ;; ((pf fun fun-ref fun-c1 'lb))) ;; (setf (info-type (fun-info fun)) (cadar (fun-call fun))) ;; (return (list 'call-local (fun-info fun) (list 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 make-inline-arg-str (sig &optional (lev -1)) (let* ((inl (let (r) (dotimes (i (1+ lev) r) (push i r)))) (inl (mapcar (lambda (x) (strcat "base" (write-to-string x))) inl)) (inl (if (= lev *level*) (cons "base" (cdr inl)) inl)) (va (member '* (car sig))) (inl (dotimes (i (- (length (car sig)) (if va 1 0)) inl) (push (strcat "#" (write-to-string i)) inl))) (inl (if va (cons (if (eq va (car sig)) "#?" "#*") inl) inl)) (inl (nreverse inl))) (reduce 'strcat (mapcon (lambda (x) (if (and (cdr x) (not (member (cadr x) '("#*" "#?") :test 'equal))) (list (car x) ",") (list (car x)))) inl) :initial-value ""))) (defun vfun-wrap (x sig clp &optional ap &aux (ap (when ap (1- ap)))) (let* ((mv (not (single-type-p (cadr sig)))) (va (member '* (car sig))) (nreg (length (ldiffn (car sig) va)))) (ms "(" (when clp (concatenate 'string "fcall.fun=" clp ",")) (when mv "fcall.valp=(fixnum)#v,") (when va "fcall.argd=") (when (and va ap) "-") (when va "#n") (when (and va ap (< ap nreg)) (- ap nreg)) (when va ",") x ")"))) (defun make-local-inline (fd) (let* ((fun (pop fd)) (clp (pop fd)) (ap (cadr fd)) (sig (car (fun-call fun))) (sig (list (mapcar (lambda (x) (link-rt x nil)) (car sig)) (link-rt (cadr sig) nil))) (mv (not (single-type-p (cadr sig)))) (nm (c-function-name "L" (fun-cfun fun) (fun-name fun))) (clp (when clp (ccb-vs-str (fun-ref-ccb fun)))) (nm (if clp (ms clp "->fun.fun_self") nm)) (inl (g1 clp nm sig ap clp (if clp -1 (fun-level fun))))) `(,(car sig) ,(cadr sig) ,(if mv (flags rfa svt) (flags rfa)) ,inl))) ;; (defun make-local-inline (fd) ;; (let* ((fun (pop fd)) ;; (clp (pop fd)) ;; (ap (cadr fd)) ;; (sig (car (fun-call fun))) ;; (sig (list (mapcar (lambda (x) (link-rt x nil)) (car sig)) (link-rt (cadr sig) nil))) ;; (mv (not (single-type-p (cadr sig)))) ;; (nm (c-function-name "L" (fun-cfun fun) (fun-name fun))) ;; (clp (when clp (ccb-vs-str (fun-ref-ccb fun)))) ;; (nm (if clp (ms clp "->fun.fun_self") nm)) ;; (inl (g1 clp nm sig ap clp (if clp -1 (fun-level fun))))) ;; `(,(car sig) ,(cadr sig) ;; ,(if mv (flags rfa svt) (flags rfa)) ;; ,inl))) ;; (defun make-local-inline (fd) ;; (let* ((fun (pop fd)) ;; (clp (pop fd)) ;; (ap (pop fd)) ;; (sig (car (fun-call fun))) ;; (sig (list (mapcar (lambda (x) (link-rt x nil)) (car sig)) (link-rt (cadr sig) nil))) ;; (mv (not (single-type-p (cadr sig)))) ;; (nm (c-function-name "L" (fun-cfun fun) (fun-name fun))) ;; (clp (when clp (ccb-vs-str (fun-ref-ccb fun)))) ;; (nm (if clp (ms clp "->fun.fun_self") nm)) ;; (inl (g1 clp nm sig ap clp (if clp -1 (fun-level fun))))) ;; `(,(car sig) ,(cadr sig) ;; ,(if mv (flags rfa svt) (flags rfa)) ;; ,inl))) ;; (defun make-local-inline (fd) ;; (let* ((fun (pop fd)) ;; (clp (pop fd)) ;; (ap (pop fd)) ;; (sig (car (fun-call fun))) ;; (sig (list (mapcar (lambda (x) (link-rt x nil)) (car sig)) (link-rt (cadr sig) nil))) ;; (mv (not (single-type-p (cadr sig)))) ;; (nm (c-function-name "L" (fun-cfun fun) (fun-name fun))) ;; (nm (if clp (strcat (ccb-vs-str (fun-ref-ccb fun)) "->fun.fun_self") nm)) ;; (inl (g0 nm sig ap (when clp (ccb-vs-str (fun-ref-ccb fun))) (if clp -1 (fun-level fun))))) ;; `(,(car sig) ,(cadr sig) ;; ,(if mv (flags rfa svt) (flags rfa)) ;; ,inl))) (defun c2call-local (fd c1fv lam args &aux (*vs* *vs*)) (declare (ignore lam c1fv)) (let ((*inline-blocks* 0)) (unwind-exit (get-inline-loc (make-local-inline fd) args)) (close-inline-blocks))) ;; (defun c2call-local (fd args &aux (*vs* *vs*)) ;; (let ((*inline-blocks* 0)) ;; (unwind-exit (get-inline-loc (make-local-inline fd) args)) ;; (close-inline-blocks))) gcl27-2.7.0/cmpnew/gcl_cmpfun.lsp000077500000000000000000000531511454061450500166000ustar00rootroot00000000000000;; 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 'funcall 'c1funcall 'c1) (defvar *princ-string-limit* 80) (defun c1princ (args &aux stream (info (make-info :flags (iflags side-effects)))) (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) (c1arg (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 (c1arg (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")) ((char= char #\Return) (wt "\\r")) (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 (cmp-norm-tp (if (characterp string) 'character 'string))) (list 'VV (add-object string))) stream) nil t)))) (defun c1terpri (args &aux stream (info (make-info :flags (iflags side-effects)))) (unless (or (endp args) (endp (cdr args))) (too-many-args 'terpri 1 (length args))) (setq stream (if (endp args) (c1nil) (c1arg (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 c1terpri (args &aux stream (info (make-info :flags (iflags side-effects)))) ;; (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 c2apply (funob args) (unless (eq 'ordinary (car funob)) (baboon)) (let* ((fn (caddr funob)) (all (cons fn args)) (*inline-blocks* 0)) (setq *sup-used* t) (unwind-exit (get-inline-loc (list (make-list (length all) :initial-element t) '* #.(flags ans set svt) (concatenate 'string "({fixnum _v=(fixnum)#v;object _z,_f=(#0),_l=(#1),_ll=_l; object _x4=Cnil,_x3=Cnil,_x2=Cnil,_x1=Cnil,_x0=Cnil; char _m=(#n-2),_q=_f->fun.fun_minarg>_m ? _f->fun.fun_minarg-_m : 0; char _n=Rset && !_f->fun.fun_argd ? _q : -1; fcall.fun=_f;fcall.valp=_v;fcall.argd=-(#n-1); switch (_n) { case 5: if (_l==Cnil) {_n=-1;break;} _x4=_l->c.c_car;_l=_l->c.c_cdr; case 4: if (_l==Cnil) {_n=-1;break;} _x3=_l->c.c_car;_l=_l->c.c_cdr; case 3: if (_l==Cnil) {_n=-1;break;} _x2=_l->c.c_car;_l=_l->c.c_cdr; case 2: if (_l==Cnil) {_n=-1;break;} _x1=_l->c.c_car;_l=_l->c.c_cdr; case 1: if (_l==Cnil) {_n=-1;break;} _x0=_l->c.c_car;_l=_l->c.c_cdr; case 0: if (_n+_m+(_l==Cnil ? 0 : 1)>_f->fun.fun_maxarg) _n=-1; else fcall.argd-=_n; default: break; } switch (_n) { case 5: _z=_f->fun.fun_self(#*_x4,_x3,_x2,_x1,_x0,_l);break; case 4: _z=_f->fun.fun_self(#*_x3,_x2,_x1,_x0,_l);break; case 3: _z=_f->fun.fun_self(#*_x2,_x1,_x0,_l);break; case 2: _z=_f->fun.fun_self(#*_x1,_x0,_l);break; case 1: _z=_f->fun.fun_self(#*_x0,_l);break; case 0: _z=" (if (cdr args) "_f->fun.fun_self(#*_l)" "(_f->fun.fun_maxarg ? _f->fun.fun_self(#*_l) : _f->fun.fun_self())") ";break; default: _z=call_proc_cs2(#*_ll);break; } if (!(_f)->fun.fun_neval && !(_f)->fun.fun_vv) vs_top=_v ? (object *)_v : sup; _z;})")) (list* (car all) (car (last all)) (butlast (cdr all))))) (close-inline-blocks))) ;; (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)))) ;; ) ;; ) ;; c2apply alters argument order (let ((l (gensym "LV"))) (defun apply-bind (form args &aux (la (car (last args)))) (if (eq l la) form (let* ((b (mapcar (lambda (x) (list (gensym) x)) (butlast args))) (v (mapcar 'car b))) `(let (,@b (,l ,la)) (apply ,@v ,l)))))) (defun fn-bind (form args) (if (or (symbolp (car args)) (constantp (car args))) form (let ((s (sgen "FN-BIND")));sgen? `(let ((,s ,(pop args))) (,(car form) ,s ,@args))))) (define-compiler-macro funcall (&whole form &rest args) (fn-bind form args)) ;(define-compiler-macro apply (&whole form &rest args) (apply-bind form args)) (define-compiler-macro apply (&whole form &rest args) (fn-bind form args)) (defun c1apply (args) (when (or (endp args) (endp (cdr args))) (too-few-args 'apply 2 (length args))) (let* ((ff (c1arg (pop args))) (fid (coerce-ff ff))) (if (eq fid 'funcall) (c1apply args) (mi1 fid (butlast args) (car (last args)) ff)))) (defun c1funcall (args) (when (endp args) (too-few-args 'funcall 1 0)) (let* ((ff (c1arg (pop args))) (fid (coerce-ff ff))) (case fid (funcall (c1funcall args))(apply (c1apply args)) (otherwise (mi1 fid args nil ff))))) ;; (defun c1funcall-apply (args &optional last) ;; (mi1 (if last 'apply 'funcall) args (car last))) ;; (defun c1funcall (args) ;; (when (endp args) (too-few-args 'funcall 1 0)) ;; (c1funcall-apply args)) ;; (defun c1apply (args) ;; (when (or (endp args) (endp (cdr args))) ;; (too-few-args 'apply 2 (length args))) ;; (let* ((last (last args)) ;; (args (ldiff args last))) ;; (c1funcall-apply args last))) (defun eq-subtp (x y) ;FIXME axe mult values (let ((s (type>= y x))) (values s (or s (type>= (tp-not y) x))))) (defun eql-is-eq-tp (x) (eq-subtp x #teql-is-eq-tp)) (defun equal-is-eq-tp (x) (eq-subtp x #tequal-is-eq-tp)) (defun equalp-is-eq-tp (x) (eq-subtp x #tequalp-is-eq-tp)) (defun do-eq-et-al (fn args);FIXME pass through function inlining (let* ((tf (cadr (test-to-tf fn))) (info (make-info :type #tboolean)) (nargs (c1args args info)) (t1 (info-type (cadar nargs))) (t2 (info-type (cadadr nargs))) (a1 (atomic-tp t1)) (a2 (atomic-tp t2)) (nfn (if (when tf (or (funcall tf t1) (funcall tf t2))) 'eq fn))) (unless (and t1 t2) (setf (info-type info) nil)) (cond ((not (type-and t1 t2)) (c1progn (append args (list nil)) (nconc nargs (list (c1nil))))) ((and a1 a2 (case nfn (eq (eql-is-eq (car a1)))(eql t))) (let ((q (eql (car a1) (car a2)))) (c1progn (append args (list q)) (nconc nargs (list (if q (c1t) (c1nil))))))) ((let ((x (get-vbind (car nargs)))(y (get-vbind (cadr nargs)))) (when (or (when x (eq x y)) (and (symbolp (car args)) (eq (car args) (cadr args)))) (c1t)))) (`(call-global ,info ,(if (when tf (or (funcall tf t1) (funcall tf t2))) 'eq fn) ,nargs))))) (dolist (l `(eq eql equal equalp)) (si::putprop l 'do-eq-et-al 'c1g)) (defun num-type-bounds (t1) (let ((x (tp-bnds t1))) (when x (list (car x) (cdr x))))) (defun ntrr (x y) (and x y (list (and (car x) (car y)) (and (cadr x) (cadr y) (eq (car x) (car y)))))) (defun dntrr (l) (reduce 'ntrr (cdr l) :initial-value (car l))) (defun num-type-rel (fn t1 t2 &optional s &aux (t1 (coerce-to-one-value t1))(t2 (coerce-to-one-value t2))) (let ((nop (car (rassoc fn '((>= . <) (> . <=) (= . /=))))) (rfn (cdr (assoc fn '((>= . >) (> . >=)))))) (cond (nop (let ((q (num-type-rel nop t1 t2))) (list (and (not (car q)) (cadr q)) (cadr q)))) ((and (consp t1) (eq (car t1) 'or)) (dntrr (mapcar (lambda (x) (num-type-rel fn x t2)) (cdr t1)))) ((and (consp t2) (eq (car t2) 'or)) (dntrr (mapcar (lambda (x) (num-type-rel fn t1 x)) (cdr t2)))) ((eq fn '=) (cond ((not (and t1 t2)) (list nil t)) ;; ((and (type>= #tcomplex t1) (not (type-and #tcomplex t2))) ;; (unless (type-and (cadr t1) (type-and t2 #t(real 0.0 0.0))) ;; (list nil t))) ;; ((and (type>= #tcomplex t2) (not (type-and #tcomplex t1))) ;; (unless (type-and (cadr t2) (type-and t1 #t(real 0.0 0.0))) ;; (list nil t))) ((let ((x (num-type-rel '>= t1 t2))(y (num-type-rel '>= t2 t1))) (list (and (car x) (car y)) (and (cadr x) (cadr y))))))) ((not s) (let ((f (num-type-rel fn t1 t2 t))) (list f (or f (num-type-rel rfn t2 t1 t))))) ((not (and t1 t2)) nil) ((and (type>= #treal t1) (type>= #treal t2)) (let ((t1 (car (num-type-bounds t1))) (t2 (cadr (num-type-bounds t2)))) (and (numberp t1) (numberp t2) (values (funcall fn t1 t2)))))))) (defun do-num-relations (fn args) (let* ((info (make-info :type #tboolean)) (nargs (c1args args info)) (t1 (and (car args) (info-type (cadar nargs)))) (t2 (and (cadr args) (info-type (cadadr nargs)))) (fn (or (cdr (assoc fn '((si::=2 . =)(si::/=2 . /=)(si::>=2 . >=) (si::>2 . >)(si::<2 . <)(si::<=2 . <=)))) fn)) (r (and t1 t2 (num-type-rel fn t1 t2)))) (cond ((cddr args) (list 'call-global info fn nargs)) ((or (car r) (cadr r)) (let ((r (when (car r) t))) (c1progn (append args (list r)) (nconc nargs (list (if r (c1t) (c1nil))))))) ((let ((x (get-vbind (car nargs)))(y (get-vbind (cadr nargs)))) (when (or (when x (eq x y)) (and (symbolp (car args)) (eq (car args) (cadr args)))) (if (member fn '(= >= <=)) (c1t) (c1nil))))) ((list 'call-global info fn nargs))))) (dolist (l `(>= > < <= = /=)) (si::putprop l 'do-num-relations 'c1g)) (dolist (l `(eq eql equal equalp > >= < <= = /= length + - / * min max;FIXME get a good list here car cdr caar cadr cdar cddr caaar caadr cadar cdaar caddr cdadr cddar cdddr caaaar caaadr caadar cadaar cdaaar caaddr cadadr cdaadr caddar cdadar cddaar cadddr cdaddr cddadr cdddar cddddr logand lognot logior logxor c-type complex-real complex-imag ratio-numerator ratio-denominator cnum-type si::number-plus si::number-minus si::number-times si::number-divide ;FIXME more ,@(mapcar (lambda (x) (cdr x)) (remove-if-not (lambda (x) (symbolp (cdr x))) +cmp-type-alist+)))) (si::putprop l t 'c1no-side-effects)) (setf (get 'cons 'c1no-side-effects) t) (setf (get 'make-list 'c1no-side-effects) t) (setf (get 'si::make-vector 'c1no-side-effects) t) (setf (get 'complex 'c1no-side-effects) t) ;;bound type comparisons ;; only boolean eval const args (defun test-to-tf (test) (let ((test (if (constantp test) (cmp-eval test) test))) (cond ((member test `(eql ,#'eql)) '(eql-is-eq eql-is-eq-tp)) ((member test `(equal ,#'equal)) '(equal-is-eq equal-is-eq-tp)) ((member test `(equalp ,#'equalp)) '(equalp-is-eq equalp-is-eq-tp))))) (defun do-predicate (fn args) (let* ((info (make-info :type #tboolean)) (nargs (c1args args info)) (tp (car (rassoc fn +cmp-type-alist+)))) (when (cdr args) (baboon)) (let ((at (nil-to-t (coerce-to-one-value (info-type (cadar nargs)))))) (cond ((type>= tp at) (c1expr (ignorable-pivot (car args) t))) ((not (type-and at tp)) (c1expr (ignorable-pivot (car args) nil))) ((list 'call-global info fn nargs)))))) (defun cons-type-length (type) (cond ((and (consp type) (eq (car type) 'cons)) (the seqind (+ 1 (cons-type-length (caddr type))))) (0))) (defun co1eql (f args) (declare (ignore 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 (sgen "CO1EQL"))) (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) (cmp-unnorm-tp (info-type (cadr (c1arg x))))) ((constantp x) (type-of x)) ((and (consp x) (eq (car x) 'the)) (second x)) (t t))) (defun co1schar (f args) (declare (ignore 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) (declare (ignore f)) (let ((tem (and (eql (length args) 2) (cons-to-lista args)))) (and tem (not (eq tem args)) (c1expr (if (equal '(nil) (last tem)) (cons 'list (butlast tem)) (cons 'list* tem)))))) ;; 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) (,(if (eq read-fun 'read-char1) '(code-char ans) 'ans)))) ((,read-fun ,stream ,eof)) )))) (`(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 ;; (let* ((s (sgen "CO1READ-BYTE"))(nargs (cons s (cdr args)))) ;; (cond ((setq tem (fast-read nargs 'read-byte1)) ;; (let ((*space* 10)) ;prevent recursion! ;; (c1expr `(let ((,s ,(car args))) ;; (if (= 1 (si::get-byte-stream-nchars ,s)) ,tem ,(cons f nargs))))))))) (defun co1read-char (f args &aux tem) (declare (ignore f)) (cond ((setq tem (fast-read args 'read-char1)) (let ((*space* 10)) ;prevent recursion! (c1expr tem))))) (defun cfast-write (args write-fun tp) (when (and (not *safe-compile*) (< *space* 2) (boundp 'si::*eof*)) (let* ((stream (second args))(stream (or stream '*standard-output*))) (if (atom stream) (let ((ch (sgen "CFAST-WRITE-CH"))) `(let ((,ch ,(car args))) (if (and (fp-okp ,stream) (typep ,ch ',tp)) (sputc ,ch ,stream) (,write-fun ,ch ,stream)) ,ch)) (let ((str (sgen "CFAST-WRITE-STR"))) `(let ((,str ,stream)) (declare (type ,(result-type stream) ,str)) ,(cfast-write (list (car args) str) write-fun tp))))))) (defun co1write-byte (f args) (declare (ignore f)) (let ((tem (cfast-write args 'write-byte 'fixnum))) (when tem (let ((*space* 10)) (c1expr tem))))) (defun co1write-char (f args) (declare (ignore f)) (let* ((tem (cfast-write args 'write-char 'character))) (when tem (let ((*space* 10)) (c1expr tem))))) (defun aet-c-type (type) (or (cdr (assoc type +c-type-string-alist+)) (baboon))) (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* t (> *space* 3) (null (cdr args)) ) (let ((*space* 10)) (c1expr (let ((val (sgen "CO1VECTOR-PUSH-VAL")) (v (sgen "CO1VECTOR-PUSH-V")) (i (sgen "CO1VECTOR-PUSH-I")) (dim (sgen "CO1VECTOR-PUSH-DIM"))) `(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 ,val ,v ,i) ,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)))))) (defun narg-list-type (nargs &optional dot) (let* ((y (mapcar (lambda (x &aux (atp (atomic-tp (info-type (cadr x))))) (cond ;((get-vbind x)) (atp (car atp));FIXME ((get-vbind x)) ((new-bind)))) nargs))) ; (when dot (setf (cdr (last y 2)) (car (last y)))) ;FIXME bump-pcons -- get rid of pcons entirely (let* ((s (when dot (car (last y))))(s (when s (unless (typep s 'proper-list) s)))(tp (info-type (cadar (last nargs)))));FIXME (cond ((when s (type>= #tproper-list tp)) #tproper-cons) ((when s (type-and #tnull tp)) #tcons) (t (when dot (setf (cdr (last y 2)) (car (last y)))) (object-type y)))))) (defun c1list (args) (let* ((info (make-info)) (nargs (c1args args info))) (cond ((not nargs) (c1nil)) ((setf (info-type info) (narg-list-type nargs)) `(call-global ,info list ,nargs))))) (si::putprop 'list 'c1list 'c1) (defun c1list* (args) (let* ((info (make-info)) (nargs (c1args args info))) (cond ((not nargs) (c1nil)) ((not (cdr nargs)) (car nargs)) ((setf (info-type info) (narg-list-type nargs t)) `(call-global ,info ,(if (cddr nargs) 'list* 'cons) ,nargs))))) (si::putprop 'list* 'c1list* 'c1) (si::putprop 'cons 'c1list* 'c1) gcl27-2.7.0/cmpnew/gcl_cmpif.lsp000077500000000000000000002140571454061450500164120ustar00rootroot00000000000000;;; 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 note-branch-elimination (test-form val elim-form) ; (let ((*suppress-compiler-notes* t) (*suppress-compiler-warnings* t)) ; (c1expr elim-form)) (keyed-cmpnote (list 'branch-elimination test-form) "Test form ~S is ~S,~%;; eliminating branch ~S~%" test-form val elim-form)) (defconstant +gen+ (make-var :name (gensym))) ;(defconstant +gen+ (gensym)) (defun tp-reduce (f1 f2 l1 l2) (labels ((c1 (c l2 &aux (d (cdr c))(m (cdr (or (assoc (car c) l2) (assoc +gen+ l2) '(nil t . t))))) (cons (car c) (cons (funcall f1 (car m) (car d)) (funcall f2 (cdr m) (cdr d)))))) (remove-duplicates (append (mapcar (lambda (x) (c1 x l2)) l1) (mapcar (lambda (x) (c1 x l1)) l2)) :key 'car))) ;; (defun tp-reduce (f1 f2 l1 l2 &optional r) ;; (labels ((m (l1 l2) (cdr (or (assoc (caar l1) l2) (assoc +gen+ l2) ;; (when (eq (caar l1) +gen+) (car l1)) '(nil t . t)))) ;; (c (l1 l2 &aux (c (car l1))(d (cdr c))(m (m l1 l2))) ;; (cons (car c) ;; (cons ;; (funcall f1 (car m) (car d)) ;; (funcall f2 (cdr m) (cdr d)))))) ;; (cond (l1 (tp-reduce f1 f2 (cdr l1) l2 (cons (c l1 l2) r))) ;; ((assoc (caar l2) r) (tp-reduce f1 f2 l1 (cdr l2) r)) ;; (l2 (tp-reduce f1 f2 l1 (cdr l2) (cons (c l2 r) r))) ;; (r)))) (defconstant +bool-inf-op-list+ '((> . <=) (>= . <) (< . >=) (<= . >) (= . /=) (/= . =))) (defconstant +bool-inf-sop-list+ '((> . <) (< . >) (<= . >=) (>= . <=) (= . =) (/= . /=))) (defun comp-type-propagator (f t1 t2 &rest r) (let ((z (let ((r (num-type-rel f t1 t2))) (cond ((car r) #t(member t)) ((cadr r) #t(member nil)) (#tboolean))))) (if r (type-or1 z (apply 'comp-type-propagator f t2 (car r) (cdr r))) z))) (defun max-bnd (x y op &aux (nx (if (atom x) x (car x))) (ny (if (atom y) y (car y)))) (cond ((or (eq x '*) (eq y '*)) '*) ((= nx ny) (if (atom x) x y)) ((funcall op nx ny) x) (y))) (defun real-bnds (t1) (num-type-bounds t1)) (defun two-tp-inf (fn t2 &aux (t2 (real-bnds (type-and #treal t2)))) (case fn (= (cmp-norm-tp `(real ,(or (car t2) '*) ,(or (cadr t2) '*)))) (/= (if (when (numberp (car t2)) (eql (car t2) (cadr t2))) (cmp-norm-tp `(and number (not (real ,@t2)))) #treal)) (> (cmp-norm-tp `(real ,(cond ((numberp (car t2)) (list (car t2))) ((car t2)) ('*))))) (>= (cmp-norm-tp `(real ,(or (car t2) '*)))) (< (cmp-norm-tp `(real * ,(cond ((numberp (cadr t2)) (list (cadr t2))) ((cadr t2)) ('*))))) (<= (cmp-norm-tp `(real * ,(or (cadr t2) '*)))))) (defmacro vl-name (x) `(var-name (car (third ,x)))) ;(defmacro vl-type (x) `(var-type (car (third ,x)))) ; Won't work, ref might be across a function boundary (defmacro vl-type (x) `(itp ,x)) (defmacro itp (x) `(info-type (second ,x))) (defmacro vlp (x) `(and (eq 'var (car ,x)) (llvar-p (car (third ,x))))) ;(defmacro vlp (x) `(and (eq 'var (car ,x)) (eq (var-kind (car (third ,x))) 'lexical))) ;; (defun get-object-value (c1x) ;; (when (and (eq 'location (car c1x)) (eq 'vv (caaddr c1x))) ;; (values (gethash (cadr (caddr c1x)) *objects-rev*)))) ;; (defvar *gen-nil* (list (cons +gen+ (cons nil t)))) ;; (defvar *gen-t* (list (cons +gen+ (cons t nil)))) ;; (defvar *inferred-tps* nil) ;; (defvar *inferred-op* nil) ;; (defvar *inferred-iop* nil) ;; (defun fmla-chain (op iop fx fy &optional res) ;; (let* ((*inferred-tps* res) ;; (*inferred-op* op) ;; (*inferred-iop* iop) ;; (r (tp-reduce op iop fx fy)) ;; (r (if *inferred-tps* (tp-reduce op iop r *inferred-tps*) r))) ;; (cond ((and (not (cdr fx)) (not (cdr fy))) r) ;; ((equal r res) r) ;; ((fmla-chain op iop fx fy r))))) ;; (defun intp (sym tp tf) ;; (let* ((a (if tf 'cadr 'cddr)) ;; (itp (funcall a (assoc sym *inferred-tps*)))) ;; (if itp (funcall (if tf *inferred-op* *inferred-iop*) tp itp) ;; tp))) (defun tppra (tp arg f r) (let ((s (info-type (cadr arg)))) (cons (type-and tp (two-tp-inf f s)) (type-and tp (two-tp-inf r s))))) ;; (defun tppra (tp arg f r) ;; (let* ((x (info-type (cadr arg))) ;; (s (cmp-norm-tp x)) ;; (sym (when (vlp arg) (vl-name arg)))) ;; (cons (type-and tp (two-tp-inf f (intp sym s t))) ;; (type-and tp (two-tp-inf r (intp sym s nil)))))) (defun fmla-if1 (f tf ff) (let* ((nf (mapcar (lambda (x) (cons (car x) (cons (cddr x) (cadr x)))) f)) (r1 (tp-reduce 'type-and 'type-or1 f tf));FIXME rewrite to carry only desired branch (r2 (tp-reduce 'type-and 'type-or1 nf ff)) (tr (tp-reduce 'type-or1 'type-and r1 r2)) (r1 (tp-reduce 'type-or1 'type-and nf tf)) (r2 (tp-reduce 'type-or1 'type-and f ff)) (fr (tp-reduce 'type-and 'type-or1 r1 r2))) (mapc (lambda (x) (setf (cddr x) (cddr (assoc (car x) fr)))) tr))) ;; (defun fmla-if1 (f tf ff) ;; (let* ((nf (mapcar (lambda (x) (cons (car x) (cons (cddr x) (cadr x)))) f)) ;; (r1 (fmla-chain 'type-and 'type-or1 f tf));FIXME rewrite to carry only desired branch ;; (r2 (fmla-chain 'type-and 'type-or1 nf ff)) ;; (tr (fmla-chain 'type-or1 'type-and r1 r2)) ;; (r1 (fmla-chain 'type-or1 'type-and nf tf)) ;; (r2 (fmla-chain 'type-or1 'type-and f ff)) ;; (fr (fmla-chain 'type-and 'type-or1 r1 r2)) ;; (tr (mapc (lambda (x) (setf (cddr x) (cddr (assoc (car x) fr)))) tr)));FIXME? check here? ;; (delete +gen+ tr :key 'car))) (defun fmla-if (f tf ff) (fmla-clean (fmla-if1 (fmla-infer-tp f) (fmla-infer-tp tf) (fmla-infer-tp ff)))) ;; (defun fmla-if (f tf ff) ;; (fmla-if1 (fmla-infer-tp f) (fmla-infer-tp tf) (fmla-infer-tp ff))) ;; (defun fmla-if (f tf ff) ;; (let* ((f (fmla-infer-tp f)) ;; (r1 (fmla-chain 'type-and 'type-or1 f (fmla-infer-tp tf))) ;; (f (mapcar (lambda (x) (cons (car x) (cons (cddr x) (cadr x)))) f)) ;; (r2 (fmla-chain 'type-and 'type-or1 f (fmla-infer-tp ff)))) ;; (delete +gen+ (fmla-chain 'type-or1 'type-and r1 r2) :key 'car))) ;; (defun fmla-switch (form &aux fm ntp ttp) ;; (let ((c (caddr form))) ;; (when (and (consp c) (eq (car c) 'inline)) ;; (let ((ca (caddr c))) ;; (when (eq ca 'tt3) ;; (let* ((f (fifth c)) ;; (v (when (and (consp f) (eq (car f) 'let*)) (cadddr f))) ;; (v (unless (cdr v) (when (and (consp (car v)) (eq (caar v) 'var)) (caaddr (car v))))) ;; (tt (sixth form))) ;; (do ((ints nil ints)) ((not (setq fm (pop tt))) (list* (var-name v) ttp ntp)) ;; (cond ((tag-p fm) (push (tag-name fm) ints)) ;; ((and (consp fm) (eq (car fm) 'return-from)) ;; (let ((tp (info-type (cadr (sixth fm))))) ;; (cond ((type>= #tnull tp) (setq ntp (type-or1 (ints-tt3 ints) ntp) ;; ints nil)) ;; ((type>= #t(not null) tp) ;; (setq ttp (type-or1 (ints-tt3 ints) ttp) ints nil))))))))))))) ;(defun merge-fmla (x) x) ;; (defun fmla-infer-inline (f) ;; (when (consp f) ;; (case (car f) ;; ((let let*) (sublis (mapcar 'cons ;; (mapcar 'var-name (third f)) ;; (mapcar (lambda (x) (when (and (consp x) (eq (car x) 'var)) ;; (var-name (car (third x))))) (fourth f))) ;; (fmla-infer-inline (fifth f)))) ;; (if (fmla-infer-inline (fourth f)));FIXME ;; (block ;; (merge-fmla (catch (third f) (fmla-infer-inline (fourth f))))) ;; (progn (fmla-infer-inline (car (last (third f))))) ;; (return-from ;; (throw (third f) (fmla-infer-inline (sixth f)))) ;; (switch ;; (mapc 'fmla-infer-inline (sixth f))) ;; (infer-tp (let ((tp (info-type (cadr (fifth f))))) ;; (cond ((type>= #tnull tp) (list* (var-name (third f)) #tt (fourth f))) ;; ((type>= #t(not null) tp) (list* (var-name (third f)) (fourth f) #tt)))))))) (defvar *infer-tags* nil) (defun fmla-default (fmla &aux (tp (info-type (cadr fmla)))(nn (type-and tp #t(not null)))(n (type-and tp #tnull))) (unless (and nn n) (list (cons +gen+ (cons (when nn t) (when n t)))))) (defun fmla-clean (fmla) (delete +gen+ fmla :key 'car)) (defun fmla-infer-tp (fmla) (when (unless *compiler-new-safety* (listp fmla)) (case (car fmla) ((inline decl-body let let*) (fmla-infer-tp (car (last fmla)))) (block (let ((*infer-tags* (cons (cons (third fmla) (fmla-infer-tp (fourth fmla))) *infer-tags*))) (labels ((fmla-walk (f) (cond ((atom f)) ((when (eq (car f) 'return-from) (eq (caddr f) (third fmla))) (fmla-infer-tp f)) (t (fmla-walk (car f)) (fmla-walk (cdr f)))))) (fmla-walk (fourth fmla))) (fmla-clean (cdar *infer-tags*)))) (progn (fmla-infer-tp (car (last (third fmla))))) (return-from (let ((x (assoc (third fmla) *infer-tags*))) (when x (let ((y (fmla-infer-tp (seventh fmla)))) (setf (cdr x) (fmla-if1 nil (cdr x) y)))))) (infer-tp (let* ((tp (info-type (cadr (fifth fmla)))) (vl (third fmla)) (i (cond ((type>= #tnull tp) (cons nil (fourth fmla)));FIXME nil tp ((type>= #t(not null) tp) (cons (fourth fmla) nil))))) (nconc (when i (mapcar (lambda (x) (cons x i)) vl)) (fmla-infer-tp (fifth fmla))))) (if (apply 'fmla-if (cddr fmla))) (var (when (llvar-p (car (third fmla))) (list (cons (car (third fmla)) (cons #t(not null) #tnull))))) (setq (fmla-infer-tp (fourth fmla)));FIXME set var too, and in call global (call-global (let* ((fn (third fmla)) (rfn (cdr (assoc fn +bool-inf-op-list+))) (sfn (cdr (assoc fn +bool-inf-sop-list+))) (srfn (cdr (assoc sfn +bool-inf-op-list+))) (args (if (eq (car fmla) 'inline) (fourth (fifth fmla)) (fourth fmla))) (l (length args)) (pt (rassoc fn +cmp-type-alist+)));FIXME +cmp-type-alist+ (get fn 'si::predicate-type) (cond ((and (= l 1) (vlp (first args)) pt) (list (cons (car (third (first args))) (cons (car pt) (tp-not (car pt)))))) ((and (= l 2) (eq fn 'typep) (vlp (first args)) (let ((tp (cmp-norm-tp (car (atomic-tp (info-type (cadr (second args)))))))) (when tp (list (cons (car (third (first args))) (cons tp (tp-not tp)))))))) ((and (= l 2) rfn) (nconc (when (vlp (first args)) (list (cons (car (third (first args))) (tppra (vl-type (first args)) (second args) fn rfn)))) (when (vlp (second args)) (list (cons (car (third (second args))) (tppra (vl-type (second args)) (first args) sfn srfn)))))) ((fmla-default fmla))))) (otherwise (fmla-default fmla))))) ;; (defun fmla-infer-tp (fmla) ;; (when (unless *compiler-new-safety* (listp fmla)) ;; (case (car fmla) ;; (inline (fmla-infer-tp (fifth fmla))) ;; ((let let*) (remove-if (lambda (x) (member (car x) (third fmla))) (fmla-infer-tp (fifth fmla)))) ;; (tagbody (mapc 'fmla-infer-tp (fifth fmla)) nil);FIXME need catch/throw here, and make this an ecase ;; (block ;; (let* ((tp (info-type (cadr (fourth fmla)))) ;; (gen (list (cons +gen+ (cons (when (type-and #t(not null) tp) t) (when (type-and #tnull tp) t))))) ;; (*infer-tags* (cons (cons (third fmla) gen) *infer-tags*))) ;; (fmla-infer-tp (fourth fmla)) ;; (labels ((fmla-walk (f) (cond ((atom f));FIXME now that this is in, maybe remove mapc in tagbody and switch ;; ((eq (car f) 'return-from) (fmla-infer-tp f)) ;; (t (fmla-walk (car f)) (fmla-walk (cdr f)))))) ;; (fmla-walk (fourth fmla))) ;; (cdar *infer-tags*))) ;; (progn (fmla-infer-tp (car (last (third fmla))))) ;; (decl-body (fmla-infer-tp (fourth fmla))) ;; (return-from ;; (let ((x (assoc (third fmla) *infer-tags*))) ;; (when x (setf (cdr x) (fmla-if1 nil (cdr x) (fmla-infer-tp (seventh fmla))))))) ;; (switch ;; (mapc 'fmla-infer-tp (fourth fmla)) nil);FIXME ;; (infer-tp (let* ((tp (info-type (cadr (fifth fmla)))) ;; (v (car (third (third fmla)))) ;; (i (cond ((type>= #tnull tp) (list (list* v nil (fourth fmla)))) ;; ((type>= #t(not null) tp) (list (list* v (fourth fmla) nil)))))) ;; (append i (fmla-infer-tp (fifth fmla))))) ;; (if (apply 'fmla-if (cddr fmla))) ;; (var (when (vlp fmla) (list (cons (car (third fmla)) (cons #t(not null) #tnull))))) ;; (setq (fmla-infer-tp (fourth fmla)));FIXME set var too, and in call global ;; (call-global ;; (let* ((fn (third fmla)) (rfn (cdr (assoc fn +bool-inf-op-list+))) ;; (sfn (cdr (assoc fn +bool-inf-sop-list+))) ;; (srfn (cdr (assoc sfn +bool-inf-op-list+))) ;; (args (if (eq (car fmla) 'inline) (fourth (fifth fmla)) (fourth fmla))) ;; (l (length args)) ;; (pt (get fn 'si::predicate-type)));FIXME +cmp-type-alist+ ;; (cond ((and (= l 1) (vlp (first args)) pt) ;; (list (cons (car (third (first args))) (cons (cmp-norm-tp pt) (cmp-norm-tp `(not ,pt)))))) ;; ((and (= l 2) (eq fn 'typep) (vlp (first args)) ;; (let ((tp (cmp-norm-tp (get-object-value (second args))))) ;; (when tp (list (cons (car (third (first args))) (cons tp (cmp-norm-tp `(not ,tp))))))))) ;; ((and (= l 2) rfn) ;; (nconc ;; (when (vlp (first args)) ;; (list (cons (car (third (first args))) ;; (tppra (vl-type (first args)) (second args) fn rfn)))) ;; (when (vlp (second args)) ;; (list (cons (car (third (second args))) ;; (tppra (vl-type (second args)) (first args) sfn srfn))))))))) ;; (otherwise ;; (cond ((consp (car fmla)) (fmla-infer-tp (car fmla))) ;; ((type>= #tnull (info-type (cadr fmla))) *gen-nil*) ;; ((type>= #t(not null) (info-type (cadr fmla))) *gen-t*)))))) ;; (defun fmla-infer-tp (fmla) ;; (when (unless *compiler-new-safety* (listp fmla)) ;; (case (car fmla) ;; (inline (fmla-infer-tp (fifth fmla))) ;; ((let let*) (remove-if (lambda (x) (member (car x) (third fmla))) (fmla-infer-tp (fifth fmla)))) ;; (tagbody (mapc 'fmla-infer-tp (fifth fmla)) nil);FIXME need catch/throw here, and make this an ecase ;; (block ;; (let* ((tp (info-type (cadr (fourth fmla)))) ;; (gen (list (cons +gen+ (cons (when (type-and #t(not null) tp) t) (when (type-and #tnull tp) t))))) ;; (*infer-tags* (cons (cons (third fmla) gen) *infer-tags*))) ;; (fmla-infer-tp (fourth fmla)) ;; (labels ((fmla-walk (f) (cond ((atom f));FIXME now that this is in, maybe remove mapc in tagbody and switch ;; ((eq (car f) 'return-from) (fmla-infer-tp f)) ;; (t (fmla-walk (car f)) (fmla-walk (cdr f)))))) ;; (fmla-walk (fourth fmla))) ;; (cdar *infer-tags*))) ;; (progn (fmla-infer-tp (car (last (third fmla))))) ;; (decl-body (fmla-infer-tp (fourth fmla))) ;; (return-from ;; (let ((x (assoc (third fmla) *infer-tags*))) ;; (when x (setf (cdr x) (fmla-if1 nil (cdr x) (fmla-infer-tp (seventh fmla))))))) ;; (switch ;; (mapc 'fmla-infer-tp (fourth fmla)) nil);FIXME ;; (infer-tp (let ((tp (info-type (cadr (fifth fmla)))) ;; (v (car (third (third fmla))))) ;; (cond ((type>= #tnull tp) (list (list* v nil (fourth fmla)))) ;; ((type>= #t(not null) tp) (list (list* v (fourth fmla) nil)))))) ;; (if (apply 'fmla-if (cddr fmla))) ;; (var (when (vlp fmla) (list (cons (car (third fmla)) (cons #t(not null) #tnull))))) ;; (setq (fmla-infer-tp (fourth fmla)));FIXME set var too, and in call global ;; (call-global ;; (let* ((fn (third fmla)) (rfn (cdr (assoc fn +bool-inf-op-list+))) ;; (sfn (cdr (assoc fn +bool-inf-sop-list+))) ;; (srfn (cdr (assoc sfn +bool-inf-op-list+))) ;; (args (if (eq (car fmla) 'inline) (fourth (fifth fmla)) (fourth fmla))) ;; (l (length args)) ;; (pt (get fn 'si::predicate-type)));FIXME +cmp-type-alist+ ;; (cond ((and (= l 1) (vlp (first args)) pt) ;; (list (cons (car (third (first args))) (cons (cmp-norm-tp pt) (cmp-norm-tp `(not ,pt)))))) ;; ((and (= l 2) (eq fn 'typep) (vlp (first args)) ;; (let ((tp (cmp-norm-tp (get-object-value (second args))))) ;; (when tp (list (cons (car (third (first args))) (cons tp (cmp-norm-tp `(not ,tp))))))))) ;; ((and (= l 2) rfn) ;; (nconc ;; (when (vlp (first args)) ;; (list (cons (car (third (first args))) ;; (tppra (vl-type (first args)) (second args) fn rfn)))) ;; (when (vlp (second args)) ;; (list (cons (car (third (second args))) ;; (tppra (vl-type (second args)) (first args) sfn srfn))))))))) ;; (otherwise ;; (cond ((consp (car fmla)) (fmla-infer-tp (car fmla))) ;; ((type>= #tnull (info-type (cadr fmla))) *gen-nil*) ;; ((type>= #t(not null) (info-type (cadr fmla))) *gen-t*)))))) ;; (defun fmla-infer-tp (fmla) ;; (when (unless *compiler-new-safety* (listp fmla)) ;; (case (car fmla) ;; (inline (fmla-infer-tp (fifth fmla))) ;; ((let let*) (remove-if (lambda (x) (member (car x) (third fmla))) (fmla-infer-tp (fifth fmla)))) ;; (tagbody (mapc 'fmla-infer-tp (fifth fmla)) nil);FIXME need catch/throw here, and make this an ecase ;; (block ;; (let* ((tp (info-type (cadr (fourth fmla)))) ;; (gen (list (cons +gen+ (cons (when (type-and #t(not null) tp) t) (when (type-and #tnull tp) t))))) ;; (*infer-tags* (cons (cons (third fmla) gen) *infer-tags*))) ;; (fmla-infer-tp (fourth fmla)) ;; (cdar *infer-tags*))) ;; (progn (fmla-infer-tp (car (last (third fmla))))) ;; (decl-body (fmla-infer-tp (fourth fmla))) ;; (return-from ;; (let ((x (assoc (third fmla) *infer-tags*))) ;; (when x (setf (cdr x) (fmla-if1 nil (cdr x) (fmla-infer-tp (seventh fmla))))))) ;; (switch ;; (mapc 'fmla-infer-tp (sixth fmla)) nil);FIXME ;; (infer-tp (let ((tp (info-type (cadr (fifth fmla)))) ;; (v (car (third (third fmla))))) ;; (cond ((type>= #tnull tp) (list (list* v nil (fourth fmla)))) ;; ((type>= #t(not null) tp) (list (list* v (fourth fmla) nil)))))) ;; (if (apply 'fmla-if (cddr fmla))) ;; (var (when (vlp fmla) (list (cons (car (third fmla)) (cons #t(not null) #tnull))))) ;; (setq (fmla-infer-tp (fourth fmla)));FIXME set var too, and in call global ;; (call-global ;; (let* ((fn (third fmla)) (rfn (cdr (assoc fn +bool-inf-op-list+))) ;; (sfn (cdr (assoc fn +bool-inf-sop-list+))) ;; (srfn (cdr (assoc sfn +bool-inf-op-list+))) ;; (args (if (eq (car fmla) 'inline) (fourth (fifth fmla)) (fourth fmla))) ;; (l (length args)) ;; (pt (get fn 'si::predicate-type)));FIXME +cmp-type-alist+ ;; (cond ((and (= l 1) (vlp (first args)) pt) ;; (list (cons (car (third (first args))) (cons (cmp-norm-tp pt) (cmp-norm-tp `(not ,pt)))))) ;; ((and (= l 2) (eq fn 'typep) (vlp (first args)) ;; (let ((tp (cmp-norm-tp (get-object-value (second args))))) ;; (when tp (list (cons (car (third (first args))) (cons tp (cmp-norm-tp `(not ,tp))))))))) ;; ((and (= l 2) rfn) ;; (nconc ;; (when (vlp (first args)) ;; (list (cons (car (third (first args))) ;; (tppra (vl-type (first args)) (second args) fn rfn)))) ;; (when (vlp (second args)) ;; (list (cons (car (third (second args))) ;; (tppra (vl-type (second args)) (first args) sfn srfn))))))))) ;; (otherwise ;; (cond ((consp (car fmla)) (fmla-infer-tp (car fmla))) ;; ((type>= #tnull (info-type (cadr fmla))) *gen-nil*) ;; ((type>= #t(not null) (info-type (cadr fmla))) *gen-t*)))))) ;; (defun fmla-infer-tp (fmla) ;; (when (unless *compiler-new-safety* (listp fmla)) ;; (case (car fmla) ;; (inline (fmla-infer-tp (fifth fmla))) ;; ((let let*) (fmla-infer-tp (fifth fmla))) ;; (tagbody (mapc 'fmla-infer-tp (fifth fmla)));FIXME need catch/throw here, and make this an ecase ;; (block ;; (let ((*infer-tags* (cons (cons (third fmla) *gen-nil*) *infer-tags*))) ;; (fmla-infer-tp (fourth fmla)) ;; (cdar *infer-tags*))) ;; (progn (fmla-infer-tp (car (last (third fmla))))) ;; (decl-body (fmla-infer-tp (fourth fmla))) ;; (return-from ;; (let ((x (assoc (third fmla) *infer-tags*))) ;; (when x (setf (cdr x) (fmla-if1 nil (cdr x) (fmla-infer-tp (seventh fmla))))))) ;; (switch ;; (mapc 'fmla-infer-tp (sixth fmla))) ;; (infer-tp (let ((tp (info-type (cadr (fifth fmla)))) ;; (v (car (third (third fmla))))) ;; (cond ((type>= #tnull tp) (list (list* v nil (fourth fmla)))) ;; ((type>= #t(not null) tp) (list (list* v (fourth fmla) nil)))))) ;; (if (apply 'fmla-if (cddr fmla))) ;; (var (when (vlp fmla) (list (cons (car (third fmla)) (cons #t(not null) #tnull))))) ;; (setq (fmla-infer-tp (fourth fmla)));FIXME set var too, and in call global ;; (call-global ;; (let* ((fn (third fmla)) (rfn (cdr (assoc fn +bool-inf-op-list+))) ;; (sfn (cdr (assoc fn +bool-inf-sop-list+))) ;; (srfn (cdr (assoc sfn +bool-inf-op-list+))) ;; (args (if (eq (car fmla) 'inline) (fourth (fifth fmla)) (fourth fmla))) ;; (l (length args)) ;; (pt (get fn 'si::predicate-type)));FIXME +cmp-type-alist+ ;; (cond ((and (= l 1) (vlp (first args)) pt) ;; (list (cons (car (third (first args))) (cons (cmp-norm-tp pt) (cmp-norm-tp `(not ,pt)))))) ;; ((and (= l 2) (eq fn 'typep) (vlp (first args)) ;; (let ((tp (cmp-norm-tp (get-object-value (second args))))) ;; (when tp (list (cons (car (third (first args))) (cons tp (cmp-norm-tp `(not ,tp))))))))) ;; ((and (= l 2) rfn) ;; (nconc ;; (when (vlp (first args)) ;; (list (cons (car (third (first args))) ;; (tppra (vl-type (first args)) (second args) fn rfn)))) ;; (when (vlp (second args)) ;; (list (cons (car (third (second args))) ;; (tppra (vl-type (second args)) (first args) sfn srfn))))))))) ;; (otherwise ;; (cond ((consp (car fmla)) (fmla-infer-tp (car fmla))) ;; ((type>= #tnull (info-type (cadr fmla))) *gen-nil*) ;; ((type>= #t(not null) (info-type (cadr fmla))) *gen-t*)))))) ;; (defun fmla-infer-tp (fmla) ;; (when (unless *compiler-new-safety* (listp fmla)) ;; (case (car fmla) ;; (inline (fmla-infer-tp (fifth fmla))) ;; ((let let*) (fmla-infer-tp (fifth fmla))) ;; (tagbody (mapc 'fmla-infer-tp (fifth fmla)));FIXME need catch/throw here, and make this an ecase ;; (block ;; (let ((*infer-tags* (cons (cons (third fmla) *gen-nil*) *infer-tags*))) ;; (fmla-infer-tp (fourth fmla)) ;; (cdar *infer-tags*))) ;; (progn (fmla-infer-tp (car (last (third fmla))))) ;; (decl-body (fmla-infer-tp (fourth fmla))) ;; (return-from ;; (let ((x (assoc (third fmla) *infer-tags*))) ;; (when x (setf (cdr x) (fmla-if1 nil (cdr x) (fmla-infer-tp (seventh fmla))))))) ;; (switch ;; (mapc 'fmla-infer-tp (sixth fmla))) ;; (infer-tp (let ((tp (info-type (cadr (fifth fmla))))) ;; (cond ((type>= #tnull tp) (list (list* (third fmla) nil (fourth fmla)))) ;; ((type>= #t(not null) tp) (list (list* (third fmla) (fourth fmla) nil)))))) ;; (if (apply 'fmla-if (cddr fmla))) ;; (var (when (vlp fmla) (list (cons (car (third fmla)) (cons #t(not null) #tnull))))) ;; (setq (fmla-infer-tp (fourth fmla)));FIXME set var too, and in call global ;; (call-global ;; (let* ((fn (third fmla)) (rfn (cdr (assoc fn +bool-inf-op-list+))) ;; (sfn (cdr (assoc fn +bool-inf-sop-list+))) ;; (srfn (cdr (assoc sfn +bool-inf-op-list+))) ;; (args (if (eq (car fmla) 'inline) (fourth (fifth fmla)) (fourth fmla))) ;; (l (length args)) ;; (pt (get fn 'si::predicate-type)));FIXME +cmp-type-alist+ ;; (cond ((and (= l 1) (vlp (first args)) pt) ;; (list (cons (car (third (first args))) (cons (cmp-norm-tp pt) (cmp-norm-tp `(not ,pt)))))) ;; ((and (= l 2) (eq fn 'typep) (vlp (first args)) ;; (let ((tp (cmp-norm-tp (get-object-value (second args))))) ;; (when tp (list (cons (car (third (first args))) (cons tp (cmp-norm-tp `(not ,tp))))))))) ;; ((and (= l 2) rfn) ;; (nconc ;; (when (vlp (first args)) ;; (list (cons (car (third (first args))) ;; (tppra (vl-type (first args)) (second args) fn rfn)))) ;; (when (vlp (second args)) ;; (list (cons (car (third (second args))) ;; (tppra (vl-type (second args)) (first args) sfn srfn))))))))) ;; (otherwise ;; (cond ((consp (car fmla)) (fmla-infer-tp (car fmla))) ;; ((type>= #tnull (info-type (cadr fmla))) *gen-nil*) ;; ((type>= #t(not null) (info-type (cadr fmla))) *gen-t*)))))) ;; (defun fmla-infer-tp (fmla) ;; (when (unless *compiler-new-safety* (listp fmla)) ;; (case (car fmla) ;; (inline (fmla-infer-tp (fifth fmla))) ;; ((let let*) (let* ((sl (mapcar 'cons (third fmla) (fourth fmla)));FIXME, sublis these alias bindings at the c1let* level ;; (ch (reduce 'union (mapcar (lambda (x) (info-ch (cadr x))) (append (fourth fmla) (list (fifth fmla)))))) ;; (sl (remove-if (lambda (x) (or (member (car x) ch) (not (eq (cadr x) 'var)))) sl)) ;; (sl (mapcar (lambda (x) (cons (car x) (car (third (cdr x))))) sl))) ;; (sublis sl (fmla-infer-tp (fifth fmla))))) ;; (tagbody (mapc 'fmla-infer-tp (fifth fmla)));FIXME need catch/throw here, and make this an ecase ;; (block ;; (let ((*infer-tags* (cons (cons (third fmla) *gen-nil*) *infer-tags*))) ;; (fmla-infer-tp (fourth fmla)) ;; (cdar *infer-tags*))) ;; (progn (fmla-infer-tp (car (last (third fmla))))) ;; (decl-body (fmla-infer-tp (fourth fmla))) ;; (return-from ;; (let ((x (assoc (third fmla) *infer-tags*))) ;; (when x (setf (cdr x) (fmla-if1 nil (cdr x) (fmla-infer-tp (seventh fmla))))))) ;; (switch ;; (mapc 'fmla-infer-tp (sixth fmla))) ;; (infer-tp (let ((tp (info-type (cadr (fifth fmla))))) ;; (cond ((type>= #tnull tp) (list (list* (third fmla) nil (fourth fmla)))) ;; ((type>= #t(not null) tp) (list (list* (third fmla) (fourth fmla) nil)))))) ;; (if (apply 'fmla-if (cddr fmla))) ;; (var (when (vlp fmla) (list (cons (car (third fmla)) (cons #t(not null) #tnull))))) ;; (setq (fmla-infer-tp (fourth fmla)));FIXME set var too, and in call global ;; (call-global ;; (let* ((fn (third fmla)) (rfn (cdr (assoc fn +bool-inf-op-list+))) ;; (sfn (cdr (assoc fn +bool-inf-sop-list+))) ;; (srfn (cdr (assoc sfn +bool-inf-op-list+))) ;; (args (if (eq (car fmla) 'inline) (fourth (fifth fmla)) (fourth fmla))) ;; (l (length args)) ;; (pt (get fn 'si::predicate-type)));FIXME +cmp-type-alist+ ;; (cond ((and (= l 1) (vlp (first args)) pt) ;; (list (cons (car (third (first args))) (cons (cmp-norm-tp pt) (cmp-norm-tp `(not ,pt)))))) ;; ((and (= l 2) (eq fn 'typep) (vlp (first args)) ;; (let ((tp (cmp-norm-tp (get-object-value (second args))))) ;; (when tp (list (cons (car (third (first args))) (cons tp (cmp-norm-tp `(not ,tp))))))))) ;; ((and (= l 2) rfn) ;; (nconc ;; (when (vlp (first args)) ;; (list (cons (car (third (first args))) ;; (tppra (vl-type (first args)) (second args) fn rfn)))) ;; (when (vlp (second args)) ;; (list (cons (car (third (second args))) ;; (tppra (vl-type (second args)) (first args) sfn srfn))))))))) ;; (otherwise ;; (cond ((consp (car fmla)) (fmla-infer-tp (car fmla))) ;; ((type>= #tnull (info-type (cadr fmla))) *gen-nil*) ;; ((type>= #t(not null) (info-type (cadr fmla))) *gen-t*)))))) ;; (defun fmla-infer-tp (fmla) ;; (unless *compiler-new-safety* ;; (case (car fmla) ;; (if (apply 'fmla-if (cddr fmla))) ;; (var (when (vlp fmla) (list (cons (var-name (car (third fmla))) (cons #t(not null) #tnull))))) ;; (setq (fmla-infer-tp (fourth fmla)));FIXME set var too, and in call global ;; ((inline call-global) ;; (let* ((fn (third fmla)) (rfn (cdr (assoc fn +bool-inf-op-list+))) ;; (sfn (cdr (assoc fn +bool-inf-sop-list+))) ;; (srfn (cdr (assoc sfn +bool-inf-op-list+))) ;; (args (if (eq (car fmla) 'inline) (fourth (fifth fmla)) (fourth fmla))) ;; (l (length args)) ;; (pt (get fn 'si::predicate-type)));FIXME +cmp-type-alist+ ;; (cond ((and (= l 1) (vlp (first args)) pt) ;; (list (cons (vl-name (first args)) (cons (cmp-norm-tp pt) (cmp-norm-tp `(not ,pt)))))) ;; ((and (= l 2) (eq fn 'typep) (vlp (first args)) ;; (let ((tp (cmp-norm-tp (get-object-value (second args))))) ;; (when tp (list (cons (vl-name (first args)) (cons tp (cmp-norm-tp `(not ,tp))))))))) ;; ((and (= l 2) rfn) ;; (nconc ;; (when (vlp (first args)) ;; (list (cons (vl-name (first args)) ;; (tppra (vl-type (first args)) (second args) fn rfn)))) ;; (when (vlp (second args)) ;; (list (cons (vl-name (second args)) ;; (tppra (vl-type (second args)) (first args) sfn srfn))))))))) ;; (otherwise ;; (cond ((consp (car fmla)) (fmla-infer-tp (car fmla))) ;; ((type>= #tnull (info-type (cadr fmla))) *gen-nil*) ;; ((type>= #t(not null) (info-type (cadr fmla))) *gen-t*)))))) (defvar *restore-vars* nil) (defun restrict-type (v ot lt) (setf (var-type v) ot) (unless (type>= lt ot) (let ((nt (type-and ot lt))) (keyed-cmpnote (list 'type 'type-restriction (var-name v)) "restricting type of ~s to ~s~%" (var-name v) (cmp-unnorm-tp nt)) (setf (var-type v) nt)))) (defun ignorable-pivot (pivot value) (let ((s (sgen "IGNORABLE-PIVOT"))) `(let ((,s ,pivot)) (declare (ignorable ,s)) ,value))) (defun fmla-is-changed (var fmla) (cond ((info-p fmla) (is-changed var fmla)) ((atom fmla) nil) ((or (fmla-is-changed var (car fmla)) (fmla-is-changed var (cdr fmla)))))) ;; (defun fmla-is-changed (name fmla) ;; (cond ((info-p fmla) (let ((v (car (member name *vars* :key (lambda (x) (when (var-p x) (var-name x))))))) ;; (is-changed v fmla))) ;; ((atom fmla) nil) ;; ((or (fmla-is-changed name (car fmla)) (fmla-is-changed name (cdr fmla)))))) (defun c1branch (tf r args info) (if (and (not tf) (endp (cddr args))) (list (c1nil) nil) (with-restore-vars ;FIXME eliminate if any variable restricts to nil (dolist (l r) (restrict-type (car l) (cadr l) (let ((l (caddr l))) (if tf (car l) (cdr l))))) (let (trv (b (c1expr* (if tf (cadr args) (caddr args)) info))) (dolist (l *restore-vars*) (push (list (car l) (var-type (car l)) (var-store (car l))) trv));) (keep-warnings) (list b trv))))) (defun c-and (y x) (if (type>= #tnull (info-type (cadr y))) y (let ((x (fmla-c1expr x))) (list 'if (make-info :type (type-or1 (info-type (cadr x)) #tnull)) y x (c1nil))))) (defun c-or (y x) (if (type>= #t(not null) (info-type (cadr y))) y (let ((x (fmla-c1expr x))) (list 'if (make-info :type (type-or1 (info-type (cadr x)) #t(member t))) y (c1t) x)))) (defun c-not (x) (let ((x (fmla-c1expr x))) (cond ((type>= #tnull (info-type (cadr x))) (list 'progn (make-info :type #t(member t)) (list x (c1t)))) ((type>= #t(not null) (info-type (cadr x))) (list 'progn (make-info :type #tnull) (list x (c1nil)))) ((list 'if (make-info :type #tboolean) x (c1nil) (c1t)))))) (defun fmla-c1expr (fmla) (case (car fmla) (fmla-and (reduce 'c-and (cdr fmla) :initial-value (c1t))) (fmla-or (reduce 'c-or (cdr fmla) :initial-value (c1nil))) (fmla-not (c-not (fmla-c1expr (cadr fmla)))) (otherwise fmla))) (defun maybe-progn-fmla (fmla args) (c1progn (list fmla args) (list (fmla-c1expr fmla) (c1expr args)))) (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) (when (caddr args) (note-branch-elimination (car args) t (caddr args))) (c1expr (cadr args))) ((nil) (note-branch-elimination (car args) nil (cadr args)) (if (endp (cddr args)) (c1nil) (c1expr (caddr args)))) (otherwise (setq info (make-info)) (let* ((fmla (c1fmla f info)) (inf (fmla-clean (fmla-infer-tp fmla))) (inf (remove-if (lambda (x) (fmla-is-changed (car x) fmla)) inf)) (fmlae (fmla-eval-const fmla)) (fmlae (if (notevery 'cadr inf) nil fmlae)) (fmlae (if (notevery 'cddr inf) t fmlae))) (when inf (keyed-cmpnote (list* 'type-inference (mapcar (lambda (x) (var-name (car x))) inf)) "inferring types on form ~s, ~s" f (mapcar (lambda (x) (list (pop x) (cmp-unnorm-tp (pop x)) (cmp-unnorm-tp x))) inf))) (if (not (eq fmlae 'boolean)) (cond (fmlae (when (caddr args) (note-branch-elimination (car args) t (caddr args))) (maybe-progn-fmla fmla (cadr args))) (t (note-branch-elimination (car args) nil (cadr args)) (maybe-progn-fmla fmla (caddr args)))) (let (r) (dolist (l inf) (let ((v (car l))) (when v (push (list v (var-type v) (cdr l)) r)))) (unwind-protect (let* ((tbl (c1branch t r args info)) (fbl (c1branch nil r args info)) (tb (car tbl)) (fb (car fbl)) (tret (info-type (cadr tb))) (fret (info-type (cadr fb))) (trv (append (when tret (cadr tbl)) (when fret (cadr fbl))))) (setf (info-type info) (type-or1 (info-type (cadr tb)) (info-type (cadr fb)))) (do (rv) ((not (setq rv (pop r)))) (setf (var-type (car rv)) (cadr rv)) (if fret (unless tret (do-setq-tp (car rv) nil (type-and (cdr (caddr rv)) (var-type (car rv))))) (when tret (do-setq-tp (car rv) nil (type-and (car (caddr rv)) (var-type (car rv))))))) (do (rv) ((not (setq rv (pop trv)))) (unless (subsetp (caddr rv) (var-store (car rv))) (keyed-cmpnote (list (var-name (car rv)) 'var-store 'binding '+opaque+) "~s store set to +opaque+ from ~s/~s across if branches" (var-name (car rv)) (caddr rv) (var-store (car rv))) (push-vbinds (car rv) (caddr rv))) (do-setq-tp (car rv) (list args nil) (type-or1 (var-type (car rv)) (cadr rv)))) (list 'if info fmla tb fb)) (dolist (l r) (setf (var-type (car l)) (cadr l)))))))))) ;; (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) ;; (when (caddr args) (note-branch-elimination (car args) t (caddr args))) ;; (c1expr (cadr args))) ;; ((nil) ;; (note-branch-elimination (car args) nil (cadr args)) ;; (if (endp (cddr args)) (c1nil) (c1expr (caddr args)))) ;; (otherwise ;; (setq info (make-info)) ;; (let* ((fmla (c1fmla f info)) ;; (inf (delete +gen+ (fmla-infer-tp fmla) :key 'car)) ;; (inf (remove-if (lambda (x) (fmla-is-changed (car x) fmla)) inf)) ;; (fmlae (fmla-eval-const fmla)) ;; (fmlae (if (notevery 'cadr inf) nil fmlae)) ;; (fmlae (if (notevery 'cddr inf) t fmlae))) ;; (when inf ;; (keyed-cmpnote (list* 'type-inference (mapcar (lambda (x) (var-name (car x))) inf)) ;; "inferring types on form ~s, ~s" f inf)) ;; (if (not (eq fmlae 'boolean)) ;; (cond (fmlae ;; (when (caddr args) (note-branch-elimination (car args) t (caddr args))) ;; (maybe-progn-fmla fmla (cadr args) info)) ;; (t (note-branch-elimination (car args) nil (cadr args)) ;; (maybe-progn-fmla fmla (caddr args) info))) ;; (let (r) ;; (dolist (l inf) ;; (let ((v (car l))) ;; (when v ;; (push (list v (var-type v) (cdr l)) r)))) ;; (unwind-protect ;; (let* ((tbl (c1branch t r args info)) ;; (fbl (c1branch nil r args info)) ;; (tb (car tbl)) ;; (fb (car fbl)) ;; (trv (append (cadr tbl) (cadr fbl)))) ;; (setf (info-type info) (type-or1 (info-type (cadr tb)) (info-type (cadr fb)))) ;; (do (rv) ((not (setq rv (pop r)))) ;; (setf (var-type (car rv)) (cadr rv)) ;; (if (info-type (cadr fb)) ;; (unless (info-type (cadr tb)) ;; (do-setq-tp (car rv) nil (type-and (cdr (caddr rv)) (var-type (car rv))))) ;; (when (info-type (cadr tb)) ;; (do-setq-tp (car rv) nil (type-and (car (caddr rv)) (var-type (car rv))))))) ;; (do (rv) ((not (setq rv (pop trv)))) ;; (setf (var-store (car rv)) (if (eq (var-store (car rv)) (caddr rv)) (var-store (car rv)) +opaque+)) ;; (do-setq-tp (car rv) (list args nil) (type-or1 (var-type (car rv)) (cadr rv)))) ;; (list 'if info fmla tb fb)) ;; (dolist (l r) ;; (setf (var-type (car l)) (cadr l)))))))))) ;; (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) ;; (when (caddr args) (note-branch-elimination (car args) t (caddr args))) ;; (c1expr (cadr args))) ;; ((nil) ;; (note-branch-elimination (car args) nil (cadr args)) ;; (if (endp (cddr args)) (c1nil) (c1expr (caddr args)))) ;; (otherwise ;; (setq info (make-info)) ;; (let* ((fmla (c1fmla f info)) ;; (inf (delete +gen+ (fmla-infer-tp fmla) :key 'car)) ;; (inf (remove-if (lambda (x) (fmla-is-changed (car x) fmla)) inf)) ;; (fmlae (fmla-eval-const fmla)) ;; (fmlae (if (notevery 'cadr inf) nil fmlae)) ;; (fmlae (if (notevery 'cddr inf) t fmlae))) ;; (when inf ;; (keyed-cmpnote (list* 'type-inference (mapcar (lambda (x) (var-name (car x))) inf)) ;; "inferring types on form ~s, ~s" f inf)) ;; (if (not (eq fmlae 'boolean)) ;; (cond (fmlae ;; (when (caddr args) (note-branch-elimination (car args) t (caddr args))) ;; (maybe-progn-fmla fmla (cadr args) info)) ;; (t (note-branch-elimination (car args) nil (cadr args)) ;; (maybe-progn-fmla fmla (caddr args) info))) ;; (let (r) ;; (dolist (l inf) ;; (let ((v (car l))) ;; (when v ;; (push (list v (var-type v) (cdr l)) r)))) ;; (unwind-protect ;; (let* ((tbl (c1branch t r args info)) ;; (fbl (c1branch nil r args info)) ;; (tb (car tbl)) ;; (fb (car fbl)) ;; (trv (append (cadr tbl) (cadr fbl)))) ;; (setf (info-type info) (type-or1 (info-type (cadr tb)) (info-type (cadr fb)))) ;; (do (rv) ((not (setq rv (pop r)))) ;; (setf (var-type (car rv)) (cadr rv)) ;; (unless (info-type (cadr tb)) ;; (do-setq-tp (car rv) nil (type-and (cdr (caddr rv)) (var-type (car rv))))) ;; (unless (info-type (cadr fb)) ;; (do-setq-tp (car rv) nil (type-and (car (caddr rv)) (var-type (car rv)))))) ;; (do (rv) ((not (setq rv (pop trv)))) ;; (do-setq-tp (car rv) (list args nil) (type-or1 (var-type (car rv)) (cadr rv)))) ;; (list 'if info fmla tb fb)) ;; (dolist (l r) ;; (setf (var-type (car l)) (cadr l)))))))))) ;; (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) ;; (when (caddr args) (note-branch-elimination (car args) t (caddr args))) ;; (c1expr (cadr args))) ;; ((nil) ;; (note-branch-elimination (car args) nil (cadr args)) ;; (if (endp (cddr args)) (c1nil) (c1expr (caddr args)))) ;; (otherwise ;; (setq info (make-info)) ;; (let* ((fmla (c1fmla f info)) ;; (inf (delete +gen+ (fmla-infer-tp fmla) :key 'car)) ;; (inf (remove-if (lambda (x) (fmla-is-changed (car x) fmla)) inf)) ;; (fmlae (fmla-eval-const fmla)) ;; (fmlae (if (notevery 'cadr inf) nil fmlae)) ;; (fmlae (if (notevery 'cddr inf) t fmlae))) ;; (when inf ;; (keyed-cmpnote (list* 'type-inference (mapcar (lambda (x) (var-name (car x))) inf)) ;; "inferring types on form ~s, ~s" f inf)) ;; (if (not (eq fmlae 'boolean)) ;; (cond (fmlae ;; (when (caddr args) (note-branch-elimination (car args) t (caddr args))) ;; (maybe-progn-fmla fmla (cadr args) info)) ;; (t (note-branch-elimination (car args) nil (cadr args)) ;; (maybe-progn-fmla fmla (caddr args) info))) ;; (let (r) ;; (dolist (l inf) ;; (let ((v (car l))) ;; (when v ;; (push (list v (var-type v) (cdr l)) r)))) ;; (unwind-protect ;; (let* ((tbl (c1branch t r args info)) ;; (fbl (c1branch nil r args info)) ;; (tb (car tbl)) ;; (fb (car fbl)) ;; (trv (append (cadr tbl) (cadr fbl)))) ;; (setf (info-type info) (type-or1 (info-type (cadr tb)) (info-type (cadr fb)))) ;; (do (rv) ((not (setq rv (pop r)))) ;; (setf (var-type (car rv)) (cadr rv)) ;; (unless (info-type (cadr tb)) ;; (do-setq-tp (car rv) nil (type-and (cdr (caddr rv)) (var-type (car rv))))) ;; (unless (info-type (cadr fb)) ;; (do-setq-tp (car rv) nil (type-and (car (caddr rv)) (var-type (car rv)))))) ;; (do (rv) ((not (setq rv (pop trv)))) ;; (do-setq-tp (car rv) nil (type-or1 (var-type (car rv)) (cadr rv)))) ;; (list 'if info fmla tb fb)) ;; (dolist (l r) ;; (setf (var-type (car l)) (cadr l)))))))))) ;; (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) ;; (when (caddr args) (note-branch-elimination (car args) t (caddr args))) ;; (c1expr (cadr args))) ;; ((nil) ;; (note-branch-elimination (car args) nil (cadr args)) ;; (if (endp (cddr args)) (c1nil) (c1expr (caddr args)))) ;; (otherwise ;; (setq info (make-info)) ;; (let* ((fmla (c1fmla f info)) ;; (inf (delete +gen+ (fmla-infer-tp fmla) :key 'car)) ;; (inf (remove-if (lambda (x) (fmla-is-changed (car x) fmla)) inf)) ;; (fmlae (fmla-eval-const fmla)) ;; (fmlae (if (notevery 'cadr inf) nil fmlae)) ;; (fmlae (if (notevery 'cddr inf) t fmlae))) ;; (when inf ;; (keyed-cmpnote (list* 'type-inference (mapcar 'car inf)) ;; "inferring types on form ~s, ~s" f inf)) ;; (if (not (eq fmlae 'boolean)) ;; (cond (fmlae ;; (when (caddr args) (note-branch-elimination (car args) t (caddr args))) ;; (maybe-progn-fmla fmla (cadr args) info)) ;; (t (note-branch-elimination (car args) nil (cadr args)) ;; (maybe-progn-fmla fmla (caddr args) info))) ;; (let (r) ;; (dolist (l inf) ;; (let ((v (car (member (car l) *vars* :key (lambda (x) (when (var-p x) (var-name x))))))) ;; (when v ;; (push (list v (var-type v) (cdr l)) r))));;FIXME return in this from from infer-tp ;; (unwind-protect ;; (let* ((tbl (c1branch t r args info)) ;; (fbl (c1branch nil r args info)) ;; (tb (car tbl)) ;; (fb (car fbl)) ;; (trv (append (cadr tbl) (cadr fbl)))) ;; (setf (info-type info) (type-or1 (info-type (cadr tb)) (info-type (cadr fb)))) ;; (do (rv) ((not (setq rv (pop r)))) ;; (setf (var-type (car rv)) (cadr rv)) ;; (unless (info-type (cadr tb)) ;; (do-setq-tp (car rv) nil (type-and (cdr (caddr rv)) (var-type (car rv))))) ;; (unless (info-type (cadr fb)) ;; (do-setq-tp (car rv) nil (type-and (car (caddr rv)) (var-type (car rv)))))) ;; (do (rv) ((not (setq rv (pop trv)))) ;; (do-setq-tp (car rv) nil (type-or1 (var-type (car rv)) (cadr rv)))) ;; (list 'if info fmla tb fb)) ;; (dolist (l r) ;; (setf (var-type (car l)) (cadr l)))))))))) (defun t-and (x y) (cond ((eq x 'boolean) (when y 'boolean)) ((eq y 'boolean) (when x 'boolean)) ((and x y)))) (defun t-or (x y) (cond ((eq x 'boolean) (or (eq y t) 'boolean)) ((eq y 'boolean) (or (eq x t) 'boolean)) ((or x y)))) (defun t-not (x) (if (eq x 'boolean) 'boolean (not x))) (defun fmla-eval-const (fmla) (if *compiler-new-safety* 'boolean (case (car fmla) (fmla-and (reduce (lambda (y x) (t-and (fmla-eval-const x) y)) (cdr fmla) :initial-value t)) (fmla-or (reduce (lambda (y x) (t-or (fmla-eval-const x) y)) (cdr fmla) :initial-value nil)) (fmla-not (t-not (fmla-eval-const (cdr fmla)))) ((t nil) (car fmla)) (otherwise (if (consp (car fmla)) (fmla-eval-const (car fmla)) (cond ((type>= #tnull (info-type (second fmla))) nil) ;FIXME ((type>= #t(not null) (info-type (second fmla))) t) ('boolean))))))) (defun c1fmla-constant (fmla &aux f) (cond (*compiler-new-safety* fmla) ((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 fmla-tp (fmla) (case (car fmla) ((fmla-and fmla-or) (let ((tp (if (eq (car fmla) 'fmla-and) #tnull #t(not null))) (z (mapcar 'fmla-tp (cdr fmla)))) (reduce (lambda (y x) (if (type>= tp y) y (type-or1 x (type-and tp y)))) (cdr z) :initial-value (car z)))) (fmla-not (let ((tp (fmla-tp (cadr fmla)))) (cond ((type>= #tnull tp) #t(member t)) ((type>= #t(not null) tp) #tnull) (#tboolean)))) (otherwise (info-type (cadr fmla))))) ;; (defun fmla-and-or (fmlac info tp) ;; (let (r rp z) ;; (dolist (x fmlac r) ;; (with-restore-vars ;; (setq z (c1fmla x info)) ;; (do (l) ((not (setq l (pop *restore-vars*)))) ;; (setf (var-type (car l)) (type-or1 (var-type (car l)) (cadr l))))) ;; (setq rp (let ((tmp (cons z nil))) (if rp (cdr (rplacd rp tmp)) (setq r tmp)))) ;; (when (type>= tp (fmla-tp z)) ;; (return r))))) ;; (defun c1fmla (fmla info &aux *c1exit*) ;; (if (atom fmla) (c1expr* fmla info) ;; (case (car fmla) ;; (and (case (length (cdr fmla)) ;; (0 (c1t)) ;; (1 (c1fmla (cadr fmla) info)) ;; (t (cons 'FMLA-AND (fmla-and-or (cdr fmla) info #tnull))))) ;; (or (case (length (cdr fmla)) ;; (0 (c1nil)) ;; (1 (c1fmla (cadr fmla) info)) ;; (t (cons 'FMLA-OR (fmla-and-or (cdr fmla) info #t(not null)))))) ;; ((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 (let* ((cm (and (symbolp (car fmla)) (get (car fmla) 'si::compiler-macro-prop))) ;; (cm (and cm (funcall cm fmla nil)))) ;; (cond ((and cm (not (eq cm fmla))) (c1fmla cm info)) ;; ((let ((r (c1expr* fmla info))) ;; (if (type>= #tboolean (info-type (cadr r))) r ;; (let ((info (make-info :type #tboolean))) ;; (add-info info (cadr r)) ;; (list 'if info ;; (list 'call-global info 'eq (list r (c1nil))) ;; (c1nil) (c1t)))))))))))) (defconstant +fmla+ (list (make-c1exit (gensym)))) (defun exit-to-fmla-p nil (eq (last *c1exit*) +fmla+)) (defun co1or-arg-tp (arg) (let ((x (with-restore-vars (c1expr arg)))) (if (member-if 'is-ttl-tag (info-ref (cadr x))) #tt (info-type (cadr x))))) (defun co1or (fn args) (declare (ignore fn)) (let* ((tp (when (and args (exit-to-fmla-p)) #t(member t))) (arg (pop args)) (tp (or tp (co1or-arg-tp arg))) (atp (atomic-tp (type-and tp #t(not null))))) (when (atomic-type-constant-value atp);FIXME make sure this is never a binding (c1expr (if args `(if ,arg ',(car atp) (or ,@args)) arg))))) ;; (defun co1or (fn args) ;; (declare (ignore fn)) ;; (let* ((tp (when (and args (exit-to-fmla-p)) #t(member t))) ;; (arg (pop args)) ;; (tp (or tp (info-type (cadr (with-restore-vars (c1expr arg)))))) ;; (atp (atomic-tp (type-and tp #t(not null))))) ;; (when (atomic-type-constant-value atp);FIXME make sure this is never a binding ;; (c1expr `(if ,arg ',(car atp) ,@(when args `((or ,@args)))))))) ;; (defun co1or (fn args) ;; (declare (ignore fn)) ;; (with-restore-vars ;; (let* ((tp (when (and args (exit-to-fmla-p)) #t(member t))) ;; (arg (pop args)) ;; (tp (or tp (info-type (cadr (c1expr arg))))) ;; (atp (atomic-tp (type-and tp #t(not null))))) ;; (when (atomic-type-constant-value atp) ;; (keep-vars) ;; (c1expr `(if ,arg ',(car atp) (or ,@args))))))) (setf (get 'or 'co1special) 'co1or) (defun c1fmla (fmla info &aux (*c1exit* +fmla+)) (c1expr* fmla info)) (defun not-compiler-macro (form env) (declare (ignore env)) `(if ,(cadr form) nil t)) (setf (get 'not 'si::compiler-macro-prop) 'not-compiler-macro) (setf (get 'null 'si::compiler-macro-prop) 'not-compiler-macro) (defun c2if (fmla form1 form2) (let* ((v *value-to-go*) (rev (and (type>= #tnull (info-type (cadr form1))) (type>= #t(not null) (info-type (cadr form2))))) (reg (and (type>= #tnull (info-type (cadr form2))) (type>= #t(not null) (info-type (cadr form1))))) (vj (when (or rev reg) (and (consp v) (car (member (car v) '(jump-true jump-false)))))) (fj (eq vj (if rev 'jump-true 'jump-false))) (Flabel (next-label)) ; (Flabel (if vj (if fj (cadr v) (caddr v)) (next-label))) FIXME: This needs working side-effects propagation (Tlabel (if vj (if fj (caddr v) (cadr v)) (next-label)))) (let* ((*unwind-exit* (cons Flabel (cons Tlabel *unwind-exit*))) (*exit* Tlabel)) (CJF fmla Tlabel Flabel)) (unless vj (wt-label Tlabel)) (let ((*unwind-exit* (cons 'JUMP *unwind-exit*))) (c2expr form1)) (wt-label Flabel) ; (unless vj (wt-label Flabel)) (c2expr form2))) ;; (defun c2if (fmla form1 form2 ;; &aux (Tlabel (next-label)) Flabel) ;; (cond ((and (eq (car form2) 'LOCATION);FIXME axe this ;; (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)))) (defun CJF (fmla Tlabel Flabel) (let ((*value-to-go* (list 'jump-false Flabel Tlabel))) (c2expr* fmla))) (defun CJT (fmla Tlabel Flabel) (let ((*value-to-go* (list 'jump-true Tlabel Flabel))) (c2expr* fmla))) ;; (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 Tlabel))) ;; (c2expr* fmla))))) ;; (OTHERWISE (let ((*value-to-go* (list 'jump-false Flabel Tlabel))) (c2expr* fmla))))) ;; (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 Flabel))) ;; (c2expr* fmla))))) ;; (OTHERWISE (let ((*value-to-go* (list 'jump-true Tlabel Flabel))) (c2expr* fmla))))) ;;; 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))) ;; ((let ((info (make-info)) ;; (nargs (append (mapcar (lambda (x) `(when ,x t)) (butlast args)) ;; (last args)))) ;; (list 'AND info (c1args nargs 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 co1or (fn args &aux (arg (pop args))) ;; (let* ((tp (info-type (cadr (c1expr arg)))) ;; (atp (atomic-tp (type-and tp #t(not null)))));(print (list arg args tp atp))(break) ;; (when (and atp (c1constant-value (setq atp (car atp)) nil)) ;; (c1expr `(if ,arg ',atp (or ,@args)))))) ;; (si:putprop 'or 'co1or 'co1special) ;; (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) (let* ((sym (sgen "SWITCH")) (op (pop args)) (args (mapcan (lambda (x &aux (k (pop x))(k (or (eq k 'otherwise) k))) (when k `(,@(if (listp k) k (list k)) (return-from ,sym (progn ,@x))))) args))) `(block ,sym (switch ,op ,@(if (member t args) args (nconc args `(t (return-from ,sym nil)))))))) ;; (defun convert-case-to-switch (args default) ;; (let ((sym (tmpsym)) 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 (switch ,(car args) ,@(nreverse body))))) (defun conv-kl (l s &aux (l (if (listp l) (remove-duplicates l) l))) (cond ((not l) nil) ((atom l) `(= ,s ,l)) ((not (cdr l)) `(= ,s ,(car l))) ((let* ((l (sort (copy-list l) '<)) (n (car l)) (x (car (last l))) (ll (let ((i (- n 1))) (mapl (lambda (x) (setf (car x) (incf i))) (make-list (length l)))))) (when (equal l ll) `(<= ,n ,s ,x)))))) (define-compiler-macro case (&whole form &rest args) (if (type>= #tfixnum (nil-to-t (info-type (cadr (with-restore-vars (c1arg (car args))))))) (let* ((s (pop args)) (oth (member-if (lambda (x &aux (x (car x))) (or (eq x t) (eq x 'otherwise))) args)) (rem (ldiff args oth)) (ff (when rem (conv-kl (caar rem) s)))) (flet ((f (x) (let ((d (cdar x))) (if (cdr d) (cons 'progn d) (car d))))) (cond ((unless (cdr rem) (when ff `(if ,ff ,(f rem) ,(f oth))))) ((convert-case-to-switch (cdr form)))))) form)) ;; (define-compiler-macro case (&whole form &rest args) ;; (if (type>= #tfixnum (nil-to-t (info-type (cadr (with-restore-vars (c1arg (car args))))))) ;; (let* ((s (pop args)) ;; (oth (member-if (lambda (x &aux (x (car x))) (or (eq x t) (eq x 'otherwise))) args)) ;; (rem (ldiff args oth)) ;; (ff (when rem (conv-kl (caar rem) s)))) ;; (flet ((f (x) (let ((d (cdar x))) (if (cdr d) (cons 'progn d) (car d))))) ;; (cond ((unless (cdr rem) (when ff `(if ,ff ,(f rem) ,(f oth))))) ;; ((convert-case-to-switch (cdr form) nil))))) ;; form)) ;; (defun c1case (args &optional (default nil)) ;; (when (endp args) (too-few-args 'case 1 0)) ;; (let* ((info (make-info :type #tnil)) ;; (key-form (with-restore-vars (c1arg (car args) info))) ;; (clauses nil) or-list) ;; (cond #+switch((unless (atomic-tp (info-type (second key-form)));FIXME ;; (type>= #tfixnum (nil-to-t (info-type (second key-form))))) ;; (return-from c1case (c1expr (convert-case-to-switch args default )))) ;; ((return-from c1case (c1expr (cmp-macroexpand `(,(if default 'ecase 'case) ,@args)))))) ;; (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 (with-restore-vars ;; (prog1 ;; (c1progn (cdr clause)) ;; (dolist (l *restore-vars*) (push (list (car l) (var-type (car l))) or-list))))) ;; (setf (info-type info) (type-or1 (info-type info) (info-type (cadr default)))) ;; (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 (with-restore-vars ;; (prog1 ;; (c1progn (cdr clause)) ;; (dolist (l *restore-vars*) (push (list (car l) (var-type (car l))) or-list)))))) ;; (add-info info (cadr body)) ;; (setf (info-type info) (type-or1 (info-type info) (info-type (cadr body)))) ;; (push (cons keylist body) clauses))))) ;; (dolist (l or-list) (setf (var-type (car l)) (type-or1 (var-type (car l)) (cadr l)))) ;; (list 'case info key-form (reverse clauses) (or default (c1nil))))) ;; (defun c1case (args &optional (default nil)) ;; (when (endp args) (too-few-args 'case 1 0)) ;; (let* ((info (make-info :type #tnil)) ;; (key-form (with-restore-vars (c1expr* (car args) info))) ;; (clauses nil) or-list) ;; (cond #+switch((unless (atomic-tp (info-type (second key-form)));FIXME ;; (type>= #tfixnum (nil-to-t (info-type (second key-form))))) ;; (return-from c1case (c1expr (convert-case-to-switch args default )))) ;; ((return-from c1case (c1expr (cmp-macroexpand `(,(if default 'ecase 'case) ,@args)))))) ;; (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 (with-restore-vars ;; (prog1 ;; (c1progn (cdr clause)) ;; (dolist (l *restore-vars*) (push (list (car l) (var-type (car l))) or-list))))) ;; (setf (info-type info) (type-or1 (info-type info) (info-type (cadr default)))) ;; (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 (with-restore-vars ;; (prog1 ;; (c1progn (cdr clause)) ;; (dolist (l *restore-vars*) (push (list (car l) (var-type (car l))) or-list)))))) ;; (add-info info (cadr body)) ;; (setf (info-type info) (type-or1 (info-type info) (info-type (cadr body)))) ;; (push (cons keylist body) clauses))))) ;; (dolist (l or-list) (setf (var-type (car l)) (type-or1 (var-type (car l)) (cadr l)))) ;; (list 'case info key-form (reverse clauses) (or default (c1nil))))) ;; (defun c2case (key-form clauses default ;; &aux (cvar (cs-push t t)) (*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)) ;; (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)) gcl27-2.7.0/cmpnew/gcl_cmpinit.lsp000077500000000000000000000006331454061450500167500ustar00rootroot00000000000000;(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))) gcl27-2.7.0/cmpnew/gcl_cmpinline.lsp000077500000000000000000001437521454061450500172750ustar00rootroot00000000000000;;; 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 eql-not-nil (x y) `(and ,x (eql ,x ,y))) ;; 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 s-print (n x a s) (princ "#<" s) (princ n s) (princ " " s) (princ x s) (format s " ~x>" a)) (defstruct (info (:print-function (lambda (x s i) (s-print 'info (info-type x) (si::address x) s))) (:copier old-copy-info)) (type t) ;;; Type of the form. (sp-change 0 :type bit) ;;; Whether execution of the form may change the value of a special variable *VS*. (volatile 0 :type bit) ;;; whether there is a possible setjmp (flags 0 :type char) (unused1 0 :type char) (ch nil :type list) (ref-ccb nil :type list) (ref-clb nil :type list) (ref nil :type list) (ch-ccb nil :type list) ) (si::freeze-defstruct 'info) (defconstant +iflags+ '(side-effects provisional compiler args)) (defmacro iflag-p (flags flag) (let ((i (position flag +iflags+))) (unless i (baboon)) `(logbitp ,i ,flags))) (defmacro iflags (&rest flags &aux (r 0)) (dolist (flag flags r) (let ((i (position flag +iflags+))) (unless i (baboon)) (setq r (logior r (ash 1 i)))))) (defmacro copy-ht (ht) `(copy-list ,ht));nil ? (defun copy-info (info) (let ((new-info (old-copy-info info))) (setf (info-ch new-info) (copy-ht (info-ch info)) (info-ref new-info) (copy-ht (info-ref info)) (info-ref-ccb new-info) (copy-ht (info-ref-ccb info)) (info-ref-clb new-info) (copy-ht (info-ref-clb info))) new-info)) ;; (defun copy-info (info) ;; (let ((new-info (old-copy-info info))) ;; (setf (info-ref new-info) (copy-ht (info-ref info)) ;; (info-ch new-info) (copy-ht (info-ch info)) ;; (info-blocks new-info) (copy-ht (info-blocks info)) ;; (info-tags new-info) (copy-ht (info-tags info))) ;; (when *make-fast-ref* ;; (setf (info-vref new-info) (copy-ht (info-vref info)) ;; (info-vref-ccb new-info) (copy-ht (info-vref-ccb info)) ;; (info-vref-clb new-info) (copy-ht (info-vref-clb info)))) ;; new-info)) ;; (defun copy-info (info) ;; (let ((new-info (old-copy-info info))) ;; (setf (info-ref new-info) (copy-ht (info-ref info)) ;; (info-ch new-info) (copy-ht (info-ch info)) ;; (info-blocks new-info) (copy-ht (info-blocks info)) ;; (info-tags new-info) (copy-ht (info-tags info)) ;; (info-vref new-info) (copy-ht (info-vref info)) ;; (info-vref-ccb new-info) (copy-ht (info-vref-ccb info)) ;; (info-vref-clb new-info) (copy-ht (info-vref-clb info)) ;; (info-bref new-info) (copy-ht (info-bref info)) ;; (info-bref-ccb new-info) (copy-ht (info-bref-ccb info)) ;; (info-bref-clb new-info) (copy-ht (info-bref-clb info)) ;; (info-tref new-info) (copy-ht (info-tref info)) ;; (info-tref-ccb new-info) (copy-ht (info-tref-ccb info)) ;; (info-tref-clb new-info) (copy-ht (info-tref-clb info)) ;; (info-fref new-info) (copy-ht (info-fref info)) ;; (info-fref-ccb new-info) (copy-ht (info-fref-ccb info)) ;; ; (info-fref-clb new-info) (copy-ht (info-fref-clb info)) ;; ) ;; new-info)) (defmacro push-ht (x ht) `(pushnew ,x ,ht :test 'eq)) (defmacro do-ht ((v ht) &rest body) `(dolist (,v ,ht) ,@body)) (defmacro in-ht (v ht) `(member ,v ,ht :test 'eq)) (defmacro adjustable-ht (ht) ht) (defmacro do-referred ((v info) &rest body) `(progn (do-ht (,v (info-ref-ccb ,info)) (when (var-p ,v) ,@body)) (do-ht (,v (info-ref-clb ,info)) (when (var-p ,v) ,@body)) (do-ht (,v (info-ref ,info)) (when (var-p ,v) ,@body)))) ;; (defmacro do-referred-cb ((v info) &rest body) ;; `(progn ;; (do-ht (,v (info-ref-ccb ,info)) (when (var-p ,v) ,@body)) ;; (do-ht (,v (info-ref-clb ,info)) (when (var-p ,v) ,@body)))) ;; (defmacro do-referred ((v info) &rest body) ;; `(do-ht (,v (info-ref ,info)) ,@body)) (defmacro do-changed ((v info) &rest body) `(do-ht (,v (info-ch ,info)) ,@body)) (defmacro is-referred (var info) `(or (in-ht ,var (info-ref-ccb ,info)) (in-ht ,var (info-ref-clb ,info)) (in-ht ,var (info-ref ,info)))) ;; (defmacro is-referred (var info) ;; `(in-ht ,var (info-ref ,info))) (defmacro is-changed (var info) `(in-ht ,var (info-ch ,info))) (defmacro push-referred (var info) `(push-ht ,var (info-ref ,info)));FIXME ;; (defmacro push-referred (var info) ;; `(push-ht ,var (info-ref ,info))) (defmacro push-changed (var info) `(push-ht ,var (info-ch ,info))) (defmacro changed-length (info) `(length (info-ch ,info))) ;; (defmacro referred-length (info) ;; `(length (info-ref ,info))) (defun imerge (x y list) (nunion x (intersection y list :test 'eq) :test 'eq)) (declaim (inline imerge)) (defun add-info (to-info from-info) ;; Allow nil from-info without error CM 20031030 (unless from-info (return-from add-info to-info)) (macrolet ((mrg (field) `(let* ((r (,field from-info))) (when r (setf (,field to-info) (imerge (,field to-info) r *vars*) (,field to-info) (imerge (,field to-info) r *blocks*) (,field to-info) (imerge (,field to-info) r *tags*) (,field to-info) (imerge (,field to-info) r *funs*)))))) (mrg info-ch) (mrg info-ref-ccb) (mrg info-ref-clb) (mrg info-ref)) (when (/= (info-sp-change from-info) 0) (setf (info-sp-change to-info) 1)) (setf (info-flags to-info) (logior (info-flags to-info) (info-flags from-info))) (setf (info-ref to-info) (nunion (info-ref to-info) (remove-if-not 'symbolp (info-ref from-info))));FIXME nunion asym (setf (info-ch-ccb to-info) (nunion (info-ch-ccb to-info) (info-ch-ccb from-info))) to-info) ;; (defun add-info (to-info from-info) ;; ;; Allow nil from-info without error CM 20031030 ;; (unless from-info (return-from add-info to-info)) ;; (macrolet ((mrg (field scrn) `(let* ((r (,field from-info))) (when r (setf (,field to-info) (imerge (,field to-info) r ,scrn))))) ;; (mrg1 (field) `(let* ((r (,field from-info))) ;; (when r ;; (setf (,field to-info) (imerge (,field to-info) r *vars*) ;; (,field to-info) (imerge (,field to-info) r *blocks*) ;; (,field to-info) (imerge (,field to-info) r *tags*) ;; (,field to-info) (imerge (,field to-info) r *funs*)))))) ;; (mrg info-ch *vars*) ;; (mrg1 info-ref-ccb) ;; (mrg1 info-ref-clb) ;; (mrg1 info-ref)) ;; (when (/= (info-sp-change from-info) 0) (setf (info-sp-change to-info) 1)) ;; (setf (info-flags to-info) (logior (info-flags to-info) (info-flags from-info))) ;; to-info) ;; (defun add-info (to-info from-info) ;; ;; Allow nil from-info without error CM 20031030 ;; (unless from-info (return-from add-info to-info)) ;; (macrolet ((mrg (field scrn) `(let* ((r (,field from-info))) (when r (setf (,field to-info) (imerge (,field to-info) r ,scrn))))) ;; (mrg1 (field) `(let* ((r (,field from-info))) ;; (when r ;; (setf (,field to-info) (imerge (,field to-info) r *vars*) ;; (,field to-info) (imerge (,field to-info) r *blocks*) ;; (,field to-info) (imerge (,field to-info) r *tags*) ;; (,field to-info) (imerge (,field to-info) r *funs*)))))) ;; (mrg info-ref *vars*) ;; (mrg info-ch *vars*) ;; (mrg info-blocks *blocks*) ;; (mrg info-tags *tags*) ;; (when *make-fast-ref* ;; (mrg1 info-vref-ccb) ;; (mrg1 info-vref-clb) ;; (mrg1 info-vref))) ;; (when (/= (info-sp-change from-info) 0) (setf (info-sp-change to-info) 1)) ;; (setf (info-flags to-info) (logior (info-flags to-info) (info-flags from-info))) ;; to-info) ;; (defun add-info (to-info from-info) ;; ;; Allow nil from-info without error CM 20031030 ;; (unless from-info (return-from add-info to-info)) ;; (macrolet ((mrg (field scrn) `(let* ((r (,field from-info))) (when r (setf (,field to-info) (imerge (,field to-info) r ,scrn)))))) ;; (mrg info-ref *vars*) ;; (mrg info-ch *vars*) ;; (mrg info-blocks *blocks*) ;; (mrg info-tags *tags*) ;; (mrg info-vref-ccb *vars*) ;; (mrg info-vref-clb *vars*) ;; (mrg info-vref *vars*) ;; (mrg info-bref-ccb *blocks*) ;; (mrg info-bref-clb *blocks*) ;; (mrg info-bref *blocks*) ;; (mrg info-tref-ccb *tags*) ;; (mrg info-tref-clb *tags*) ;; (mrg info-tref *tags*) ;; (mrg info-fref-ccb *funs*) ;; ; (mrg info-fref-clb *funs*) ;; (mrg info-fref *funs*)) ;; (when (/= (info-sp-change from-info) 0) (setf (info-sp-change to-info) 1)) ;; (setf (info-flags to-info) (logior (info-flags to-info) (info-flags from-info))) ;; to-info) ;; (setf (info-ref to-info) (imerge (info-ref to-info) (info-ref from-info) *vars*) ;; (info-ch to-info) (imerge (info-ch to-info) (info-ch from-info) *vars*) ;; (info-blocks to-info) (imerge (info-blocks to-info) (info-blocks from-info) *blocks*) ;; (info-tags to-info) (imerge (info-tags to-info) (info-tags from-info) *tags*) ;; (info-vref-ccb to-info) (imerge (info-vref-ccb to-info) (info-vref-ccb from-info) *vars*) ;; (info-vref-clb to-info) (imerge (info-vref-clb to-info) (info-vref-clb from-info) *vars*) ;; (info-vref to-info) (imerge (info-vref to-info) (info-vref from-info) *vars*) ;; (info-bref-ccb to-info) (imerge (info-bref-ccb to-info) (info-bref-ccb from-info) *blocks*) ;; (info-bref-clb to-info) (imerge (info-bref-clb to-info) (info-bref-clb from-info) *blocks*) ;; (info-bref to-info) (imerge (info-bref to-info) (info-bref from-info) *blocks*) ;; (info-tref-ccb to-info) (imerge (info-tref-ccb to-info) (info-tref-ccb from-info) *tags*) ;; (info-tref-clb to-info) (imerge (info-tref-clb to-info) (info-tref-clb from-info) *tags*) ;; (info-tref to-info) (imerge (info-tref to-info) (info-tref from-info) *tags*) ;; (info-fref-ccb to-info) (imerge (info-fref-ccb to-info) (info-fref-ccb from-info) *funs*) ;; ; (info-fref-clb to-info) (imerge (info-fref-clb to-info) (info-fref-clb from-info) *funs*) ;; (info-fref to-info) (imerge (info-fref to-info) (info-fref from-info) *funs*) ;; ) ;; (when (/= (info-sp-change from-info) 0) (setf (info-sp-change to-info) 1)) ;; (setf (info-flags to-info) (logior (info-flags to-info) (info-flags from-info))) ;; to-info) (defconstant +c1nil+ (list 'LOCATION (make-info :type (object-type nil)) nil)) (defmacro c1nil () `+c1nil+) (defconstant +c1t+ (list 'LOCATION (make-info :type (object-type t)) t)) (defmacro c1t () `+c1t+) (defun args-info-changed-vars (var forms) (if (member (var-kind var) +c-local-var-types+) (dolist (form forms) (when (is-changed var (cadr form)) (return-from args-info-changed-vars t))) (case (var-kind var) ((LEXICAL 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)) 0)) (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 args-info-referred-vars (var forms) (if (member (var-kind var) +c-local-var-types+) (dolist (form forms nil) (when (or (is-referred var (cadr form)) (is-rep-referred var (cadr form))) (return-from args-info-referred-vars t))) (case (var-kind var) ((LEXICAL REPLACED 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)) 0)) (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. (defun inc-inline-blocks() (cond ((consp *inline-blocks*) (incf (car *inline-blocks*))) (t (incf *inline-blocks*)))) ;; (defun loc-from-c2form (form type) ;; (case (car form) ;; (LOCATION (coerce-loc (caddr form) type)) ;; (VAR ;; (cond ((args-info-changed-vars (caaddr form) (cdr forms)) ;; (cond ((and (member (var-kind (caaddr form)) +c-local-var-types+) ;; (eq type (var-kind (caaddr form)))) ;; (let* ((cvar (cs-push type t))(*value-to-go* `(cvar ,cvar))) ;; (wt-nl "{" (rep-type type) "V" cvar "= V" ;; (var-loc (caaddr form)) ";") ;; (inc-inline-blocks) ;; (list 'cvar cvar 'inline-args))) ;; ((let* ((temp (wt-c-push type))(*value-to-go* temp)) ;; (wt-nl temp "= ") ;; (wt-var (caaddr form) (cadr (caddr form))) ;; (wt ";") ;; (coerce-loc temp type))))) ;; ((and (member (var-kind (caaddr form)) +c-local-var-types+) ;; (not (eq type (var-kind (caaddr form))))) ;; (let* ((temp (cs-push type))(*value-to-go* `(cvar ,temp))) ;; (wt-nl "V" temp " = " ;; (coerce-loc (cons 'var (caddr form)) type) ";") ;; (list 'cvar temp))) ;; ((coerce-loc (cons 'VAR (caddr form)) type)))) ;; (CALL-GLOBAL ;; (if (let ((fname (caddr form))) ;; (and (inline-possible fname) ;; (setq ii (get-inline-info fname (cadddr form) (info-type (cadr form)) (sixth 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) +c-local-var-types+) ;; (not (eq type (cadr ii))))) ;; (let* ((temp (cs-push type))(*value-to-go* `(cvar ,temp))) ;; (wt-nl "V" temp " = " (coerce-loc loc type) ";") ;; (list 'cvar temp))) ;; ((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 "= ") ;; (let ((*value-to-go* `(cvar ,cvar))) (wt-loc loc))) ;; (t (setq cvar (cs-push type t)) ;; (wt-nl "{" (rep-type type) "V" cvar "= ") ;; (let ((*value-to-go* `(cvar ,cvar))) ;; (funcall (or (cdr (assoc (promoted-c-type type) +wt-loc-alist+)) 'wt-loc) loc)) ;; (inc-inline-blocks))) ;; (wt ";") ;; (list 'cvar cvar 'inline-args))) ;; (t (coerce-loc loc type)))) ;; (let* ((temp (if *c-gc* (list 'cvar (cs-push)) (list 'vs (vs-push)))) ;; (*value-to-go* temp)) ;; (c2expr* form) ;; (coerce-loc temp type)))) ;; (ub (list 'gen-loc (caddr form) (loc-from-c2form (fourth form) type))) ;; (structure-ref(coerce-loc-structure-ref (cdr form) type)) ;; (SETQ ;; (let ((vref (caddr form)) ;; (form1 (cadddr form))) ;; (let ((*value-to-go* (cons 'var vref))) (c2expr* form1)) ;; (cond ((eq (car form1) 'LOCATION) ;; (coerce-loc (caddr form1) type)) ;; (t (loc-from-c2form (list 'VAR (cadr form) vref)) ;; (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)))))) ;; ((let ((temp ;; (cond ((not *c-gc*) (list 'vs (vs-push))) ;; ((eq type t) (list 'cvar (cs-push))) ;; ((list 'var ;; (make-var :type type :loc (cs-push type) ;; :kind (or (car (member (promoted-c-type type) +c-local-var-types+)) 'object)) ;; nil))))) ;; (let ((*value-to-go* temp)) ;; (c2expr* form) ;; (coerce-loc temp type)))))) (defun wt-push-loc (loc type &optional expr) (let* ((cv (cs-push type)) (*value-to-go* `(cvar ,cv))) (if expr (c2expr* loc) (wt-nl "V" cv "= " (coerce-loc loc type) ";")) (coerce-loc *value-to-go* type))) (defun lit-loc (tp inl args stores) (declare (ignore stores)) (let ((sig (list (mapcar (lambda (x) (info-type (cadr x))) args) tp))) (get-inline-loc (list (car sig) (cadr sig) (flags rfa) inl) args))) ;; (defun lit-loc (tp inl args) ;; (let* ((sig (list (mapcar (lambda (x) (info-type (cadr x))) args) tp))) ;; (get-inline-loc (list (car sig) (cadr sig) (flags rfa) inl) args))) (defun inline-args (forms types &optional fun &aux locs ii) (do ((forms forms (cdr forms)) (types types (cdr types))) ((endp forms) (nreverse locs)) (let* ((form (car forms)) (type (car types)) (type (adj-cnum-tp type (info-type (cadr form))))) (case (car form) (LOCATION (push (coerce-loc (caddr form) type) locs)) (VAR (cond ((args-info-changed-vars (caaddr form) (cdr forms)) (push (wt-push-loc (cons 'var (caddr form)) type) locs)) ((and (member (var-kind (caaddr form)) +c-local-var-types+) (not (type>= (var-kind (caaddr form)) type))) ; (not (eq type (var-kind (caaddr form))))) (push (wt-push-loc (cons 'var (caddr form)) type) locs)) ((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)) (sixth 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) +c-local-var-types+) (not (eq type (cadr ii))))) (push (wt-push-loc loc type) 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))))) (push (wt-push-loc loc type) locs)) ((push (coerce-loc loc type) locs)))) (push (wt-push-loc form type t) locs))) (lit (push (coerce-loc (apply 'lit-loc (cddr form)) type) locs)) (ub (push (list 'gen-loc (caddr form) (let* ((v (fourth form))(c (car v))) (ecase c (var (cons c (caddr v))) (lit (apply 'lit-loc (cddr v))) (location (caddr v))))) locs)) (structure-ref (push (coerce-loc-structure-ref (cdr form) type) locs)) (SETQ (let* ((vref (caddr form)) (form1 (cadddr form)) (v (car vref)) (vv (cons 'var vref)) (vt (if (or (eq t (var-ref v)) (consp (var-ref v)) (var-cb v) (eq (var-kind v) 'global)) vv *value-to-go*))) (cond ((eq vt vv) (let ((*value-to-go* vt)) (c2expr* form1)) (if (eq (car form1) 'LOCATION) (push (coerce-loc (caddr form1) type) locs) (setq forms (list* form (list 'VAR (cadr form) vref) (cdr forms)) types (list* type types)))) ((setq forms (list* form form1 (cdr forms)) types (list* type types))))));; want (setq types (list* type type (cdr types))) but type is first of types (otherwise (push (wt-push-loc form type t) locs)))))) ;; (defun inline-args (forms types &optional fun &aux locs ii) ;; (do ((forms forms (cdr forms)) ;; (types types (cdr types))) ;; ((endp forms) (nreverse locs)) ;; (let* ((form (car forms)) ;; (type (car types)) ;; (type (adj-cnum-tp type (info-type (cadr form))))) ;; (case (car form) ;; (LOCATION (push (coerce-loc (caddr form) type) locs)) ;; (VAR ;; (cond ((args-info-changed-vars (caaddr form) (cdr forms)) ;; (push (wt-push-loc (cons 'var (caddr form)) type) locs)) ;; ((and (member (var-kind (caaddr form)) +c-local-var-types+) ;; (not (type>= (var-kind (caaddr form)) type))) ;; ; (not (eq type (var-kind (caaddr form))))) ;; (push (wt-push-loc (cons 'var (caddr form)) type) locs)) ;; ((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)) (sixth 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) +c-local-var-types+) ;; (not (eq type (cadr ii))))) ;; (push (wt-push-loc loc type) 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))))) ;; (push (wt-push-loc loc type) locs)) ;; ((push (coerce-loc loc type) locs)))) ;; (push (wt-push-loc form type t) locs))) ;; (lit (push (coerce-loc (apply 'lit-loc (cddr form)) type) locs)) ;; (ub (push (list 'gen-loc (caddr form) ;; (let* ((v (fourth form))(c (car v))) ;; (ecase c ;; (var (cons c (caddr v))) ;; (lit (apply 'lit-loc (cddr v))) ;; (location (caddr v))))) locs)) ;; (structure-ref (push (coerce-loc-structure-ref (cdr form) type) locs)) ;; (SETQ ;; (let* ((vref (caddr form)) ;; (form1 (cadddr form)) ;; (v (car vref)) ;; (vv (cons 'var vref)) ;; (vt (if (or (eq t (var-ref v)) (consp (var-ref v)) (var-cb v) (eq (var-kind v) 'global)) vv *value-to-go*))) ;; (cond ((eq vt vv) ;; (let ((*value-to-go* vt)) (c2expr* form1)) ;; (if (eq (car form1) 'LOCATION) ;; (push (coerce-loc (caddr form1) type) locs) ;; (setq forms (list* form (list 'VAR (cadr form) vref) (cdr forms)) ;; types (list* type types)))) ;; ((setq forms (list* form form1 (cdr forms)) ;; types (list* type types))))));; want (setq types (list* type type (cdr types))) but type is first of types ;; (otherwise (push (wt-push-loc form type t) locs)))))) ;; (defun inline-args (forms types &optional fun &aux locs ii) ;; (do ((forms forms (cdr forms)) ;; (types types (cdr types))) ;; ((endp forms) (nreverse locs)) ;; (let* ((form (car forms)) ;; (type (car types)) ;; (type (adj-cnum-tp type (info-type (cadr form))))) ;; (case (car form) ;; (LOCATION (push (coerce-loc (caddr form) type) locs)) ;; (VAR ;; (cond ((args-info-changed-vars (caaddr form) (cdr forms)) ;; (push (wt-push-loc (cons 'var (caddr form)) type) locs)) ;; ((and (member (var-kind (caaddr form)) +c-local-var-types+) ;; (not (type>= (var-kind (caaddr form)) type))) ;; ; (not (eq type (var-kind (caaddr form))))) ;; (push (wt-push-loc (cons 'var (caddr form)) type) locs)) ;; ((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)) (sixth 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) +c-local-var-types+) ;; (not (eq type (cadr ii))))) ;; (push (wt-push-loc loc type) 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))))) ;; (push (wt-push-loc loc type) locs)) ;; ((push (coerce-loc loc type) locs)))) ;; (push (wt-push-loc form type t) locs))) ;; (ub (push (list 'gen-loc (caddr form) ;; (let* ((v (fourth form))(tv (third v))) ;; (if (eq (car v) 'var) (cons (car v) tv) tv))) locs)) ;; (structure-ref (push (coerce-loc-structure-ref (cdr form) type) locs)) ;; (SETQ ;; (let* ((vref (caddr form)) ;; (form1 (cadddr form)) ;; (v (car vref)) ;; (vv (cons 'var vref)) ;; (vt (if (or (eq t (var-ref v)) (consp (var-ref v)) (var-cb v) (eq (var-kind v) 'global)) vv *value-to-go*))) ;; (cond ((eq vt vv) ;; (let ((*value-to-go* vt)) (c2expr* form1)) ;; (if (eq (car form1) 'LOCATION) ;; (push (coerce-loc (caddr form1) type) locs) ;; (setq forms (list* form (list 'VAR (cadr form) vref) (cdr forms)) ;; types (list* type types)))) ;; ((setq forms (list* form form1 (cdr forms)) ;; types (list* type types))))));; want (setq types (list* type type (cdr types))) but type is first of types ;; (otherwise (push (wt-push-loc form type t) locs)))))) ;; (defun inline-args (forms types &optional fun &aux locs ii) ;; (do ((forms forms (cdr forms)) ;; (types types (cdr types))) ;; ((endp forms) (nreverse locs)) ;; (let* ((form (car forms)) ;; (type (car types)) ;; (type (adj-cnum-tp type (info-type (cadr form))))) ;; (case (car form) ;; (LOCATION (push (coerce-loc (caddr form) type) locs)) ;; (VAR ;; (cond ((args-info-changed-vars (caaddr form) (cdr forms)) ;; (push (wt-push-loc (cons 'var (caddr form)) type) locs)) ;; ((and (member (var-kind (caaddr form)) +c-local-var-types+) ;; (not (eq type (var-kind (caaddr form))))) ;; (push (wt-push-loc (cons 'var (caddr form)) type) locs)) ;; ((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)) (sixth 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) +c-local-var-types+) ;; (not (eq type (cadr ii))))) ;; (push (wt-push-loc loc type) 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))))) ;; (push (wt-push-loc loc type) locs)) ;; ((push (coerce-loc loc type) locs)))) ;; (push (wt-push-loc form type t) locs))) ;; (ub (push (list 'gen-loc (caddr form) ;; (let* ((v (fourth form))(tv (third v))) ;; (if (eq (car v) 'var) (cons (car v) tv) tv))) locs)) ;; (structure-ref (push (coerce-loc-structure-ref (cdr form) type) locs)) ;; (SETQ ;; (let* ((vref (caddr form)) ;; (form1 (cadddr form)) ;; (v (car vref)) ;; (vv (cons 'var vref)) ;; (vt (if (or (eq t (var-ref v)) (consp (var-ref v)) (var-cb v) (eq (var-kind v) 'global)) vv *value-to-go*))) ;; (cond ((eq vt vv) ;; (let ((*value-to-go* vt)) (c2expr* form1)) ;; (if (eq (car form1) 'LOCATION) ;; (push (coerce-loc (caddr form1) type) locs) ;; (setq forms (list* form (list 'VAR (cadr form) vref) (cdr forms)) ;; types (list* type types)))) ;; ((setq forms (list* form form1 (cdr forms)) ;; types (list* type types))))));; want (setq types (list* type type (cdr types))) but type is first of types ;; (otherwise (push (wt-push-loc form type t) locs)))))) ;; (defun inline-args (forms types &optional fun &aux locs ii) ;; (do ((forms forms (cdr forms)) ;; (types types (cdr types))) ;; ((endp forms) (reverse locs)) ;; (let ((form (car forms)) ;; (type (car types))) ;; (let ((type (adj-cnum-tp type (info-type (cadr form))))) ;; (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)) +c-local-var-types+) ;; (eq type (var-kind (caaddr form)))) ;; (let* ((cvar (cs-push type t))(*value-to-go* `(cvar ,cvar))) ;; (wt-nl "{" (rep-type type) "V" cvar "= V" ;; (var-loc (caaddr form)) ";") ;; (push (list 'cvar cvar 'inline-args) locs) ;; (inc-inline-blocks))) ;; ((let* ((temp (wt-c-push type))(*value-to-go* temp)) ;; (wt-nl temp "= ") ;; (wt-var (caaddr form) (cadr (caddr form))) ;; (wt ";") ;; (push (coerce-loc temp type) locs))))) ;; ((and (member (var-kind (caaddr form)) +c-local-var-types+) ;; (not (eq type (var-kind (caaddr form))))) ;; (let* ((temp (cs-push type))(*value-to-go* `(cvar ,temp))) ;; (wt-nl "V" temp " = " ;; (coerce-loc (cons 'var (caddr form)) type) ";") ;; (push (list 'cvar temp) locs))) ;; ((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)) (sixth 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) +c-local-var-types+) ;; (not (eq type (cadr ii))))) ;; (let* ((temp (cs-push type))(*value-to-go* `(cvar ,temp))) ;; (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 "= ") ;; (let ((*value-to-go* `(cvar ,cvar))) (wt-loc loc))) ;; (t (setq cvar (cs-push type t)) ;; (wt-nl "{" (rep-type type) "V" cvar "= ") ;; (let ((*value-to-go* `(cvar ,cvar))) ;; (funcall (or (cdr (assoc (promoted-c-type type) +wt-loc-alist+)) '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)))) ;; ; (ub (push (coerce-loc (cons 'var (third (fourth form))) (get (caddr form) 'lisp-type)) locs)) ;; (ub (push (list 'gen-loc (caddr form) (let* ((v (fourth form))(tv (third v))) (if (eq (car v) 'var) (cons (car v) tv) tv))) 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 ((not *c-gc*) (list 'vs (vs-push))) ;; ((eq type t) (list 'cvar (cs-push))) ;; ((list 'var ;; (make-var :type type :loc (cs-push type) ;; :kind (or (car (member (promoted-c-type type) +c-local-var-types+)) 'object)) ;; nil))))) ;; (let ((*value-to-go* temp)) ;; (c2expr* form) ;; (push (coerce-loc temp type) locs))))))))) (defun coerce-loc (loc type) (let ((tmp (car (rassoc (promoted-c-type type) *box-alist*)))) (if tmp (list 'gen-loc tmp loc) (let ((tl (cdr (assoc (promoted-c-type type) +coersion-alist+)))) (if tl (list tl loc) loc))))) ;; (defun coerce-loc (loc type) ;; (when (eq 'var (when (listp loc) (car loc))) (setf (var-type (cadr loc)) type));FIXME cmp-aref ;; (let ((tmp (car (rassoc (promoted-c-type type) *box-alist*)))) ;; (if tmp (list 'gen-loc tmp loc) ;; (let ((tl (cdr (assoc (promoted-c-type type) +coersion-alist+)))) ;; (if tl (list tl loc) 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 (reverse locs1))) (declare (fixnum n)) (if (member n saves) (let* ((loc (car l)) (loc1 loc) (coersion (and (consp loc) (cdr (rassoc (car loc) +coersion-alist+)))) (loc (if coersion (cadr loc) loc))); remove coersion (cond ((and (consp loc) (rassoc (car loc) +inline-types-alist+) (or (member (car loc) '(inline inline-cond)) (flag-p (cadr loc) allocates-new-storage) (flag-p (cadr loc) side-effect-p))) (wt-nl "{") (inc-inline-blocks) ;;FIXME -- make sure not losing specificity in coersion (let* ((ck (or (car (rassoc coersion +coersion-alist+)) 'object)) (cvar (cs-push ck t))) (push (list 'CVAR cvar) locs1) (unless ck (baboon)) (wt (rep-type ck) "V" cvar "= ") (funcall (cdr (assoc ck +wt-loc-alist+)) loc)) (wt ";")) (t (push loc1 locs1)))) (push (car l) locs1))))) (let ((others (and (stringp fun) (not (single-type-p (cadr ii))) (not (type>= (cadr ii) '*)) (mapcar 'inline-type (cddadr ii))))) (list (inline-type (cadr ii)) (caddr ii) (if others (cons fun others) fun) locs )) ) (defun inline-type (type) (or (cdr (assoc (promoted-c-type type) +inline-types-alist+)) 'inline)) (defun get-plist-inline (fname args return-type apnarg inline-list) (reduce (lambda (y x) (or y (inline-type-matches fname x args return-type apnarg))) inline-list :initial-value nil)) (defun get-inline-info (fname args return-type &optional apnarg &aux (sui (if *safe-compile* 'inline-safe 'inline-unsafe))) (setq args (mapcar (lambda (form) (info-type (cadr form))) args)) (cond ((get-plist-inline fname args return-type apnarg (get fname sui))) ((get-plist-inline fname args return-type apnarg (get fname 'inline-always))) ((cdr (add-fast-link fname (length args) apnarg))))) ;; (defun get-inline-info (fname args return-type &optional apnarg ;; &aux (sui (if *safe-compile* 'inline-safe 'inline-unsafe))) ;; (setq args (mapcar (lambda (form) (info-type (cadr form))) args)) ;; (cond ((get-plist-inline fname args return-type apnarg (get fname sui))) ;; ((get-plist-inline fname args return-type apnarg (get fname 'inline-always))) ;; ((cdr (add-fast-link fname apnarg))))) (defun adj-cnum-tp (tp ref) (if (and (type>= #tcnum tp) (not (type>= #tcnum (promoted-c-type tp)))) (let ((pr (promoted-c-type ref))) (when (and (type>= #tcnum pr) (type>= tp ref)) ref)) tp)) (defun mv-cast (arg-type type);FIXME (cond ((single-type-p type) arg-type) ((single-type-p arg-type) (list* (car type) (coerce-to-one-value arg-type) (make-list (length (cddr type))))) ((append arg-type (make-list (max 0 (- (length type) (length arg-type)))))))) (defun inline-type-matches (fname inline-info arg-types return-type &optional apnarg &aux rts (flags (third inline-info))) (declare (ignore fname)) (fix-opt inline-info) (when (let ((x (flag-p flags aa))) (if apnarg x (not x))) (when (flag-p flags itf) (let ((restp (apply (car inline-info) arg-types))) (return-from inline-type-matches (when restp `(,(car restp) ,(cadr restp) ,@(cddr inline-info)))))) (let* ((t1 (mapcar (lambda (x) (or x #tnull)) (cons return-type arg-types))) (t2 (cons (cadr inline-info) (car inline-info))) (last #tt) (ret t)) (when (dolist (arg-type t1 (or (equal t2 '(*)) (endp t2))) (when (endp t2) (return nil)) (let* ((s (unless ret (and (eq (car t2) '*) (not (cdr t2))))) (lst (if (unless (type<= last #topaque) s) #tt last));FIXME (cmp-norm-tp 'opaque) (type (if s lst (pop t2))) (arg-type (if ret (mv-cast arg-type type) (coerce-to-one-value arg-type)));FIXME (tp (adj-cnum-tp type arg-type))) (unless (type>= tp arg-type) (return nil)) (setq last type ret nil) (push tp rts))) (setq rts (nreverse rts)) (cons (cdr rts) (cons (car rts) (cddr inline-info))))))) (defun need-to-protect (forms types &aux ii) (do ((forms forms (cdr forms)) (types types (cdr types))) ((endp forms) nil) (let ((form (car forms))) (case (car form) (LOCATION) (VAR (when (or (args-info-changed-vars (caaddr form) (cdr forms)) (when (member (var-kind (caaddr form)) +c-local-var-types+) (not (type>= (var-kind (caaddr form)) (car types))))) (return t))) (CALL-GLOBAL (let ((fname (caddr form))) (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) +c-local-var-types+) (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 (&optional type) (cond (*c-gc* (inc-inline-blocks) (let ((tem (cs-push type t))) (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-char 'wt-inline-char 'wt-loc) (si:putprop 'inline-long-float 'wt-inline-long-float 'wt-loc) (si:putprop 'inline-short-float 'wt-inline-short-float 'wt-loc) (si:putprop 'inline-dcomplex 'wt-inline-dcomplex 'wt-loc) (si:putprop 'inline-fcomplex 'wt-inline-fcomplex 'wt-loc) (defun wt-inline-loc (fun locs &aux (i 0) (max 0) (maxv 0)) (declare (fixnum i max maxv)) (let* ((others (and (consp fun) (stringp (car fun)) (cdr fun))) (fun (if (and (consp fun) (stringp (car fun))) (car fun) fun))) (cond ((stringp fun) (when (char= (char fun 0) #\@) (setq i 1) (do () ((char= (char fun i) #\;) (incf i)) (incf i))) (do ((size (length fun))) ((>= i size)) (declare (fixnum size)) (let ((char (char fun i))) (declare (character char)) (cond ((char= char #\#) (let ((ch (char fun (the fixnum (1+ i)))) (n 0)) (cond ((eql ch #\n) (wt (length locs))) ((or (eql ch #\*) (eql ch #\?)) (let* ((f (char= (char fun (1- i)) #\()) (e (char= (char fun (+ 2 i)) #\))) (locs (nthcdr 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)))) ((eql ch #\v) (wt-fixnum-loc (cond ((eq *value-to-go* 'top) (list 'vs-address "base" (cdr (vs-push)))) ((and (not (eq *value-to-go* 'return)) (not (rassoc *value-to-go* +return-alist+)) (not *values-to-go*)) (list 'fixnum-value nil 0)) (*mv-var* (cond ((>= (var-known-init *mv-var*) 0) (setq *values-to-go* (nthcdr (var-known-init *mv-var*) *values-to-go*))) (t (unless (boundp '*extend-vs-top*) (baboon)) (setq *extend-vs-top* t *values-to-go* nil))) (list 'var *mv-var* nil)) ((list 'vs-address "base" (cdr (vs-push))))))) ((setq n (digit-char-p ch)) (let* ((ii (+ i 2)) (m (when (> (length fun) ii) (digit-char-p (setq ch (char fun ii)))))) (when m (setq n (+ (* n 10) m) i (1+ i))) (setq max (max max (1+ n))) (let ((*values-to-go* nil)) (wt-loc (nth n locs))))) ((wt ch)))) (incf i 2)) ((char= char #\@);FIXME better error checking (let* ((n (- (char-code (char fun (1+ i))) #.(char-code #\1))) (n (if (digit-char-p (char fun (+ i 2))) (+ (* 10 (1+ n)) (- (char-code (char fun (1+ (incf i)))) #.(char-code #\1))) n)) (pos (position #\@ fun :start (+ i 2))) (new-fun (subseq fun (+ i 2) pos)) (*value-to-go* (or (nth n *values-to-go*) (and (member *value-to-go* '(top return)) (list 'vs (vs-push))) 'trash)) (*values-to-go* nil)) (set-loc (list (nth n others) (flags) new-fun locs)) (setf maxv (max maxv (1+ n))) (setf i (1+ pos)))) (t (princ char *compiler-output1*) (incf i))))) (setq *values-to-go* (nthcdr maxv *values-to-go*))) ((values (apply fun locs)))))) (defun wt-inline (flags fun locs) (declare (ignore flags)) (wt-inline-loc fun locs)) (defun wt-inline-cond (flags fun locs) (declare (ignore flags)) (wt "(") (wt-inline-loc fun locs) (wt "?Ct:Cnil") (wt ")")) (defun wt-inline-fixnum (flags fun locs) (declare (ignore flags)) (when (zerop *space*) (wt "CMP")) (wt "make_fixnum(") (wt-inline-loc fun locs) (wt ")")) (defun wt-inline-integer (flags fun locs) (declare (ignore flags)) (wt "make_integer(") (wt-inline-loc fun locs) (wt ")")) (defun wt-inline-character (flags fun locs) (declare (ignore flags)) (wt "code_char(") (wt-inline-loc fun locs) (wt ")")) (defun wt-inline-char (flags fun locs) (declare (ignore flags)) (wt "make_fixnum(") (wt-inline-loc fun locs) (wt ")")) (defun wt-inline-long-float (flags fun locs) (declare (ignore flags)) (wt "make_longfloat(") (wt-inline-loc fun locs) (wt ")")) (defun wt-inline-short-float (flags fun locs) (declare (ignore flags)) (wt "make_shortfloat(") (wt-inline-loc fun locs) (wt ")")) (defun wt-inline-fcomplex (flags fun locs) (declare (ignore flags)) (wt "make_fcomplex(") (wt-inline-loc fun locs) (wt ")")) (defun wt-inline-dcomplex (flags fun locs) (declare (ignore flags)) (wt "make_dcomplex(") (wt-inline-loc fun locs) (wt ")")) ;;; Borrowed from CMPOPT.LSP (defmacro can-allocate-on-stack () `(and (consp *value-to-go*) (eq (car *value-to-go*) 'var) (var-dynamic (second *value-to-go*)) (not (var-cb (second *value-to-go*))))) (defun wt-stack-list* (x l &optional n (st "Cnil") (lst "Cnil")) (let ((z (or n (length x)))) (when n (wt-nl "({ufixnum _z=" z ";!_z ? Cnil :")) (wt-nl "({object _b=OBJ_ALIGNED_STACK_ALLOC(" (if n "_z" z) "*sizeof(struct cons));") (wt-nl "register struct cons *_p=(void *)_b;") (cond (n (wt-nl "struct cons *_e=_p+(_z-1);") (wt-nl "for (;_p<_e;_p++) {_p->c_car=" st ";_p->c_cdr=(object)(_p+1);}") (wt-nl "_p->c_car=" lst ";_p->c_cdr=Cnil;_b;});})")) ((dolist (x x (wt-nl "_p[-1].c_cdr=" l ";_b;})")) (wt-nl "_p->c_car=" x ";_p->c_cdr=(object)(_p+1);_p++;")))))) (defun list-inline (&rest x &aux (*values-to-go* nil)) (cond ((can-allocate-on-stack) (wt-stack-list* x nil)) ((endp (cdr x)) (wt "make_cons(" (car x) ",Cnil)")) (t (wt "list(" (length x)) (dolist (loc x (wt #\))) (wt #\, loc))))) (defun list*-inline (&rest x &aux (*values-to-go* nil)) (if (can-allocate-on-stack) (wt-stack-list* (butlast x) (car (last 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 #\)))))) (defun make-list-inline (n &aux (*values-to-go* nil)) (if (can-allocate-on-stack) (wt-stack-list* nil nil n) (wt "make_list(" n ")"))) (defun cons-inline (x y &aux (*values-to-go* nil)) (if (can-allocate-on-stack) (wt-stack-list* (list x) y) (wt "make_cons(" x "," y ")"))) (defun c-cast (aet) (or (cdr (assoc aet +c-type-string-alist+)) (baboon))) (defun default-init (type) (let ((type (promoted-c-type type))) (when (member type +c-local-var-types+) (cmpwarn "The default value of NIL is not ~S." type))) (c1nil)) gcl27-2.7.0/cmpnew/gcl_cmplabel.lsp000077500000000000000000000226621454061450500170720ustar00rootroot00000000000000;;; 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) ";")(wt-nl))) (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-frames-bds (frames bds-cvar bds-bind) (dotimes (i frames) (wt-nl "frs_pop();")) (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 (frames 0)) (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 (rassoc *value-to-go* +return-alist+)) (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*) (unless (and (consp *value-to-go*) (or (eq (car *value-to-go*) 'jump-true) (eq (car *value-to-go*) 'jump-false))) (set-loc loc)) (unwind-frames-bds frames bds-cvar bds-bind) (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 (rassoc *value-to-go* +return-alist+)) (not (eq *value-to-go* 'top))) (wt-nl "sup=V" (cdr ue) ";") (wt-nl) (reset-top))) ((setq jump-p t)))) ((numberp ue) (setq bds-cvar ue bds-bind 0)) ((eq ue 'bds-bind) (incf bds-bind)) ((eq ue 'return) (unless (eq *exit* ue) (wfs-error)) (set-loc loc) (unwind-frames-bds frames bds-cvar bds-bind) (wt-nl "return;") (return)) ((eq ue 'frame) (incf frames)) ((eq ue 'tail-recursion-mark)) ((eq ue 'jump) (setq jump-p t)) ((setq type.wt (assoc (car (rassoc ue +return-alist+)) +wt-loc-alist+)) (unless (eq *exit* ue) (wfs-error)) (cond (*mv-var* (let* ((nv (cond ((and (consp fname) (eq (car fname) 'values)) (1- (cdr fname))) ((or (not fname) (eq fname 'single-value)) 0) ((abs (vald (get-return-type fname)))))) (nv (if (= nv (- multiple-values-limit 2)) 0 nv)) (fv (cs-push (car type.wt) t)) (lbs (mapcar (lambda (x) (declare (ignore x)) (cs-push t t)) (make-list (max 0 nv)))) (*value-to-go* (append (mapcar (lambda (x) (list 'cvar x)) (cons fv lbs)) '(trash)))) (wt-nl "{" (rep-type (car type.wt)) "V" fv ";") (cond (lbs (wt-nl "if (V" (var-loc *mv-var*) ") {") (let ((i -1)) (mapc (lambda (x) (wt-nl "#define V" x " ((object *)V" (var-loc *mv-var*) ")[" (incf i) "]")) lbs)) (set-loc loc) (mapc (lambda (x) (wt-nl "#undef V" x)) lbs) (wt-nl "} else {") (let ((*value-to-go* (list 'cvar fv))) (set-loc loc)) (wt-nl "}")) ((set-loc loc))) (when (or (eq loc 'fun-val) ;FIXME this can lead to a value stack leak on vs_top, e.g. typep with local mvfun tpi (and (consp loc) (rassoc (car loc) +inline-types-alist+) (flag-p (cadr loc) sets-vs-top))) (setq nv -2)) (unwind-frames-bds frames bds-cvar bds-bind) (wt-nl "VMRV" *reservation-cmacro* "(V" fv "," nv ");}"))) ((let ((cvar (cs-push (car type.wt) t))) (wt-nl "{" (rep-type (car type.wt)) "V" cvar " = ") (funcall (cdr type.wt) loc) (wt ";") (unwind-frames-bds frames bds-cvar bds-bind) (wt-nl "VMR" *reservation-cmacro* "(V" cvar ");}")))) (return)) ((baboon))))) (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)) ((or (eq ue 'return) (rassoc ue +return-alist+)) (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))))) gcl27-2.7.0/cmpnew/gcl_cmplam.lsp000077500000000000000000000747671454061450500166010ustar00rootroot00000000000000;;; 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))) (defun wfs-error () (error "This error is not supposed to occur: Contact Schelter ~ ~%wfs@math.utexas.edu")) (defun decls-from-procls (ll procls body) (cond ((or (null procls) (eq (car procls) '*) (null ll) (member (car ll) '(&whole &optional &rest &key &environment))) nil) ((eq (car procls) t) (decls-from-procls (cdr ll) (cdr procls) body)) (t (cons (list (car procls) (or (if (atom (car ll)) (car ll) (caar ll)))) (decls-from-procls (cdr ll) (cdr procls) body))))) (defun c1lambda-expr (args &aux (regs (pop args)) requireds tv doc body ss is ts other-decls (ovars *vars*) (*vars* *vars*) narg (info (make-info)) ctps) (multiple-value-setq (body ss ts is other-decls doc ctps) (c1body args t));FIXME parse-body-header (mapc (lambda (x &aux (y (c1make-var x ss is ts))) (setf (var-mt y) nil) (push-var y nil) (push y requireds)) regs) (when (member +nargs+ ts :key 'car) (setq narg (list (c1make-var +nargs+ ss is ts)))) (setq tv (append narg requireds)) (c1add-globals ss) (check-vdecl (mapcar 'var-name tv) ts is) (setq body (c1decl-body other-decls body)) (ref-vars body requireds) (dolist (var requireds) (check-vref var)) (dolist (v requireds) (when (var-p v) (unless (type>= (var-type v) (var-mt v)) (setf (var-type v) (var-mt v)))));FIXME? (let ((*vars* ovars)) (add-info info (cadr body))) (cond (*compiler-new-safety* (mapc (lambda (x) (setf (var-type x) #tt)) requireds) (let ((i (cadr body))) (setf (info-type i) (if (single-type-p (info-type i)) #tt #t*)))) ((mapc (lambda (l) (setf (var-type l) (type-and (var-type l) (nil-to-t (cdr (assoc (var-name l) ctps)))))) tv)));FIXME? `(lambda ,info ,(list (nreverse requireds) narg) ,doc ,body)) ;; (defun c1lambda-expr (args &aux (regs (pop args)) requireds tv ;; doc body ss is ts other-decls (ovars *vars*) ;; (*vars* *vars*) narg (info (make-info)) ctps) ;; (multiple-value-setq (body ss ts is other-decls doc ctps) (c1body args t));FIXME parse-body-header ;; (mapc (lambda (x &aux (y (c1make-var x ss is ts))) (push-var y nil) (push y requireds)) regs) ;; (when (member +nargs+ ts :key 'car) ;; (setq narg (list (c1make-var +nargs+ ss is ts)))) ;; (setq tv (append narg requireds)) ;; (c1add-globals ss) ;; (check-vdecl (mapcar 'var-name tv) ts is) ;; (setq body (c1decl-body other-decls body)) ;; (ref-vars body requireds) ;; (dolist (var requireds) (check-vref var)) ;; (dolist (v requireds) ;; (when (var-p v) ;; (setf (var-type v) (var-mt v))));FIXME? ;; (let ((*vars* ovars)) (add-info info (cadr body))) ;; (cond (*compiler-new-safety* ;; (mapc (lambda (x) (setf (var-type x) #tt)) requireds) ;; (let ((i (cadr body))) ;; (setf (info-type i) (if (single-type-p (info-type i)) #tt #t*)))) ;; ((mapc (lambda (l) (setf (var-type l) (type-and (var-type l) (nil-to-t (cdr (assoc (var-name l) ctps)))))) tv)));FIXME? ;; `(lambda ,info ,(list (nreverse requireds) narg) ,doc ,body)) ;; (defun c1lambda-expr (args &aux (regs (pop args)) requireds tv ;; doc body ss is ts other-decls (ovars *vars*) ;; (*vars* *vars*) narg (info (make-info)) ctps) ;; (multiple-value-setq (body ss ts is other-decls doc ctps) (c1body args t));FIXME parse-body-header ;; (mapc (lambda (x &aux (y (c1make-var x ss is ts))) (push-var y nil) (push y requireds)) regs) ;; (when (member +nargs+ ts :key 'car) ;; (setq narg (list (c1make-var +nargs+ ss is ts)))) ;; (setq tv (append narg requireds)) ;; (c1add-globals ss) ;; (check-vdecl (mapcar 'var-name tv) ts is) ;; (setq body (c1decl-body other-decls body)) ;; (ref-vars body requireds) ;; (dolist (var requireds) (check-vref var)) ;; (dolist (v requireds) ;; (when (var-p v) ;; (setf (var-type v) (var-mt v))));FIXME? ;; (let ((*vars* ovars)) (add-info info (cadr body))) ;; (unless *compiler-new-safety* ;; (dolist (l tv) ;; (setf (var-type l) (type-and (var-type l) (nil-to-t (cdr (assoc (var-name l) ctps)))))));FIXME? ;; `(lambda ,info ,(list (nreverse requireds) narg) ,doc ,body)) ;; (defun c1lambda-expr (args &aux (regs (pop args)) requireds tv ;; doc body ss is ts other-decls (ovars *vars*) ;; (*vars* *vars*) narg (info (make-info)) ctps) ;; (multiple-value-setq (body ss ts is other-decls doc ctps) (c1body args t));FIXME parse-body-header ;; (mapc (lambda (x &aux (y (c1make-var x ss is ts))) (push-var y nil) (push y requireds)) regs) ;; (when (member +nargs+ ts :key 'car) ;; (setq narg (list (c1make-var +nargs+ ss is ts)))) ;; (setq tv (append narg requireds)) ;; (c1add-globals ss) ;; (check-vdecl (mapcar 'var-name tv) ts is) ;; (setq body (c1decl-body other-decls body)) ;; (ref-vars body requireds) ;; (dolist (var requireds) (check-vref var)) ;; (dolist (v requireds) ;; (when (var-p v) ;; (setf (var-type v) (var-mt v))));FIXME? ;; (let ((*vars* ovars)) (add-info info (cadr body))) ;; (dolist (l tv) ;; (setf (var-type l) (type-and (var-type l) (nil-to-t (cdr (assoc (var-name l) ctps))))));FIXME? ;; `(lambda ,info ,(list (nreverse requireds) narg) ,doc ,body)) ;; (defun c1lambda-expr (args &aux (regs (pop args)) requireds tv ;; doc body ss is ts other-decls (ovars *vars*) ;; (*vars* *vars*) narg (info (make-info)) ctps) ;; (multiple-value-setq (body ss ts is other-decls doc ctps) (c1body args t));FIXME parse-body-header ;; (mapc (lambda (x &aux (y (c1make-var x ss is ts))) (push y *vars*) (push y requireds)) regs) ;; (when (member +nargs+ ts :key 'car) ;; (setq narg (list (c1make-var +nargs+ ss is ts)))) ;; (setq tv (append narg requireds)) ;; (c1add-globals ss) ;; (check-vdecl (mapcar 'var-name tv) ts is) ;; (setq body (c1decl-body other-decls body)) ;; (ref-vars body requireds) ;; (dolist (var requireds) (check-vref var)) ;; (dolist (v requireds) ;; (when (var-p v) ;; (setf (var-type v) (var-mt v))));FIXME? ;; (let ((*vars* ovars)) (add-info info (cadr body))) ;; (dolist (l tv) ;; (setf (var-type l) (type-and (var-type l) (nil-to-t (cdr (assoc (var-name l) ctps))))));FIXME? ;; `(lambda ,info ,(list (nreverse requireds) narg) ,doc ,body)) ;; (defun c1lambda-expr (args &aux (regs (pop args)) requireds tv ;; doc body ss is ts other-decls ;; (*vars* *vars*) narg (info (make-info)) ctps) ;; (multiple-value-setq (body ss ts is other-decls doc ctps) (c1body args t));FIXME parse-body-header ;; (mapc (lambda (x &aux (y (c1make-var x ss is ts))) (push y *vars*) (push y requireds)) regs) ;; (when (member +nargs+ ts :key 'car) ;; (setq narg (list (c1make-var +nargs+ ss is ts)))) ;; (setq tv (append narg requireds)) ;; (c1add-globals ss) ;; (check-vdecl (mapcar 'var-name tv) ts is) ;; (setq body (c1decl-body other-decls body)) ;; (ref-vars body requireds) ;; (dolist (var requireds) (check-vref var)) ;; (dolist (v requireds) ;; (when (var-p v) ;; (setf (var-type v) (var-mt v))));FIXME? ;; (add-info info (cadr body)) ;; (dolist (l tv) ;; (setf (var-type l) (type-and (var-type l) (nil-to-t (cdr (assoc (var-name l) ctps))))));FIXME? ;; `(lambda ,info ,(list (nreverse requireds) narg) ,doc ,body)) ;; (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*) ctps) ;; (cmpck (endp lambda-expr) ;; "The lambda expression ~s is illegal." (cons 'lambda lambda-expr)) ;; ;;FIXME -- this is backwards, as the proclamations should be ;; ;;generated from the declarations. What we need here and in the let ;; ;;code is reverse type propagation. CM 20050106 ;; ;; (let ((decls (decls-from-procls ;; ;; (car lambda-expr) ;; ;; (and block-it (get-arg-types block-name)) ;; ;; (cdr lambda-expr)))) ;; ;; (when decls ;; ;; (cmpnote "~S function args declared: ~S~%" block-name decls) ;; ;; (setq lambda-expr (cons (car lambda-expr) (cons (cons 'declare decls) (cdr lambda-expr)))))) ;; (multiple-value-setq (body ss ts is other-decls doc ctps) ;; (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*)))) ;; (set-var-init-type (car aux-vars) (info-type (second (car aux-inits)))) ;; (go Laux1) ;; ) ;; ) ;; (setq requireds (reverse requireds) ;; optionals (reverse optionals) ;; keywords (reverse keywords) ;; aux-vars (reverse aux-vars) ;; aux-inits (reverse aux-inits)) ;; (check-vdecl vnames ts is) ;; (setq body (c1decl-body other-decls body)) ;; (ref-vars body (append requireds optionals keywords aux-vars));FIXME aux? ;; (dolist (l (list requireds optionals keywords aux-vars)) ;; (dolist (v l) ;; (when (var-p v) ;; (setf (var-type v) (var-mt v))))) ;; (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)) ;; (setf (info-type aux-info) (info-type (cadr body))) ;; (setq body (list 'let* aux-info aux-vars aux-inits body)) ;; (or (eql setjmps *setjmps*) (setf (info-volatile aux-info) 1))) ;; ;;FIXME -- is above for aux needed too? ;; (when (or optionals keywords) ;; (or (eql setjmps *setjmps*) (setf (info-volatile info) 1))) ;; (setq optionals (list (is-narg-le lambda-expr)));FIXME ;; (setq lambda-list ;; (list requireds optionals rest key-flag keywords allow-other-keys)) ;; (dolist (l requireds) ;; (setf (var-type l) (type-and (var-type l) (nil-to-t (cdr (assoc (var-name l) ctps))))));(unboxed-type (cdr (assoc (var-name l) ctps))) ;; (and *record-call-info* (record-arg-info lambda-list)) ;; `(lambda ,info ,lambda-list ,doc ,body)) ;; (defun c1lambda-expr (args ;; &optional (block-name nil block-it) ;; &aux (regs (pop args)) requireds ;; lambda-list doc vl spec body ss is ts ;; other-decls vnames ;; (*vars* *vars*) ;; (info (make-info)) ctps) ;; (multiple-value-setq (body ss ts is other-decls doc ctps) (c1body args t)) ;; (mapc (lambda (x &aux (y (c1make-var x ss is ts))) (push y *vars*) (push y requireds)) regs) ;; (c1add-globals ss) ;; (check-vdecl requireds ts is) ;; (setq body (c1decl-body other-decls body)) ;; (ref-vars body requireds) ;; (dolist (v requireds) ;; (when (var-p v) ;; (setf (var-type v) (var-mt v)))) ;; (add-info info (cadr body)) ;; (dolist (var requireds) (check-vref var)) ;; (let* ((narg (is-narg-le args))) ;; (when narg (print (list 'narg block-name))) ;; (setq lambda-list (list (nreverse requireds) (when narg (list +nargs+))))) ;; (dolist (l requireds) ;; (setf (var-type l) (type-and (var-type l) (nil-to-t (cdr (assoc (var-name l) ctps))))));(unboxed-type (cdr (assoc (var-name l) ctps))) ;; `(lambda ,info ,lambda-list ,doc ,body)) ;; (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*) ctps ;; ) ;; (cmpck (endp lambda-expr) ;; "The lambda expression ~s is illegal." (cons 'lambda lambda-expr)) ;; ;;FIXME -- this is backwards, as the proclamations should be ;; ;;generated from the declarations. What we need here and in the let ;; ;;code is reverse type propagation. CM 20050106 ;; ;; (let ((decls (decls-from-procls ;; ;; (car lambda-expr) ;; ;; (and block-it (get-arg-types block-name)) ;; ;; (cdr lambda-expr)))) ;; ;; (when decls ;; ;; (cmpnote "~S function args declared: ~S~%" block-name decls) ;; ;; (setq lambda-expr (cons (car lambda-expr) (cons (cons 'declare decls) (cdr lambda-expr)))))) ;; (multiple-value-setq (body ss ts is other-decls doc ctps) ;; (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*)))) ;; (set-var-init-type (car aux-vars) (info-type (second (car aux-inits)))) ;; (go Laux1) ;; ) ;; ) ;; (setq requireds (reverse requireds) ;; optionals (reverse optionals) ;; keywords (reverse keywords) ;; aux-vars (reverse aux-vars) ;; aux-inits (reverse aux-inits)) ;; (check-vdecl vnames ts is) ;; (setq body (c1decl-body other-decls body)) ;; (dolist (l (list requireds optionals keywords aux-vars)) ;; (dolist (v l) ;; (when (var-p v) ;; (setf (var-type v) (var-mt v))))) ;; (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)) ;; (setf (info-type aux-info) (info-type (cadr body))) ;; (setq body (list 'let* aux-info aux-vars aux-inits body)) ;; (or (eql setjmps *setjmps*) (setf (info-volatile aux-info) 1))) ;; ;;FIXME -- is above for aux needed too? ;; (when (or optionals keywords) ;; (or (eql setjmps *setjmps*) (setf (info-volatile info) 1))) ;; (setq lambda-list ;; (list requireds optionals rest key-flag keywords allow-other-keys)) ;; (dolist (l requireds) ;; (setf (var-type l) (type-and (var-type l) (nil-to-t (cdr (assoc (var-name l) ctps))))));(unboxed-type (cdr (assoc (var-name l) ctps))) ;; (and *record-call-info* (record-arg-info lambda-list)) ;; `(lambda ,info ,lambda-list ,doc ,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 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. )) gcl27-2.7.0/cmpnew/gcl_cmplet.lsp000077500000000000000000000742331454061450500166000ustar00rootroot00000000000000;;; 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 set-var-init-type (v t1);;FIXME should be in c1make-var (when (eq (var-kind v) 'lexical) (setq t1 (coerce-to-one-value t1)) (setf (var-dt v) (var-type v) (var-type v) (ensure-known-type (if *compiler-new-safety* (var-type v) (type-and t1 (var-dt v)))) (var-mt v) (var-type v) (var-loc v) (unless (and (eq (var-loc v) 'object) (unless (eq t (var-type v)) (var-type v))) (var-loc v))) (keyed-cmpnote (list (var-name v) 'type-propagation 'type 'init-type) "Setting init type of ~s to ~s" (var-name v) (cmp-unnorm-tp (var-type v))))) (defun new-c1progn (f body) (let ((info (copy-info (cadr body)))) (add-info info (cadr f)) (list 'progn info (if (eq (car body) 'progn) (cons f (caddr body)) (list f body))))) ;; (defun side-effects-p (f &optional bl) ;; (cond ((atom f) nil) ;; ((eq (car f) 'setq) (let ((v (car (third f)))) (member (var-kind v) '(special global))));FIXME psetq ;; ((member (car f) '(lambda function foo)) nil) ;; ((eq (car f) 'call-global) ;; (reduce (lambda (y x) (or y (side-effects-p x))) ;; (fourth f) :initial-value (not (get (caddr f) 'c1no-side-effects)))) ;; ((eq (car f) 'block) (side-effects-p (cdddr f) (cons (caddr f) bl))) ;; ((member (car f) '(return return-from)) (or (not (member (caddr f) bl)) (side-effects-p (cdddr f) bl))) ;; ((member (car f) '(call-local ordinary funcall apply throw princ structure-set go)));FIXME ;; ((or (side-effects-p (car f) bl) (side-effects-p (cdr f) bl))))) ;; (defun ignorable-form (f) ;; (cond ((member (car f) '(function lambda))) ;; ((> (length (info-changed-array (cadr f))) 0) nil) ;; ((side-effects-p f) nil) ;; (t))) ;; (defun have-provfn (form);FIXME provisional flag ;; (cond ((atom form) (eq form 'provfn)) ;; ((or (have-provfn (car form)) (have-provfn (cdr form)))))) ;; (defun provisional-block-trim (n bp fs star) ;; (declare (ignorable n)) ;; (when *provisional-inline* ;; (or bp ;; (when star ;; (have-provfn (cdr fs)))))) (defun ignorable-form-with-local-unreferenced-changes (form vs) (let* ((i (cadr form))(ch (info-ch i)) (nch (remove-if (lambda (x) (and (member x vs) (eq (var-kind x) 'lexical) (not (eq (var-ref x) t)) (not (var-ref-ccb x)))) ch))) (ignorable-form (if (eq nch ch) form (list* (car form) (let ((i (copy-info i)))(setf (info-ch i) nch) i) (cddr form)))))) (defun trim-vars (vars forms body &optional star) (do* (nv nf (vs vars (cdr vs)) (fs forms (cdr fs)) (av (append vars *vars*)) (fv (cdr av) (cdr fv))) ((or (endp vs) (endp fs)) (list nv nf body)) (let ((var (car vs)) (form (car fs))) (cond ((and (eq (var-kind var) 'LEXICAL) (not (eq t (var-ref var))) ;;; This field may be IGNORE. (not (var-ref-ccb var))) (check-vref var) (keyed-cmpnote (list 'var-trim (var-name var)) "Trimming ~s; bound form ~a ignorable" (var-name var) (if (ignorable-form form) "" "not ")) (unless (ignorable-form-with-local-unreferenced-changes form (cdr vs));(ignorable-form form) (when star (ref-vars form (cdr vs))) (let* ((*vars* (if nf (if star fv *vars*) av)) (f (if nf (car nf) body)) (np (new-c1progn form f))) (if nf (setf (car nf) np) (setf body np))))) ((push var nv) (when star (ref-vars form (cdr vs))) (push form nf)))))) ;; (defun trim-vars (vars forms body &optional star &aux (bp (have-provfn body))) ;; (do* (nv nf (vs vars (cdr vs)) (fs forms (cdr fs)) ;; (av (append vars *vars*)) (fv (cdr av) (cdr fv))) ;; ((or (endp vs) (endp fs)) (list nv nf body)) ;; (let ((var (car vs)) (form (car fs))) ;; (cond ((and (eq (var-kind var) 'LEXICAL) ;; (not (eq t (var-ref var))) ;;; This field may be IGNORE. ;; (not (var-ref-ccb var)) ;; (not (provisional-block-trim (var-name var) bp fs star))) ;; (unless (ignorable-form form) ;; (let* ((*vars* (if nf (if star fv *vars*) av)) ;; (f (if nf (car nf) body)) ;; (np (new-c1progn form f))) ;; (if nf (setf (car nf) np) (setf body np))))) ;; ((push var nv) (push form nf)))))) ;; (defun trim-vars (vars forms body &optional star) ;; (do* (nv nf (vs vars (cdr vs)) (fs forms (cdr fs)) ;; (av (append vars *vars*)) (fv (cdr av) (cdr fv))) ;; ((or (endp vs) (endp fs)) (list nv nf body)) ;; (let ((var (car vs)) (form (car fs))) ;; (cond ((and (eq (var-kind var) 'LEXICAL) ;; (not (eq t (var-ref var))) ;;; This field may be IGNORE. ;; (not (var-ref-ccb var)) ;; (not *provisional-inline*));FIXME ;; (unless (ignorable-form form) ;; (let* ((*vars* (if nf (if star fv *vars*) av)) ;; (f (if nf (car nf) body)) ;; (np (new-c1progn form f))) ;; (if nf (setf (car nf) np) (setf body np))))) ;; ((push var nv) (push form nf)))))) (defun mvars (args ss is ts star inls) (mapcar (lambda (x) (let* ((n (if (atom x) x (pop x))) (f (unless (atom x) (car x))) (v (c1make-var n ss is ts)) (fm (if (and inls (eq f (caar inls))) (cdr (pop inls)) (c1arg f))));FIXME check (set-var-init-type v (info-type (cadr fm))) (when (eq (car fm) 'var) (pushnew (caaddr fm) (var-aliases v))) (maybe-reverse-type-prop (var-type v) fm) (when star (push-var v fm)) (cons v fm))) args)) ;; (defun mvars (args ss is ts star inls) ;; (mapcar (lambda (x) ;; (let* ((n (if (atom x) x (pop x))) ;; (f (unless (atom x) (car x))) ;; (v (c1make-var n ss is ts)) ;; (fm (if (and inls (eq f (caar inls))) (cdr (pop inls)) (c1arg f))));FIXME check ;; (set-var-init-type v (info-type (cadr fm))) ;; (when (eq (car fm) 'var) (pushnew (caaddr fm) (var-aliases v))) ;; (maybe-reverse-type-prop (var-type v) fm) ;; (when star (push v *vars*)) ;; (cons v fm))) args)) ;; (defun mvars (args ss is ts star inls &aux *c1exit*) ;; (mapcar (lambda (x) ;; (let* ((n (if (atom x) x (pop x))) ;; (f (unless (atom x) (car x))) ;; (v (c1make-var n ss is ts)) ;; (fm (if (and inls (eq f (caar inls))) (cdr (pop inls)) (c1expr f))));FIXME check ;; (set-var-init-type v (info-type (cadr fm))) ;; (when (eq (car fm) 'var) (pushnew (caaddr fm) (var-aliases v))) ;; (maybe-reverse-type-prop (var-type v) fm) ;; (when star (push v *vars*)) ;; (cons v fm))) args)) ;; (defun mvars (args ss is ts info star &aux *c1exit* (ov *vars*)) ;; (mapcar (lambda (x) ;; (let* ((n (if (atom x) x (pop x))) ;; (f (unless (atom x) (car x))) ;; (v (c1make-var n ss is ts)) ;; (fm (if (and *inline-forms* ;; (eq f (caar *inline-forms*))) (cdr (pop *inline-forms*)) (c1expr f)))) ;; (let ((*vars* ov)) (add-info info (cadr fm)));FIXME? top-level info ;; (set-var-init-type v (info-type (cadr fm))) ;; (when (eq (car fm) 'var) (pushnew (caaddr fm) (var-aliases v))) ;; (maybe-reverse-type-prop (var-type v) fm) ;; (when star (push v *vars*)) ;; (cons v fm))) args)) ;; (defun fsl (sl) ;; (labels ((m (tg q &aux (v (member tg q :key 'car))) (if v (m (cdar v) (cdr v)) tg))) ;; (mapl (lambda (x) (setf (cdar x) (m (cdar x) (cdr x)))) sl))) ;; (defun c1replace-check (sl f) ;; (cond ((atom f) (assert (not (assoc f sl)))) ;; (t (c1replace-check sl (car f)) (c1replace-check sl (cdr f))))) ;; (defun c1replace-body (sl f);FIXME push refs to slot of var to avoid walk ;; (unless (atom f) ;; (labels ((set (v &aux (s (assoc (car v) sl))) (when s (setf (car v) (cdr s))))) ;; (case (car f) ;; (var (if (info-p (cadr f)) (set (third f)) (c1replace-body sl (cdr f)))) ;; (infer-tp (set (cddr f));FIXME ;; (c1replace-body sl (cdddr f))) ;; (otherwise (c1replace-body sl (car f)) (c1replace-body sl (cdr f))))))) ;; (defun c1replace (form) ;; (let* ((nm (pop form)) (info (pop form)) (vars (pop form)) (fms (pop form)) ;; (q (mapcar 'cons vars fms)) ;; (nf (append fms form)) ;; (ch (reduce 'nunion (mapcar (lambda (x &aux (x (cadr x))) (union (info-ch x) (union (info-ref-ccb x) (info-ref-clb x)))) nf))) ;; (sl (remove-if (lambda (x) (not (eq (cadr x) 'var))) q)) ;; (sl (mapcar (lambda (x) (cons (car x) (car (third (cdr x))))) sl)) ;; (sl (labels ((bad (x) (or (member x ch) (member (var-kind x) '(global special))))) ;; (remove-if (lambda (x) (or (bad (car x)) (bad (cdr x)))) sl))) ;; (sl (remove-if-not (lambda (x) (type>= (var-type (car x)) (var-type (cdr x)))) sl)) ;; (sl (fsl (nreverse sl))) ;; (q (remove-if (lambda (x) (assoc (car x) sl)) q))) ;; (mapc (lambda (x) (mapc (lambda (y) (setf (car y) (cdr x))(push y (var-store (cdr x)))) (var-store (car x)))) sl) ;; ; (c1replace-check sl nf) ;; (list* nm info (mapcar 'car q) (mapcar 'cdr q) form))) ;; (defun c1replace (form) ;; (let* ((nm (pop form)) (info (pop form)) (vars (pop form)) (fms (pop form)) ;; (q (mapcar 'cons vars fms)) ;; (nf (append fms form)) ;; (ch (reduce 'nunion (mapcar (lambda (x &aux (x (cadr x))) (union (info-ch x) (union (info-ref-ccb x) (info-ref-clb x)))) nf))) ;; (sl (remove-if (lambda (x) (not (eq (cadr x) 'var))) q)) ;; (sl (mapcar (lambda (x) (cons (car x) (car (third (cdr x))))) sl)) ;; (sl (labels ((bad (x) (or (member x ch) (member (var-kind x) '(global special))))) ;; (remove-if (lambda (x) (or (bad (car x)) (bad (cdr x)))) sl))) ;; (sl (remove-if-not (lambda (x) (type>= (var-type (car x)) (var-type (cdr x)))) sl)) ;; (sl (fsl (nreverse sl))) ;; (q (remove-if (lambda (x) (assoc (car x) sl)) q))) ;; (when sl (c1replace-body sl nf));FIXME push refs to slot of var to avoid walk ;; ; (c1replace-check sl nf) ;; (list* nm info (mapcar 'car q) (mapcar 'cdr q) form))) (defun push-var (var form) (push var *vars*) (push-vbind var form)) (defun c1let-* (args &optional star inls &aux (nm (if star 'let* 'let)) (ov *vars*) (*vars* *vars*) (setjmps *setjmps*) ss is ts body other-decls (info (make-info))) (when (endp args) (too-few-args nm 1 0)) (multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil)) (let* ((vs (nreverse (mvars (car args) ss is ts star inls))) (vars (mapcar 'car vs)) (forms (mapcar 'cdr vs)) (vnames (mapcar 'var-name vars))) (unless star (mapc (lambda (x) (push-var (car x) (cdr x))) vs)) (c1add-globals (set-difference ss vnames)) (check-vdecl vnames ts is) (setq body (c1decl-body other-decls body)) (unless (single-type-p (info-type (cadr body))) (let ((mv (car (member-if 'is-mv-var vars)))) (when mv (ref-vars (c1var (var-name mv)) (list mv))))) (ref-vars body vars) (dolist (var vars) (setf (var-type var) (var-mt var)));FIXME? (let* ((*vars* ov) (z (trim-vars vars forms body star)) (vars (pop z)) (fms (pop z)) (body (car z))) (dolist (fm fms) (add-info info (cadr fm))) (add-info info (cadr body)) (setf (info-type info) (info-type (cadr body))) (unless (eq setjmps *setjmps*) (setf (info-volatile info) 1)) (if vars (list nm info vars fms body) (list* (car body) info (cddr body)))))) ;; (defun c1let-* (args &optional star inls ;; &aux (nm (if star 'let* 'let)) ;; (ov *vars*) (*vars* *vars*) (setjmps *setjmps*) ;; ss is ts body other-decls ;; (info (make-info))) ;; (when (endp args) (too-few-args nm 1 0)) ;; (multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil)) ;; (let* ((vs (nreverse (mvars (car args) ss is ts star inls))) ;; (vars (mapcar 'car vs)) ;; (forms (mapcar 'cdr vs)) ;; (vnames (mapcar 'var-name vars)) ;; (*vars* (if star *vars* (append vars *vars*)))) ;; (c1add-globals (set-difference ss vnames)) ;; (check-vdecl vnames ts is) ;; (setq body (c1decl-body other-decls body)) ;; (unless (single-type-p (info-type (cadr body))) ;; (let ((mv (car (member-if 'is-mv-var vars)))) ;; (when mv ;; (ref-vars (c1var (var-name mv)) (list mv))))) ;; (ref-vars body vars) ;; (dolist (var vars) (setf (var-type var) (var-mt var)));FIXME? ;; (let* ((*vars* ov) ;; (z (trim-vars vars forms body star)) ;; (vars (pop z)) ;; (fms (pop z)) ;; (body (car z))) ;; (dolist (fm fms) (add-info info (cadr fm))) ;; (add-info info (cadr body)) ;; (setf (info-type info) (info-type (cadr body))) ;; (unless (eq setjmps *setjmps*) (setf (info-volatile info) 1)) ;; (if vars (c1replace (list nm info vars fms body)) ;; (list* (car body) info (cddr body)))))) ;; (defun c1let-* (args &optional star inls ;; &aux (nm (if star 'let* 'let)) ;; (ov *vars*) (*vars* *vars*) (setjmps *setjmps*) ;; ss is ts body other-decls ;; (info (make-info))) ;; (when (endp args) (too-few-args nm 1 0)) ;; (multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil)) ;; (let* ((vs (nreverse (mvars (car args) ss is ts star inls))) ;; (vars (mapcar 'car vs)) ;; (forms (mapcar 'cdr vs)) ;; (vnames (mapcar 'var-name vars)) ;; (*vars* (if star *vars* (append vars *vars*)))) ;; (c1add-globals (set-difference ss vnames)) ;; (check-vdecl vnames ts is) ;; (setq body (c1decl-body other-decls body)) ;; (unless (single-type-p (info-type (cadr body))) ;; (let ((mv (car (member-if 'is-mv-var vars)))) ;; (when mv ;; (ref-vars (c1var (var-name mv)) (list mv))))) ;; (ref-vars body vars) ;; (dolist (var vars) (setf (var-type var) (var-mt var)));FIXME? ;; (let* ((*vars* ov) ;; (z (trim-vars vars forms body star)) ;; (vars (pop z)) ;; (fms (pop z)) ;; (body (car z))) ;; (dolist (fm fms) (add-info info (cadr fm))) ;; (add-info info (cadr body)) ;; (setf (info-type info) (info-type (cadr body))) ;; (unless (eq setjmps *setjmps*) (setf (info-volatile info) 1)) ;; (if vars (list nm info vars fms body) ;; (list* (car body) info (cddr body)))))) ;; (defun c1let-* (args &optional star env inls ;; &aux (nm (if star 'let* 'let)) ;; (ov *vars*) (*vars* *vars*) (setjmps *setjmps*) ;; ss is ts body other-decls ;; (info (make-info))) ;; (when (endp args) (too-few-args nm 1 0)) ;; (multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil)) ;; (let* ((vs (nreverse (mvars (car args) ss is ts star inls))) ;; (vars (mapcar 'car vs)) ;; (forms (mapcar 'cdr vs)) ;; (vnames (mapcar 'var-name vars)) ;; (*vars* (if star *vars* (append vars *vars*)))) ;; (c1add-globals (set-difference ss vnames)) ;; (check-vdecl vnames ts is) ;; (setq body (c1decl-body other-decls body)) ;; (unless (single-type-p (info-type (cadr body))) ;; (let ((mv (car (member-if 'is-mv-var vars)))) ;; (when mv ;; (ref-vars (c1var (var-name mv)) (list mv))))) ;; (ref-vars body vars) ;; (dolist (var vars) (setf (var-type var) (var-mt var)));FIXME? ;; (let* ((*vars* ov)) ;; (under-env ;; env ;; (let* ((z (trim-vars vars forms body star)) ;; (vars (pop z)) ;; (fms (pop z)) ;; (body (car z))) ;; (dolist (fm fms) (add-info info (cadr fm))) ;; (add-info info (cadr body)) ;; (setf (info-type info) (info-type (cadr body))) ;; (unless (eq setjmps *setjmps*) (setf (info-volatile info) 1)) ;; (if vars (list nm info vars fms body) ;; (list* (car body) info (cddr body)))))))) ;; (defun c1let-* (args &optional star ;; &aux (nm (if star 'let* 'let)) ;; (ov *vars*) (*vars* *vars*) (setjmps *setjmps*) ;; ss is ts body other-decls ;; (info (make-info))) ;; (when (endp args) (too-few-args nm 1 0)) ;; (multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil)) ;; (let* ((vs (nreverse (mvars (car args) ss is ts info star))) ;; (vars (mapcar 'car vs)) ;; (forms (mapcar 'cdr vs)) ;; (vnames (mapcar 'var-name vars)) ;; (*vars* (if star *vars* (append vars *vars*)))) ;; (c1add-globals (set-difference ss vnames)) ;; (check-vdecl vnames ts is) ;; (setq body (c1decl-body other-decls body)) ;; (when (member-if 'is-mv-var vars) ;; (unless (single-type-p (info-type (cadr body))) ;; (c1vref +mv+))) ;; (dolist (var vars) ;; (check-vref var) ;; (setf (var-type var) (var-mt var)));FIXME? ;; (let* ((*vars* ov) ;; (z (trim-vars vars forms body star))) ;FIXME mi5 too ;; (add-info info (cadr body)) ;; (setf (info-type info) (info-type (cadr body))) ;; (unless (eq setjmps *setjmps*) (setf (info-volatile info) 1)) ;; (if (car z) (list* nm info z) (caddr z))))) (defun c1let (args) (c1let-* args)) (defun c1let* (args) (c1let-* args t)) ;; (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)) ;; ; (setq args (declare-let-bindings-new args nil ss)) ;; ; (setq args (declare-let-bindings-new1 args nil ss)) ;; (multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil)) ;; ; (c1add-globals ss) ;; (let ((*vars* *vars*)) ;; (dolist** (x (car args)) ;; (cond ((symbolp x) ;; (let ((v (c1make-var x ss is ts))) ;; (push x vnames) ;; (push v vars) ;; (set-var-init-type (car vars) #tnull) ;; (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) ;; (when (eq (caar forms) 'var) ;; (pushnew (caaddr (car forms)) (var-aliases (car vars)))) ;; (set-var-init-type (car vars) (info-type (second (car forms)))) ;; (maybe-reverse-type-prop (var-type v) (car forms)))))) ;; (c1add-globals (set-difference ss vnames)) ;; (setq vars (nreverse vars)) ;; (dolist* (v vars) (push v *vars*)) ;; (setq vars (nreverse 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) 1)) ;; (dolist (var vars) (setf (var-type var) (var-mt var))) ;; (let ((z (trim-vars vars forms body))) ;; (cond ((car z) (list* 'let info z)) ;; ((caddr z))))) (defun c2let (vars forms body &aux block-p bindings initials (*unwind-exit* *unwind-exit*) (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) (do ((vl vars (cdr vl)) (fl forms (cdr fl)) (prev-ss nil)) ((endp vl)) (let* ((form (car fl)) (var (car vl)) (kind (c2var-kind var))) (cond (kind (setf (var-kind var) kind (var-loc var) (cs-push (var-type var) t))) ((eq (var-kind var) 'down) (or (si::fixnump (var-loc var)) (wfs-error))) ((eq (var-kind var) 'special)) ((setf (var-ref var) (vs-push))) ) (if (member (var-kind var) +c-local-var-types+) (push (list 'c2expr* (list 'var var nil) form) initials) (case (car form) (LOCATION (if (can-be-replaced var body) (progn (setf (var-kind var) 'REPLACED (var-loc var) (caddr form))) (push (list var (caddr form)) bindings))) (VAR (let ((var1 (caaddr form))) (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))) ((push (list var) bindings) (unless (integerp (var-ref var)) (setf (var-ref var) (vs-push))) (list 'vs (var-ref var)))) form) initials)) ((eq (var-kind var) 'replaced)) ((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))))) ((push (list var (list 'var var1 (cadr (caddr form)))) bindings))))) (otherwise (cond ((when (and nil (symbolp (car form));FIXME (get (car form) 'wt-loc) (can-be-replaced var body) (= (var-register var) 1)) (setf (var-kind var) 'replaced) (var-loc var) form)) ((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))) ((push (list var) bindings) (unless (integerp (var-ref var)) (setf (var-ref var) (vs-push))) (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)) (cond ((type>= #tnil (info-type (cadr (third binding)))) (let ((*value-to-go* 'trash)) (c2expr* (third binding))) (let ((*value-to-go* (second binding))) (c2expr* (c1nil)))) ((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 vars vnames (*inline-forms* *inline-forms*) ;; (setjmps *setjmps*) ;; ss is ts body other-decls ;; (info (make-info))) ;; (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) ;; (let ((*vars* *vars*)) ;; (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) ;; (set-var-init-type (car vars) #tnull) ;; (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)) ;; (if (and *inline-forms* (eq (caar *inline-forms*) (cadr x))) ;; (let ((n (cdr (pop *inline-forms*)))) ;; (add-info info (cadr n)) ;; n) ;; (and-form-type (var-type v) ;; (c1expr* (cadr x) info) ;; (cadr x)))) ;; forms) ;; (push v vars) ;; (when (eq (caar forms) 'var) ;; (pushnew (caaddr (car forms)) (var-aliases (car vars)))) ;; (set-var-init-type (car vars) (info-type (second (car forms)))) ;; (maybe-reverse-type-prop (var-type v) (car forms)) ;; (push v *vars*))))) ;; (c1add-globals (set-difference ss vnames)) ;; ; (when *inline-forms* (print args)(break)) ;; (check-vdecl vnames ts is) ;; (setq body (c1decl-body other-decls body)) ;; (when (member-if 'is-mv-var vars) ;; (unless (single-type-p (info-type (cadr body))) ;; (c1vref +mv+)))) ;; (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) 1)) ;; (dolist (var vars) (setf (var-type var) (var-mt var))) ;; (let ((z (trim-vars vars forms body t))) ;; (cond ((car z) (list* 'let* info z)) ;; ((caddr z))))) (defun c2let* (vars forms body &aux (block-p nil) (*unwind-exit* *unwind-exit*) (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) (do ((vl vars (cdr vl)) (fl forms (cdr fl))) ((endp vl)) (let* ((form (car fl)) (var (car vl)) (kind (c2var-kind var))) (when kind (setf (var-kind var) kind (var-loc var) (cs-push (var-type var) t))) (unless (member (var-kind var) +c-local-var-types+) (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) 'down) (or (si::fixnump (var-loc var)) (baboon))) ((member (var-kind var) '(object special))) ((setf (var-ref var) (vs-push))) )) (VAR (let ((var1 (caaddr form))) (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))))) ((member (var-kind var) '(object special))) ((setf (var-ref var) (vs-push))) ))) (otherwise (cond ((when (and nil (symbolp (car form));FIXME (get (car form) 'wt-loc) (can-be-replaced var body) (= (var-register var) 1))(print form) (setf (var-kind var) 'replaced) (var-loc var) form)) ((member (var-kind var) '(object special))) ((setf (var-ref var) (vs-push))) ; ((var-ref var) (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))) (cond ((eq (var-kind var) 'replaced)) ((type>= #tnil (info-type (cadr form))) (let ((*value-to-go* 'trash)) (c2expr* form)) (c2bind-loc var nil)) ((member (var-kind var) +c-local-var-types+) (let ((*value-to-go* (list 'var var nil))) (c2expr* form))) (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 (member (var-kind var) '(LEXICAL OBJECT REPLACED)) (not (var-cb var)) (not (var-noreplace var)) (not (is-changed var (cadr body))))) ;; (defun can-be-replaced (var body) ;; (and (member (var-kind var) '(LEXICAL OBJECT REPLACED)) ;; (not (var-cb var)) ;; (not (var-store var)) ;; (not (is-changed var (cadr body))))) ;; (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))) (when (or (eq kind 'object) (member kind +c-local-var-types+)) (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 (cs-push t t) 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 (cs-push t t))) (wt-nl "{Cons_Macro" n ";") (c2expr form) (wt "}") (wt-h "#define Cons_Macro" n (format nil " struct cons ~{STcons~a ~^,~};" nums) ))) ;;FIXME update this ;(push '((fixnum t t) t #.(flags) ; "(STcons#0.t=t_cons,STcons#0.m=0,STcons#0.c_car=(#1), ; STcons#0.c_cdr=(#2),(object)&STcons#0)") ; (get 'stack-cons 'inline-always)) ;; ---------- end stack-let for consing on stack --------- gcl27-2.7.0/cmpnew/gcl_cmploc.lsp000077500000000000000000000475201454061450500165700ustar00rootroot00000000000000;;; 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*) (defvar *values-to-go* nil) (defvar *multiple-value-exit-label* nil) ;;; 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 'vs-address 'wt-vs-address '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 'char-value 'wt-char-value 'wt-loc) (si:putprop 'char-loc 'wt-char-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 'fcomplex-value 'wt-fcomplex-value 'wt-loc) (si:putprop 'fcomplex-loc 'wt-fcomplex-loc 'wt-loc) (si:putprop 'dcomplex-value 'wt-dcomplex-value 'wt-loc) (si:putprop 'dcomplex-loc 'wt-dcomplex-loc 'wt-loc) (si:putprop 'gen-loc 'wt-gen-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 multiple-values-p () (and (consp *value-to-go*) (consp (car *value-to-go*)))) (defvar *extend-vs-top*) (defun set-loc (loc &aux fd) (cond ((eq *value-to-go* 'return) (set-return loc)) ((member *value-to-go* '(trash expr)) (let ((tr (eq *value-to-go* 'trash))) (cond ((and (consp loc) (rassoc (car loc) +inline-types-alist+) (cadr loc)) (wt-nl (if tr "(void)" "") "(") (wt-inline t (caddr loc) (cadddr loc)) (wt ")" (if tr ";" ""))) ((and (consp loc) (eq (car loc) 'SIMPLE-CALL)) (wt-nl (if tr "(void)" "") loc (if tr ";" "")))))) ((eq *value-to-go* 'top) (unless (eq loc 'fun-val) (set-top loc))) ((multiple-values-p) (let ((*values-to-go* *value-to-go*) *extend-vs-top*) (do ((loc loc nil)) ((null *values-to-go*)) (let ((*value-to-go* (pop *values-to-go*))) (set-loc loc))) (when *mvb-vals* (wt-nl) (when (and *extend-vs-top* (> (var-space *mv-var*) 0)) (let ((l (var-loc *mv-var*))) (wt-nl "for (vs_top=vs_top (var-space *mv-var*) 0)) ;; (let ((l (var-loc *mv-var*))) ;; (wt-nl "for (vs_top=vs_topc.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) " */")) (let* ((fn (or (car (rassoc cvar *c-vars*)) (cdr (assoc cvar *c-vars*)) t)) (fn (or (car (member fn +c-local-var-types+ :test 'type<=)) 'object)) (fn (cdr (assoc fn +wt-c-var-alist+)))) (unless fn (baboon)) (wt fn) (wt "(V" cvar ")"))) (defun vv-str (vv) (let ((vv (add-object2 vv))) (string-concatenate "((object)VV[" (write-to-string vv) "])"))) ;; (defun vv-str (vv) (si::string-concatenate "((object)VV[" (write-to-string vv) "])")) (defun wt-vv (vv) (wt (vv-str vv))) (defun kind-tp (x) (cadr (assoc x *c-types*))) (let ((fk (kind-tp 'fixnum))(ck (kind-tp 'char))) (defun wt-fixnum-loc (loc &aux x) (cond ((and (consp loc) (eq (car loc) 'var) (or (eq fk (var-kind (cadr loc))) (eq ck (var-kind (cadr loc)))));FIXME (wt "V" (var-loc (cadr loc)))) ((and (consp loc) (eq (car loc) 'cvar) (setq x (car (rassoc (cadr loc) *c-vars*))) (type>= #tfixnum x)) (wt loc)) ((and (consp loc) (member (car loc) +number-inlines+)) ; (wt "(fixnum)") (wt-inline-loc (caddr loc) (cadddr loc))) ((and (consp loc) (or (eq (car loc) 'fixnum-value) (eq (car loc) 'char-value))) ; (wt "(fixnum)") (cond ((= (caddr loc) most-negative-fixnum) (wt "(" (1+ most-negative-fixnum) "- 1)")) ((wt (caddr loc))))) ((and (consp loc) (eq (car loc) 'vs-address));???? (wt loc)) (t (wt (if *safe-compile* "fixint(" "fix(") loc ")"))))) ;; (defun wt-integer-loc (loc &aux (avma t)(first (and (consp loc) (car loc)))) ;; (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 ;; (cond ;; ((eq (var-kind (cadr loc)) #tinteger) (setq avma nil) (wt "V" (var-loc (cadr loc)))) ;; ((eq (var-kind (cadr loc)) #tfixnum) (wt "stoi(V" (var-loc (cadr loc))")")) ;; ((wt "otoi(" loc ")")))) ;; (otherwise (wt "otoi(" loc ")"))) ;; ; (and avma (not *restore-avma*)(wfs-error)) ;; ) (let ((fk (kind-tp 'fixnum))) (defun fixnum-loc-p (loc) (and (consp loc) (or (and (eq (car loc) 'var) (eq fk (var-kind (cadr loc)))) (eq (car loc) 'INLINE-FIXNUM) (eq (car loc) 'fixnum-value))))) (defun wt-fixnum-value (vv fixnum-value) (if vv (wt (vv-str vv)) (wt "make_fixnum(" fixnum-value ")"))) (defun wt-vs-address (v i) (wt "(fixnum)(" v "+" i ")")) (let ((ck (kind-tp 'character))) (defun wt-character-loc (loc) (cond ((and (consp loc) (eq (car loc) 'var) (eq (var-kind (cadr loc)) ck)) (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 ")"))))) (let ((ck (kind-tp 'character))) (defun character-loc-p (loc) (and (consp loc) (or (and (eq (car loc) 'var) (eq (var-kind (cadr loc)) ck)) (eq (car loc) 'INLINE-CHARACTER) (eq (car loc) 'character-value))))) (defun wt-character-value (vv character-code) (if vv (wt (vv-str vv)) (wt "code_char(" character-code ")"))) (defun wt-char-loc (loc) (wt-fixnum-loc loc)) (let ((ck (kind-tp 'char))) (defun char-loc-p (loc) (and (consp loc) (or (and (eq (car loc) 'var) (eq (var-kind (cadr loc)) ck)) (eq (car loc) 'INLINE-CHAR) (eq (car loc) 'char-value))))) (defun wt-char-value (vv char) (if vv (wt (vv-str vv)) (wt "make_fixnum(" char ")"))) (let ((lk (kind-tp 'long-float))) (defun wt-long-float-loc (loc &aux x) (cond ((and (consp loc) (eq (car loc) 'var) (eq (var-kind (cadr loc)) lk)) (wt "V" (var-loc (cadr loc)))) ((and (consp loc) (eq (car loc) 'cvar) (setq x (car (rassoc (cadr loc) *c-vars*))) (type>= #tlong-float x)) (wt 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 ")"))))) (let ((lk (kind-tp 'long-float))) (defun long-float-loc-p (loc) (and (consp loc) (or (and (eq (car loc) 'var) (eq (var-kind (cadr loc)) lk)) (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 ft-wrapper (key tt pp) ;; (if *compiler-new-safety* ;; (wt (strcat "((" key ")object_to_" (if pp "pointer" "dcomplex") "(")) ;; (wt (or (cdr (assoc tt +to-c-var-alist+)) "") "("))) ;; (defun tt-wrapper (ft) ;; (wt (or (cdr (assoc ft +wt-c-var-alist+)) "") "(")) ;; (defun cast-wrapper (key) key) (defun loc-kind (loc &aux (cl (when (listp loc) (car loc)))) (cond ((eq cl 'var) (let* ((var (cadr loc)) (kind (var-kind var))) (case kind (replaced (loc-kind (var-loc var))) ((global object lexical special) #tt) (otherwise kind)))) ((eq cl 'cvar) (or (car (member (or (car (rassoc (cadr loc) *c-vars*)) (cdr (assoc (cadr loc) *c-vars*)) #tt) +c-local-var-types+ :test 'type<=)) #tt)) ((car (rassoc cl +inline-types-alist+))) ((car (rassoc cl +value-types+))) (#tt))) (defun wt-lexical-var (loc) (let* ((var (pop loc)) (ccb (car loc))) (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))))));FIXME side-effect propagation (defun vv-value-loc (key loc &aux (ktp (get key 'cmp-lisp-type))) (unless (eq ktp t) (when (when (consp loc) (eq (car loc) 'vv)) (let* ((x (cadr loc)) (x (if (ltvp x) (eval (cdr x)) x))) (when (type>= ktp (object-tp x)) `(,(cdr (assoc ktp +value-types+ :test 'type<=)) nil ,x)))))) (defun wt-gen-loc (key loc &aux (loc (or (vv-value-loc key loc) loc)) p) (let* ((cl (when (consp loc) (car loc))) (fit (car (rassoc cl +inline-types-alist+))) (fvt (car (rassoc cl +value-types+))) (ft (loc-kind loc)) (tt (get key 'cmp-lisp-type)) (cast (if (member key '(:cnum :creal)) "" (strcat "(" key ")"))) (pp (search "*" cast))) (cond ((unless fvt (eq ft tt))) ((equal ft #tt) (if *compiler-new-safety* (let ((v (member key '(:char :int :fixnum)))) (if v (wt (setq p "object_to_") (strcat key)) (wt cast (setq p "object_to_") (if pp "pointer" "dcomplex")))) (wt (or (setq p (cdr (assoc tt +to-c-var-alist+ :test 'type<=))) cast))));FIXME prune to-c list ((equal tt #tt) (wt (or (setq p (cdr (assoc ft +wt-c-var-alist+))) ""))) ((and (type>= #tint tt) (type>= tt ft))) ((and (type>= #tcnum tt) (type>= #t(or character cnum) ft)) (wt cast)) ((baboon))) (when p (wt "(")) (cond ((not loc) (wt "Cnil")) ((eq loc t) (wt "Ct")) ((eq cl 'var) (case (var-kind (cadr loc)) ((special global) (wt "(" (vv-str (var-loc (cadr loc))) "->s.s_dbind)")) (lexical (wt-lexical-var (cdr loc))) (otherwise (cond ((integerp (var-loc (cadr loc))) (wt "V" (var-loc (cadr loc)))) ((and (consp (var-loc (cadr loc))) (rassoc (car (var-loc (cadr loc))) +value-types+)) (wt (caddr (var-loc (cadr loc))))) ((wt (var-loc (cadr loc)))))))) ((eq cl 'cvar) (wt "V" (cadr loc))) ((eq cl 'vv) (wt loc)) (fit (wt-inline-loc (caddr loc) (cadddr loc))) (fvt (cond ((= (caddr loc) most-negative-fixnum) (wt "(" (1+ most-negative-fixnum) "- 1)")) ((wt (caddr loc))))) ((baboon))) (when pp (unless *compiler-new-safety* (wt "->v.v_self"))) (when p (wt ")")) (when (and (equal tt #tt) (equal ft #tboolean)) (wt "?Ct:Cnil")))) (let ((sk (kind-tp 'short-float))) (defun wt-short-float-loc (loc) (cond ((and (consp loc) (eq (car loc) 'var) (eq (var-kind (cadr loc)) sk)) (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 ")"))))) (let ((sk (kind-tp 'short-float))) (defun short-float-loc-p (loc) (and (consp loc) (or (and (eq (car loc) 'var) (eq (var-kind (cadr loc)) sk)) (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))) (let ((fk (kind-tp 'fcomplex))) (defun wt-fcomplex-loc (loc) (cond ((and (consp loc) (eq (car loc) 'var) (eq (var-kind (cadr loc)) fk)) (wt "V" (var-loc (cadr loc)))) ((and (consp loc) (eq (car loc) 'INLINE-FCOMPLEX)) (wt-inline-loc (caddr loc) (cadddr loc))) ((and (consp loc) (eq (car loc) 'fcomplex-value)) (wt (caddr loc))) (t (wt "sfc(" loc ")"))))) (let ((fk (kind-tp 'fcomplex))) (defun fcomplex-loc-p (loc) (and (consp loc) (or (and (eq (car loc) 'var) (eq (var-kind (cadr loc)) fk)) (eq (car loc) 'INLINE-FCOMPLEX) (eq (car loc) 'fcomplex-value))))) (defun wt-fcomplex-value (vv fcomplex-value) (declare (ignore fcomplex-value)) (wt (vv-str vv))) (let ((dk (kind-tp 'dcomplex))) (defun wt-dcomplex-loc (loc) (cond ((and (consp loc) (eq (car loc) 'var) (eq (var-kind (cadr loc)) dk)) (wt "V" (var-loc (cadr loc)))) ((and (consp loc) (eq (car loc) 'INLINE-DCOMPLEX)) (wt-inline-loc (caddr loc) (cadddr loc))) ((and (consp loc) (eq (car loc) 'dcomplex-value)) (wt (caddr loc))) (t (wt "lfc(" loc ")"))))) (let ((dk (kind-tp 'dcomplex))) (defun dcomplex-loc-p (loc) (and (consp loc) (or (and (eq (car loc) 'var) (eq (var-kind (cadr loc)) dk)) (eq (car loc) 'INLINE-DCOMPLEX) (eq (car loc) 'dcomplex-value))))) (defun wt-dcomplex-value (vv dcomplex-value) (declare (ignore dcomplex-value)) (wt (vv-str vv))) gcl27-2.7.0/cmpnew/gcl_cmpmain.lsp000077500000000000000000000755441454061450500167460ustar00rootroot00000000000000;;; 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*));FIXME (import 'si::(*tmp-dir* *cc* *ld* *objdump*)) (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) ;; (si::file-to-string ;; (namestring ;; (make-pathname :directory (append (pathname-directory si::*system-directory*) (list :back "h")) ;; :name "cmpinclude" :type "h")))) (defvar *compiler-default-type* #p".lsp") (defvar *compiler-normal-type* #p".lsp") (defvar *compile-file-truename* nil) (defvar *compile-file-pathname* nil) ;; 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" )) ((let ((lf (and file (not (eq file t))))) (let ((device (if lf (pathname-device file) device)) (dir (if lf (pathname-directory file) dir)) (name (if lf (pathname-name file) name))) (make-pathname :device device :directory dir :name name :type ext)))))) (defun safe-system (string) (multiple-value-bind (code result) (system (mysub string "$" "\\$")) (unless (and (zerop code) (zerop result)) (cerror "Continues anyway." "(SYSTEM ~S) returned a non-zero value ~D ~D." string code 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 *default-prof-p* nil) #+large-memory-model(defvar *default-large-memory-model-p* nil) (defvar *keep-gaz* nil) (defvar *prof-p* nil) #+large-memory-model(defvar *large-memory-model-p* 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 (defvar *lsp-ext* (make-pathname :type "lsp")) (defvar *o-ext* (make-pathname :type "o")) (defvar *compile-file-truename*) (defvar *sigs* (make-hash-table :test 'eq)) (defvar *new-sigs-in-file* nil) (defun set-first-sig (x y) (unless (gethash x *sigs*) (setf (gethash x *sigs*) y))) (defun setup-sigs nil (clrhash *sigs*) (mapc (lambda (x) (set-first-sig (car x) (cdr x)) (mapc (lambda (x) (set-first-sig (car x) (list (cdr x) nil nil nil nil nil))) (caddr x))) si::*sig-discovery-props*)) (defun compile-file (fn &rest l &aux w e) (values (handler-bind ((style-warning (lambda (c) (declare (ignore c)) (setq w t))) (warning (lambda (c) (declare (ignore c)) (setq w t e t))) (error (lambda (c) (declare (ignore c)) (setq w t e t)))) (apply 'compile-file2 fn l)) w e)) (defun compile-file2 (filename &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 (filename (pathname filename)) (*compile-file-pathname* (merge-pathnames filename)) (*compile-file-truename* (truename filename))) (loop (setup-sigs) (do nil ((not (eq (setq tem (let (*new-sigs-in-file*) (apply 'compile-file1 filename args))) 'again)))) (cond ((atom *split-files*)(return (when tem (truename tem)))) ((and (consp *split-files*) (null (third *split-files*))) (let* ((gaz (gazonk-name)) (*readtable* (si::standard-readtable))) (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) (unless (member :output-file args) (setq args (append args (list :output-file (merge-pathnames (make-pathname :type "o") (pathname filename)))))) (return (let ((tem (apply 'compile-file gaz (append args (unless (member :output-file args) (list :output-file (get-output-pathname filename "o" nil nil nil))))))) (unless *keep-gaz* (mdelete-file gaz)) (when tem (truename tem)))))) ((setf (car *split-files*) (+ (third *split-files*) section-length)))))) (defvar *init-name* nil) (defvar *function-filename* nil) (defvar *c-debug* nil) (defun compile-file1 (input-pathname &key (output-file (merge-pathnames ".o" (truename 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 *compile-print*) (external-format :default) (verbose *compile-verbose*) (prof-p *default-prof-p*) #+large-memory-model(large-memory-model-p *default-large-memory-model-p*) (load nil) &aux (*standard-output* *standard-output*) (*prof-p* prof-p) #+large-memory-model(*large-memory-model-p* large-memory-model-p) (output-file (pathname output-file)) (*error-output* *error-output*) (*compiler-in-use* *compiler-in-use*) (*c-debug* c-debug) (*compile-print* (or print *compile-print*)) (*compile-verbose* verbose) (*DEFAULT-PATHNAME-DEFAULTS* #p"") *data* (*fasd-data* *fasd-data*) (*error-count* 0) (*init-name* *init-name*) (*function-filename* *function-filename*)) (declare (ignore external-format)) ; (declare (special *c-debug* system-p)) (cond (*compiler-in-use* (format t "~&The compiler was called recursively.~%~ Cannot compile ~a.~%" (namestring (merge-pathnames input-pathname *compiler-default-type*))) (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 *compiler-default-type*)) (format t "~&The source file ~a is not found.~%" (namestring (merge-pathnames input-pathname *compiler-default-type*))) (setq *error-p* t) (return-from compile-file1 (values))) (when *compile-verbose* (format t "~&;; Compiling ~a.~%" (namestring (merge-pathnames input-pathname *compiler-default-type*)))) (and *record-call-info* (clear-call-table)) (with-open-file (*compiler-input* (merge-pathnames input-pathname *compiler-default-type*)) (when (numberp *split-files*) (setq *split-files* (unless (< (file-length *compiler-input*) *split-files*) (list *split-files* nil 0 nil)))) (when (consp *split-files*) (file-position *compiler-input* (third *split-files*)) (setq output-file (make-pathname :device (pathname-device output-file) :directory (pathname-directory output-file) :name (format nil "~a~a" (pathname-name output-file) (length (second *split-files*))) :type "o"))) (with-open-file (s output-file :if-does-not-exist :create)) (setq *init-name* (init-name output-file t)) (setq *function-filename* (unless *compiler-compile* (namestring (truename (pathname *compiler-input*))))) (let* ((eof (cons nil nil)) (dir (or (unless (null output-file) (pathname-directory output-file)) (pathname-directory input-pathname))) (name (or (unless (null output-file) (pathname-name output-file)) (pathname-name input-pathname))) (tp (or (unless (null output-file) (pathname-type output-file)) "o")) (device (or (unless (null output-file) (pathname-device output-file)) (pathname-device input-pathname))) (o-pathname (get-output-pathname o-file tp 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));FIXME (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 (when (eq (get-macro-character #\# rtb) (get-macro-character #\# (si:standard-readtable))) (get-dispatch-macro-character #\# #\, rtb)))) (when (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.. (when (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 (if *eval-when-defaults* (list-split '(load :load-toplevel) *eval-when-defaults*) t))) (nil) (unless (eq form eof) (if load-flag (t1expr form) (maybe-eval nil form))) (when (or (eq form eof) (and *split-files* (> (file-position *compiler-input*) (car *split-files*)))) (when *new-sigs-in-file* (keyed-cmpnote (list 'signatures (car *new-sigs-in-file*)) "Caller ~s appears after callee ~s,~% whose sig changed from ~s to ~s, restart pass1~%" (car *new-sigs-in-file*) (cadr *new-sigs-in-file*) (caddr *new-sigs-in-file*) (cadddr *new-sigs-in-file*)) (return-from compile-file1 'again)) (when *split-files* (push (pathname-name output-file) (second *split-files*)) (setf (third *split-files*) (unless (eq form eof) (file-position *compiler-input*))) (setf (fourth *split-files*) nil));(reverse (third *data*)) ;FIXME check this (return nil))) (when prev (set-dispatch-macro-character #\# #\, prev rtb))))) (when *sig-discovery* (close *compiler-output-data*) (close *compiler-input*) (return-from compile-file1 (values))) (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 (delete-file c-pathname)) (unless h-file (delete-file h-pathname)) (unless (or data-file #+ld-not-accept-data t system-p) (delete-file data-pathname)) (when o-file o-pathname)) (progn (when (probe-file c-pathname) (delete-file c-pathname)) (when (probe-file h-pathname) (delete-file h-pathname)) (when (probe-file data-pathname) (delete-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-data2 form) ;; this binds all the print stuff )) (defun fun-env (name) (let ((fun (when (fboundp name) (or (macro-function name) (symbol-function name))))) (multiple-value-bind (src clo blk) (function-lambda-expression fun) (declare (ignore src blk)) (mapcar 'cadr clo)))) ;; (cond ((si::interpreted-function-p fun) ;; (multiple-value-bind ;; (src clo blk) ;; (function-lambda-expression fun) ;; (declare (ignore src blk)) ;; (mapcar 'cadr clo))) ;; ((compiled-function-p fun) (c::function-env fun 0))))) (defun get-named-form (name) (when (fboundp name) (let* ((mac (macro-function name)) (na (if (symbol-package name) name 'cmp-anon)) (fun (or mac (symbol-function name)))) (multiple-value-bind (lam clo) (function-lambda-expression fun) (assert (not (when mac clo)));FIXME? (let ((form `(,(if mac 'defmacro 'defun) ,(if mac (cons 'macro na) na) ,(cadr lam) ,@(cddr lam))));na (if mac (cons 'macro na) na) (values (if clo `(let* (,@(nreverse (let ((i -1)) (mapcar (lambda (x) `(,(car x) (nth ,(incf i) (fun-env ',name)))) clo)))) ,form) form) na)))))) (defvar *compiler-compile-data* nil) (defun compile (name &optional def &aux na tem gaz (*default-pathname-defaults* #p".")) (when (eq name 'cmp-anon) ; (remhash name si::*call-hash-table*) (dolist (l '(proclaimed-function proclaimed-arg-types proclaimed-return-type)) (remprop name l))) (cond ((not (symbolp name)) (error "Must be a name")) ((and (consp def) (eq (car def) 'lambda));(or (si::interpreted-function-p def) );FIXME (compile nil (coerce def 'function))) ((functionp def) (or name (setf name 'cmp-anon)) (setf (symbol-function name) def) (compile name)) (def (error "def not a lambda expression")) ;; FIXME -- support warnings-p and failures-p. CM 20041119 ((multiple-value-setq (tem na) (get-named-form name)) (let (warnings failures *compiler-compile-data*) (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)) (multiple-value-bind (fn w f) (let ((*compiler-compile* tem)) (compile-file gaz)) (when fn (load fn) (unless *keep-gaz* (delete-file fn))) (setq warnings w failures f)) (unless *keep-gaz* (delete-file gaz))) (unless (eq na name) (setf (symbol-function name) (symbol-function na))) (when *tmp-pack* (delete-package *tmp-pack*) (setq *tmp-pack* nil)) (values (symbol-function name) warnings failures))) (t (error "can't compile ~a" name)))) (defvar *codes* '((lambda (x) (code-char x)) (lambda (x) (char-code x)) (lambda (x y) (+ x y)) (lambda (x y) (declare (seqind x y)) (+ x y)) (lambda (x y) (- x y)) (lambda (x y) (declare (seqind x y)) (- x y)) (lambda (x) (- x)) (lambda (x) (declare (seqind x)) (- x)) (lambda (x y) (member x y)) (lambda (x y) (declare (symbol x)) (member x y)) (lambda (f x) (mapl f x)) (lambda (x) (mapc (lambda (x) (1+ x)) x)) (lambda (x) (coerce x 'function)) (lambda (x) (declare (function x)) (coerce x 'function)) (lambda (x) (declare (symbol x)) (coerce x 'function)) (lambda (x y) (eq x y)) (lambda (x y) (eql x y)) (lambda (x y) (declare (symbol x)) (eql x y)) (lambda (x y) (declare (fixnum x)) (eql x y)) (lambda (x y) (declare (symbol x) (fixnum x)) (eql x y)))) (defun code-size (f) (let* ((x (with-output-to-string (s) (let ((*standard-output* s)) (disassemble f)))) (b (string-match #v"\n[0-9a-f]* <[^>\n]*>:" x)) (e (string-match #v"\n[0-9a-f]* <[^>\n]*>:" x (match-end 0))) (x (subseq x b e))(i 0)(zb 0)(ze 0)) (do nil ((>= 0 (string-match #v"\n *\([0-9a-f]*\):" x i))) (setq zb (match-beginning 1) ze (match-end 1) i (match-end 0))) (let ((*read-base* 16)) (read-from-string (subseq x zb ze))))) (defun vec-to-list (x) (typecase x (string (if (find-if-not 'standard-char-p x) "fasl code" x)) ((vector t) (vec-to-list (coerce x 'list))) (cons (let ((a (vec-to-list (car x)))(d (vec-to-list (cdr x)))) (if (and (eq a (car x)) (eq d (cdr x))) x (cons a d)))) (otherwise x))) (defvar *disassemble-objdump* t) (defun disassemble (name &aux tem); &optional (asm t) file (declare (optimize (safety 1))) (check-type name (or function function-identifier)) (cond ((and (consp name) (eq (car name) 'lambda)) (dolist (l '(proclaimed-function proclaimed-return-type proclaimed-arg-types)) (remprop 'cmp-anon l)) (eval `(defun cmp-anon ,@ (cdr name))) (disassemble 'cmp-anon)) ((consp name) (disassemble (si::funid-sym name))) ((functionp name) (disassemble (si::fle name))) ((setq tem (get-named-form name)) (let ((gaz (gazonk-name))(*compiler-compile* tem)) (with-open-file (st gaz :direction :output) (prin1-cmp 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 #v"gazonk_[0-9]*_[0-9]*.h" a) 0) (format t "~%~d~%" a) a)))) (si::copy-stream st *standard-output*)) (with-open-file (st dn) (princ (let (f) (do nil ((eq 'eof (car (push (read st nil 'eof) f))) (vec-to-list (nreverse (cdr f)))))))) (with-open-file (st hn) (si::copy-stream st *standard-output*)) (when *disassemble-objdump* (si::copy-stream (open (concatenate 'string "|objdump --source " (namestring on))) *standard-output*)) (delete-file cn) (delete-file dn) (delete-file hn) (delete-file on) (unless *keep-gaz* (delete-file gaz)) nil))))) (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 (or (eq system-p 'disassemble) (probe-file ci)) system-p))) (declare (special *init-name*)) (with-open-file (st c-pathname :direction :output) (let ((*compiler-output1* (if (eq system-p 'disassemble) *standard-output* 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 c-pathname system-p))) (when system-p (wt-nl "") (wt-nl "#ifdef SYSTEM_SPECIAL_INIT") (wt-nl "SYSTEM_SPECIAL_INIT") (wt-nl "#endif")) (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 *ld-libs* "ld-libs") (defvar *opt-three* "") (defvar *opt-two* "") (defvar *init-lsp* "init-lsp") (defvar *use-buggy* nil) (defun remove-flag (flag flags) (let ((i (search flag flags))) (if i (concatenate 'string (subseq flags 0 i) (remove-flag flag (subseq flags (+ i (length flag))))) flags))) (defun compiler-command (&rest args ) (declare (special *c-debug*)) (format nil "~a ~a -I~a ~a ~a -c ~a -o ~a" (concatenate 'string (if *prof-p* (remove-flag "-fomit-frame-pointer" *cc*) *cc*) #+large-memory-model(if *large-memory-model-p* " -mcmodel=large " "") #-large-memory-model "") (if *prof-p* " -pg " "") (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)))) #+(or cygwin 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)))) (defun compiler-cc (c-pathname o-pathname) (safe-system (format nil #+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" #+(or cygwin winnt) (prep-win-path-acc (compiler-command c-pathname o-pathname) "") #-(or vax system-v e15 dgux sgi) (compiler-command c-pathname o-pathname) *cc* (if (or (= *speed* 2) (= *speed* 3)) t nil) (namestring c-pathname) (namestring o-pathname))) #+large-memory-model(when *large-memory-model-p* (mark-as-large-memory-model 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-new-safety*) 2) ((null *compiler-push-events*) 3) (t 4)) *safe-compile* *space* *speed* *debug*)) (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)) (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 '(:relative)))) (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 "extern void gcl_init_or_load1 (void (*fn) (void), const char *file);~%") (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) (delete-file c) o)) (defun mysub (str it new) (declare (string str it new));FIXME (let ((x (search it str))) (cond ((not x) str) ((si::string-concatenate (subseq str 0 x) new (mysub (subseq str (+ x (length it))) it new)))))) (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)) (when (= 0 (system (format nil "~a ~a ~a ~a -L~a ~a ~a ~a" *ld* (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 "-rdynamic -Wl,-Map ~a" (namestring map)) #-gnu-ld "" (let* ((par (namestring (make-pathname :directory '(:relative :up)))) (i (concatenate 'string " " par)) (j (concatenate 'string " " si::*system-directory* par))) (mysub *ld-libs* i j)) (if (stringp extra-libs) extra-libs "")))) (delete-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 "(setq si::*optimize-maximum-pages* ~s si::*disable-recompile* ~s)(si::use-fast-links t)" si::*optimize-maximum-pages* si::*disable-recompile*) (format st "(si::save-system \"~a\")~%" (namestring image))) (when (= 0 (system (format nil "GCL_SYSDIR=~a ~a ~a < ~a" si::*system-directory* (namestring raw) si::*system-directory* (namestring init)))) (delete-file raw) (delete-file init) image)))) (defun cdebug (&optional a) (setq *default-system-p* t *default-c-file* t *default-data-file* t *default-h-file* t *keep-gaz* a *annotate* a)) gcl27-2.7.0/cmpnew/gcl_cmpmap.lsp000077500000000000000000000024171454061450500165640ustar00rootroot00000000000000;;; 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) (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)))) gcl27-2.7.0/cmpnew/gcl_cmpmulti.lsp000077500000000000000000000626031454061450500171440ustar00rootroot00000000000000;;; 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-bind 'c1multiple-value-bind 'c1) (si:putprop 'multiple-value-bind 'c2multiple-value-bind 'c2) (defun nval (x) (cond ;((type>= #t(returns-exactly) x) 0) ((single-type-p x) 1) ((when (consp x) (eq (car x) 'returns-exactly)) (1- (length x))))) (defun c1multiple-value-call (args &aux (tsyms (load-time-value (mapl (lambda (x) (setf (car x) (gensym "MV-CALL"))) (make-list 50))))) (when (endp args) (too-few-args 'multiple-value-call 1 0)) (let* ((info (make-info)) (nargs (c1args args info)) (tps (mapcar (lambda (x) (info-type (cadr x))) (cdr nargs))) (vals (mapcar 'nval tps)) (n (if (member nil vals) -1 (reduce '+ vals)))) (cond ((endp (cdr args)) (c1funcall args)) ((and (>= (length tsyms) n 0) (inline-possible 'multiple-value-bind)) (let* ((syms (mapcar (lambda (x) (declare (ignore x)) (pop tsyms)) (make-list n))) (r syms)) (c1expr (reduce (lambda (x y) (cond ((= 1 (length (car x))) `(let ((,(caar x) ,(cadr x))) ,y)) (`(multiple-value-bind ,@x ,y)))) (mapcar (lambda (x y) (let* ((n (nval x)) syms) (dotimes (i n) (push (pop r) syms)) (list (nreverse syms) y))) tps (cdr args)) :from-end t :initial-value `(funcall ,(car args) ,@syms))))) ((list 'multiple-value-call info (pop nargs) nargs))))) ;; (defun c1multiple-value-call (args) ;; (when (endp args) (too-few-args 'multiple-value-call 1 0)) ;; (let* ((nargs (c1args (cdr args) (make-info))) ;; (tps (mapcar (lambda (x) (info-type (cadr x))) nargs))) ;; (cond ((endp (cdr args)) (c1funcall args)) ;; ((and (not (member-if-not 'nval tps)) ;; (inline-possible 'multiple-value-bind)) ;; (let* ((n (reduce '+ (mapcar 'nval tps))) ;; (syms (mapcar (lambda (x) (declare (ignore x)) (tmpsym)) (make-list n))) ;; (r syms)) ;; (c1expr ;; (reduce (lambda (x y) ;; (cond ((= 1 (length (car x))) ;; `(let ((,(caar x) ,(cadr x))) ,y)) ;; (`(multiple-value-bind ,@x ,y)))) ;; (mapcar (lambda (x y) (let* ((n (nval x)) syms) ;; (dotimes (i n) (push (pop r) syms)) ;; (list (nreverse syms) y))) tps (cdr args)) ;; :from-end t :initial-value `(funcall ,(car args) ,@syms))))) ;; ((let* ((info (make-info)) ;; (nargs (c1args args info))) ;; (list 'multiple-value-call info (pop nargs) nargs)))))) (defun c2multiple-value-call (funob forms &aux (*vs* *vs*) (loc (list 'vs (vs-push))) top sup) (let ((*value-to-go* loc)) (c2expr* funob)) (cond ((endp (cdr forms)) (let ((*value-to-go* 'top)) (c2expr* (car forms)))) ((setq top (cs-push t t)) (setq sup (cs-push t t)) (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= (length tsyms) (length (cdr tp))))) (keep-vars))) (cond ((single-type-p tp) (let ((s (pop tsyms))) (c1expr `(let ((,s ,(car args))) ,@(cdr args) ,s)))) ((and (consp tp) (eq (car tp) 'returns-exactly) (>= (length tsyms) (length (cdr tp)))) (let ((syms (mapcar (lambda (x) (declare (ignore x)) (pop tsyms)) (cdr tp)))) (c1expr `(multiple-value-bind (,@syms) ,(car args) ,@(cdr args) (values ,@syms))))) (t (setq args (c1args (cdr args) info)) ; (setf (info-type info) (info-type (cadr form))) (list 'multiple-value-prog1 info form args)))) ;; (defun c1multiple-value-prog1 (args &aux (info (make-info)) form) ;; (when (endp args) (too-few-args 'multiple-value-prog1 1 0)) ;; (setq form (c1expr* (car args) info)) ;; (let ((tp (info-type (cadr form)))) ;; (cond ((single-type-p tp) (let ((s (tmpsym))) (c1expr `(let ((,s ,(car args))) ,@(cdr args) ,s)))) ;; ((and (consp tp) (eq (car tp) 'returns-exactly)) ;; (let ((syms (mapcar (lambda (x) (declare (ignore x)) (tmpsym)) (cdr tp)))) ;; (c1expr `(multiple-value-bind (,@syms) ,(car args) ,@(cdr args) (values ,@syms))))) ;; (t ;; (setq args (c1args (cdr args) info)) ;; (setf (info-type info) (info-type (cadr form))) ;; (list 'multiple-value-prog1 info form args))))) ;; We may record information here when *value-to-go* = 'top (defvar *top-data* nil) (defun c2multiple-value-prog1 (form forms &aux (base (cs-push t t)) (top (cs-push t t)) (sup (cs-push t t)) top-data) (let ((*value-to-go* 'top) *top-data*) (c2expr* form) (setq top-data *top-data*)) ;; 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 "=vs_top,*V" base "=vs_base,*V" sup "=sup;") (setq *sup-used* t) (wt-nl "vs_base=V" top ";") (dolist (form forms) (let ((*value-to-go* 'trash) (*unwind-exit* (cons (cons 'sup sup) *unwind-exit*))) (c2expr-top* form top))) (wt-nl "vs_base=V" base ";vs_top=V" top ";sup=V" sup ";}") (unwind-exit 'fun-val nil (if top-data (car top-data)))) (defun c1values (args &aux (nargs (mapcar (lambda (x &aux (x (c1expr x))) (setf (info-type (cadr x)) (coerce-to-one-value (info-type (cadr x)))) x) args))) (cond ((unless (cdr nargs) (car nargs))) ((let ((info (make-info))) (setf (info-type info) (cons 'returns-exactly (mapcar (lambda (x &aux (i (cadr x))) (add-info info i) (info-type i)) nargs))) (list 'values info nargs))))) ;; (defun c1values (args &aux (info (make-info))) ;; (cond ((and args (not (cdr args))) ;; (let ((nargs (c1args args info))) ;; (if (type>= t (info-type (cadar nargs))) ;; (c1expr (car args)) ;; (c1expr (let ((s (tmpsym))) `(let ((,s ,(car args))) ,s)))))) ;; (t ;; (setq args (c1args args info)) ;; (setf (info-type info) ;; (cmp-norm-tp ;; (cons 'returns-exactly ;; (mapcar (lambda (x) (coerce-to-one-value (info-type (cadr x)))) args)))) ;; (list 'values info args)))) (defun c2values (forms) (let* ((*inline-blocks* 0) (types (mapcar (lambda (x) (let ((x (coerce-to-one-value (info-type (cadr x))))) (if (type>= #tboolean x) t x))) forms)) (i -1) ;FIXME all of this unnecessary, just avoid valp[i]=base[0] (r (mapcar (lambda (x y &aux (x (when x (write-to-string (incf i))))) (strcat (rep-type y) " _t" x "=#" x ";")) (or forms (list (c1nil))) (or types (list #tnull)))) (i 0) (s (mapcar (lambda (x &aux (x (when x (write-to-string (incf i))))) (strcat "@" x "(_t" x ")@")) (cdr forms))) (s (strcat "({" (apply 'strcat (nconc r s)) "_t0;})"));FIXME (s (cons s (mapcar 'inline-type (cdr types)))) (in (list (inline-type (car types)) (flags) s (inline-args forms types)))) (unwind-exit in nil (cons 'values (length forms))) (close-inline-blocks))) ;; (defun c2values (forms) ;; (if *mv-var* ;; (let* ((*inline-blocks* 0) ;; (types (mapcar (lambda (x) (let ((x (coerce-to-one-value (info-type (cadr x))))) (if (type>= #tboolean x) t x))) forms)) ;; (i 0) ;; (s (mapcar (lambda (x &aux (x (when x (write-to-string (incf i))))) (strcat "@" x "(#" x ")@")) (cdr forms))) ;; (s (strcat "({" (apply 'strcat s) "#0;})")) ;; (s (cons s (mapcar 'inline-type (cdr types)))) ;; (in (list (inline-type (car types)) (flags) s (inline-args forms types)))) ;; (unwind-exit in nil (cons 'values (length forms))) ;; (close-inline-blocks)) ;; (prog1 (c2expr (or (car forms) (c1nil))) ;; (let ((*value-to-go* 'trash)) ;; (dolist (f (cdr forms)) (c2expr f)))))) ;; (defun c2values (forms) ;; (if *mv-var* ;; (let* ((*inline-blocks* 0) ;; (types (mapcar (lambda (x) (let ((x (info-type (cadr x)))) (if (type>= #tboolean x) t x))) forms)) ;; (i 0) ;; (s (mapcar (lambda (x &aux (x (when x (write-to-string (incf i))))) (strcat "@" x "(#" x ")@")) (cdr forms))) ;; (s (strcat "({" (apply 'strcat s) "#0;})")) ;; (s (cons s (mapcar 'inline-type (cdr types)))) ;; (in (list (inline-type (car types)) (flags) s (inline-args forms types)))) ;; (unwind-exit in nil (cons 'values (length forms))) ;; (close-inline-blocks)) ;; (c2expr (car forms)))) ;; (defun c2values (forms &aux (base *vs*) (*vs* *vs*)) ;; (when (and (eq *value-to-go* 'return-object) ;; (cdr forms) ;; (consp *current-form*) ;; (eq 'defun (car *current-form*)) ;; (single-type-p (get-return-type (cadr *current-form*)))) ;; (cmpwarn "Trying to return multiple values. ~%;But ~a was proclaimed to have single value.~%;Only first one will assured." ;; (cadr *current-form*))) ;; (cond ;; (*mv-var* ;; (let* ((*inline-blocks* 0) ;; (types (mapcar (lambda (x) (let ((x (info-type (cadr x)))) (if (type>= #tboolean x) t x))) forms)) ;; (in (list (inline-type (car types)) ;; (flags) ;; (list* (si::string-concatenate ;; "({" ;; (apply 'si::string-concatenate ;; (let ((i 0)) ;; (mapcan (lambda (x) (declare (ignore x)) ;; (let ((s (write-to-string (incf i)))) ;; (list (si::string-concatenate "@" s "(#" s ")@")))) (cdr forms)))) ;; "#0;})") ;; (mapcar 'inline-type (cdr types))) ;; (inline-args forms types)))) ;; (unwind-exit in nil (cons 'values (length forms))) ;; (close-inline-blocks) ;; (return-from c2values nil))) ;; ((null forms) ;; (wt-nl "vs_base=vs_top=base+" base ";") ;; (base-used) ;; (wt-nl "vs_base[0]=Cnil;")) ;; (t ;; (dolist** (form forms) ;; (let ((*value-to-go* (list 'vs (vs-push)))) (c2expr* form)));FIXME ;; (wt-nl "vs_top=(vs_base=base+" base ")+" (- *vs* base) ";") ;; (base-used))) ;; (unwind-exit 'fun-val nil (cons 'values (length forms)))) (defun multiple-value-check (vrefs form) (and (cdr vrefs) (eq (car form) 'call-global) (let ((fname (third form))) (cond ((and (symbolp fname) (single-type-p (get-return-type fname))) (cmpwarn "~A was proclaimed to have only one return value. ~%;But you appear to want multiple values." fname)))))) (defun c1multiple-value-bind (args &aux (info (make-info)) (vars nil) (vnames nil) init-form ss is ts body other-decls (*vars* *vars*) ; (ov *vars*) ) (when (or (endp args) (endp (cdr args))) (too-few-args 'multiple-value-bind 2 (length args))) (when (and (caar args) (not (cdar args))) (return-from c1multiple-value-bind (c1expr `(let ((,(caar args) ,(cadr args))) ,@(cddr args))))) (multiple-value-setq (body ss ts is other-decls) (c1body (cddr args) nil)) (dolist (s (car args)) (let ((v (c1make-var s ss is ts))) (push s vnames) (push v vars))) (c1add-globals (set-difference ss vnames)) (setq init-form (c1arg (cadr args) info)) (setq vars (nreverse vars)) (let* ((tp (info-type (second init-form))) (tp (cond ((not tp) tp) ((single-type-p tp) (list tp)) ((eq tp '*) (make-list (length vars) :initial-element t)) ((cdr tp))))) (do ((v vars (cdr v)) (t1 tp (cdr t1))) ((not v)) (set-var-init-type (car v) (or (car t1) #tnull)))) (dolist (v vars) (push-var v init-form)) (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))) (ref-vars body vars) (dolist (var vars) (check-vref var)) ;; (let* ((*vars* ov));FIXME ;; (print (setq fff (trim-vars vars (make-list (length vars) :initial-element init-form) body nil))) ;; (break)) (list 'multiple-value-bind info vars init-form body)) ;; (defun c1multiple-value-bind (args &aux (info (make-info)) ;; (vars nil) (vnames nil) init-form ;; ss is ts body other-decls ;; (*vars* *vars*)) ;; (when (or (endp args) (endp (cdr args))) ;; (too-few-args 'multiple-value-bind 2 (length args))) ;; (when (and (caar args) (not (cdar args))) ;; (return-from c1multiple-value-bind ;; (c1expr `(let ((,(caar args) ,(cadr args))) ,@(cddr args))))) ;; (multiple-value-setq (body ss ts is other-decls) (c1body (cddr args) nil)) ;; (dolist (s (car args)) ;; (let ((v (c1make-var s ss is ts))) ;; (push s vnames) ;; (push v vars))) ;; (c1add-globals (set-difference ss vnames)) ;; (setq init-form (c1arg (cadr args) info)) ;; (setq vars (nreverse vars)) ;; (let* ((tp (info-type (second init-form))) ;; (tp (cond ((not tp) tp) ;; ((single-type-p tp) (list tp)) ;; ((eq tp '*) (make-list (length vars) :initial-element t)) ;; ((cdr tp))))) ;; (do ((v vars (cdr v)) (t1 tp (cdr t1))) ;; ((not v)) ;; (set-var-init-type (car v) (or (car t1) #tnull)))) ;; (dolist* (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))) ;; (ref-vars body vars) ;; (dolist** (var vars) (check-vref var)) ;; (list 'multiple-value-bind info vars init-form body)) ;; (defun c1multiple-value-bind (args &aux (info (make-info)) ;; (vars nil) (vnames nil) init-form ;; ss is ts body other-decls ;; (*vars* *vars*)) ;; (when (or (endp args) (endp (cdr args))) ;; (too-few-args 'multiple-value-bind 2 (length args))) ;; (when (and (caar args) (not (cdar args))) ;; (return-from c1multiple-value-bind ;; (c1expr `(let ((,(caar args) ,(cadr args))) ,@(cddr args))))) ;; (multiple-value-setq (body ss ts is other-decls) (c1body (cddr args) nil)) ;; (dolist (s (car args)) ;; (let ((v (c1make-var s ss is ts))) ;; (push s vnames) ;; (push v vars))) ;; (c1add-globals (set-difference ss vnames)) ;; (let (*c1exit*) (setq init-form (c1expr* (cadr args) info))) ;; (setq vars (nreverse vars)) ;; (let* ((tp (info-type (second init-form))) ;; (tp (cond ((not tp) tp) ;; ((single-type-p tp) (list tp)) ;; ((eq tp '*) (make-list (length vars) :initial-element t)) ;; ((cdr tp))))) ;; (do ((v vars (cdr v)) (t1 tp (cdr t1))) ;; ((not v)) ;; (set-var-init-type (car v) (or (car t1) #tnull)))) ;; (dolist* (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))) ;; (ref-vars body vars) ;; (dolist** (var vars) (check-vref var)) ;; (list 'multiple-value-bind info vars init-form body)) ;; (defun c1multiple-value-bind (args &aux (info (make-info)) ;; (vars nil) (vnames nil) init-form ;; ss is ts body other-decls ;; (*vars* *vars*)) ;; (when (or (endp args) (endp (cdr args))) ;; (too-few-args 'multiple-value-bind 2 (length args))) ;; (when (and (caar args) (not (cdar args))) ;; (return-from c1multiple-value-bind ;; (c1expr `(let ((,(caar args) ,(cadr args))) ,@(cddr args))))) ;; (multiple-value-setq (body ss ts is other-decls) (c1body (cddr args) nil)) ;; (dolist (s (car args)) ;; (let ((v (c1make-var s ss is ts))) ;; (push s vnames) ;; (push v vars))) ;; (c1add-globals (set-difference ss vnames)) ;; (let (*c1exit*) (setq init-form (c1expr* (cadr args) info))) ;; (setq vars (nreverse vars)) ;; (let* ((tp (info-type (second init-form))) ;; (tp (cond ((not tp) tp) ;; ((single-type-p tp) (list tp)) ;; ((eq tp '*) (make-list (length vars) :initial-element t)) ;; ((cdr tp))))) ;; (do ((v vars (cdr v)) (t1 tp (cdr t1))) ;; ((not v)) ;; (set-var-init-type (car v) (or (car t1) #tnull)))) ;; (dolist* (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)) ;; (list 'multiple-value-bind info vars init-form body)) (defun max-stack-space (form) (abs (vald (info-type (cadr form))))) (defun stack-space (form) (let* ((tp (info-type (cadr form))) (vd (vald tp))) (cond ((< vd 0) (- vd)) ((equal tp #t(returns-exactly)) 0)))) (defvar *mvb-vals* nil) (defvar *vals-set* nil) (defun c2multiple-value-bind (vars init-form body &aux (labels nil) (*unwind-exit* *unwind-exit*) (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*) top-data lbs) (multiple-value-check vars init-form) (let* ((mv (make-var :type #tfixnum :kind 'lexical :loc (cs-push #tfixnum t))) (nv (1- (length vars))) (ns1 (stack-space init-form)) (ns (max nv (or ns1 (max-stack-space init-form)))) (*mvb-vals* t) *vals-set*) (setf (var-kind mv) (c2var-kind mv) (var-space mv) nv (var-known-init mv) (or ns1 -1)) (setq lbs (mapcar (lambda (x) (let ((kind (c2var-kind x))(f (eq x (car vars)))) (if kind (setf (var-kind x) (if f kind 'object) (var-loc x) (cs-push (if f (var-type x) t) t)) (setf (var-ref x) (vs-push) x (cs-push (if f (var-type x) t) t))))) vars)) ; (wt-nl "{") ; (wt-nl "int vals_set=0;") (when vars (wt-nl "register " (rep-type (var-type (car vars))) " V" (car lbs) ";") (wt-nl "object V" (var-loc mv) "[" ns "];")) (let ((i -1)) (mapc (lambda (x) (wt-nl "#define V" x " V" (var-loc mv) "[" (incf i) "]")) (cdr lbs))) (wt-nl);FIXME (dotimes (i (1+ (length vars))) (push (next-label) labels)) (wt-nl "{") ;; (wt-nl "int vals_set=0;") (let ((*mv-var* mv) (*value-to-go* (or (mapcar (lambda (x) (list 'cvar x)) lbs) 'trash)) *top-data*) (c2expr* init-form) (setq top-data *top-data*)) (and *record-call-info* (record-call-info nil (car top-data))) (when lbs (unless *vals-set* (baboon))) ;; (wt-nl "if (!vals_set) {") ;; (setq labels (nreverse labels)) ;; (do ((lb lbs (cdr lb)) ;; (lab labels (cdr lab))) ;; ((endp lb)(reset-top)(wt-go (car lab))) ;; (wt-nl "if(vs_base>=vs_top){") ;; (reset-top) ;; (wt-go (car lab)) ;; (wt "}") ;; (set-cvar '(vs-base 0) (car lb)) ;; (when (cdr lb) ;; (wt-nl "vs_base++;"))) ;; (do ((lb lbs (cdr lb)) ;; (lab labels (cdr lab))) ;; ((endp lb)(wt-label (car lab))) ;; (wt-label (car lab)) ;; (set-cvar nil (car lb))) ;; (wt-nl "}}") (do ((vs vars (cdr vs)) (lb lbs (cdr lb))) ((endp vs)) (when (member (var-kind (car vs)) '(lexical special down)) (c2bind-loc (car vs) (list 'cvar (car lb)))))) (c2expr body) (mapc (lambda (x) (wt-nl "#undef V" x)) (cdr lbs)) (wt-nl "") (wt-nl "}")) ;; (defun c2multiple-value-bind (vars init-form body ;; &aux (labels nil) ;; (*unwind-exit* *unwind-exit*) ;; (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*) ;; top-data lbs) ;; (multiple-value-check vars init-form) ;; (let* ((mv (make-var :type #tfixnum :kind 'lexical :loc (cs-push #tfixnum t))) ;; (nv (1- (length vars))) ;; (ns1 (stack-space init-form)) ;; (ns (max nv (or ns1 (max-stack-space init-form)))) ;; (*mvb-vals* t)) ;; (setf (var-kind mv) (c2var-kind mv) (var-space mv) nv (var-known-init mv) (or ns1 -1)) ;; (setq lbs ;; (mapcar (lambda (x) ;; (let ((kind (c2var-kind x))(f (eq x (car vars)))) ;; (if kind (setf (var-kind x) (if f kind 'object) ;; (var-loc x) (cs-push (if f (var-type x) t) t)) ;; (setf (var-ref x) (vs-push) x (cs-push (if f (var-type x) t) t))))) ;; vars)) ;; (wt-nl "{") ;; ; (wt-nl "int vals_set=0;") ;; (when vars ;; (wt-nl "register " (rep-type (var-type (car vars))) " V" (car lbs) ";") ;; (wt-nl "object V" (var-loc mv) "[" ns "];")) ;; (let ((i -1)) (mapc (lambda (x) (wt-nl "#define V" x " V" (var-loc mv) "[" (incf i) "]")) (cdr lbs))) ;; (wt-nl);FIXME ;; (dotimes (i (1+ (length vars))) (push (next-label) labels)) ;; (wt-nl "{") ;; (wt-nl "int vals_set=0;") ;; (let ((*mv-var* mv) ;; (*value-to-go* (or (mapcar (lambda (x) (list 'cvar x)) lbs) 'trash)) ;; *top-data*) ;; (c2expr* init-form) ;; (setq top-data *top-data*)) ;; (and *record-call-info* (record-call-info nil (car top-data))) ;; (wt-nl "if (!vals_set) {") ;; (setq labels (nreverse labels)) ;; (do ((lb lbs (cdr lb)) ;; (lab labels (cdr lab))) ;; ((endp lb)(reset-top)(wt-go (car lab))) ;; (wt-nl "if(vs_base>=vs_top){") ;; (reset-top) ;; (wt-go (car lab)) ;; (wt "}") ;; (set-cvar '(vs-base 0) (car lb)) ;; (when (cdr lb) ;; (wt-nl "vs_base++;"))) ;; (do ((lb lbs (cdr lb)) ;; (lab labels (cdr lab))) ;; ((endp lb)(wt-label (car lab))) ;; (wt-label (car lab)) ;; (set-cvar nil (car lb))) ;; (wt-nl "}}") ;; (do ((vs vars (cdr vs)) (lb lbs (cdr lb))) ;; ((endp vs)) ;; (when (member (var-kind (car vs)) '(lexical special down)) ;; (c2bind-loc (car vs) (list 'cvar (car lb)))))) ;; (c2expr body) ;; (mapc (lambda (x) (wt-nl "#undef V" x)) (cdr lbs)) ;; (wt-nl "") ;; (wt-nl "}")) gcl27-2.7.0/cmpnew/gcl_cmpopt.lsp000077500000000000000000001440141454061450500166110ustar00rootroot00000000000000(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")) ;;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 rfa) "@0;(type_of(#0)==t_stream? ((#0)->sm.sm_fp)!=0: 0 )") (get 'fp-okp 'inline-unsafe)) (push '((stream) boolean #.(flags set rfa)"((#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 rfa)"type_of(#0)==t_longfloat") (get 'long-float-p 'inline-always)) ;;COMPLEX-P (push '((t) boolean #.(flags)"type_of(#0)==t_complex") (get 'si::complexp 'inline-always)) ;;SFEOF (push `((t) boolean #.(flags set rfa) ,(lambda (x) (add-libc "feof") (wt "(feof((" x ")->sm.sm_fp))"))) (get 'sfeof 'inline-unsafe)) ;;SGETC1 (push `((t) fixnum #.(flags set rfa) ,(lambda (x) (add-libc "getc") (wt "(getc((" x ")->sm.sm_fp))"))) (get 'sgetc1 'inline-unsafe)) ;;SPUTC (push `((fixnum t) fixnum #.(flags set rfa) ,(lambda (x y) (add-libc "putc") (wt "(putc(" x ",(" y ")->sm.sm_fp))"))) (get 'sputc 'inline-always)) (push `((character t) fixnum #.(flags set rfa) ,(lambda (x y) (add-libc "putc") (wt "(putc(char_code(" x "),(" y ")->sm.sm_fp))"))) (get 'sputc 'inline-always)) ;;FORK (push `(() t #.(flags) ,(lambda nil (add-libc "memset")(add-libc "pipe")(add-libc "close")(add-libc "fork")(wt "myfork()"))) (get 'si::fork 'inline-unsafe)) ;;READ-POINTER-OBJECT (push '((t) t #.(flags ans set)"read_pointer_object(#0)") (get 'si::read-pointer-object 'inline-unsafe)) ;;WRITE-POINTER-OBJECT (push '((t t) t #.(flags ans set)"write_pointer_object(#0,#1)") (get 'si::write-pointer-object 'inline-unsafe)) ;;READ-BYTE1 ;; (push '((t t) t #.(flags rfa ans set)"read_byte1(#0,#1)") ;; (get 'read-byte1 'inline-unsafe)) ;;READ-CHAR1 (push '((t t) t #.(flags rfa 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 rfa)"type_of(#0)==t_shortfloat") (get 'short-float-p 'inline-always)) ;;SIDE-EFFECTS (push '(nil t #.(flags)"Ct") (get 'side-effects 'inline-always)) ;;STACK-CONS ;;FIXME update this ; (push '((fixnum t t) t #.(flags) ; "(STcons#0.t=t_cons,STcons#0.m=0,STcons#0.c_car=(#1), ; STcons#0.c_cdr=(#2),(object)&STcons#0)") ; (get 'stack-cons 'inline-always)) ;;SUBLIS1 ;; (push '((t t t) t #.(flags rfa ans set)SUBLIS1-INLINE) ;; (get 'sublis1 'inline-always)) ;;FIXME the MAX and MIN optimized arg evaluations aren't logically related to side effects ;; but we need to save the intermediate results in any case to avoid exponential ;; growth in nested expressions. set added to flags for now here and in analogous ;; constructs involving ?. CM 20041129 ;;ABS ; (si::putprop 'abs 'abs-propagator 'type-propagator) (push '((t) t #.(compiler::flags) "immnum_abs(#0)") (get 'abs 'compiler::inline-always)) (push '(((integer #.(1+ most-negative-fixnum) #.most-positive-fixnum)) (integer 0 #.most-positive-fixnum) #.(flags)"abs(#0)") (get 'abs 'inline-always)) (push '((short-float) (short-float 0.0) #.(flags)"fabs(#0)") ;;FIXME ranged floating point types (get 'abs 'inline-always)) (push '((long-float) (long-float 0.0) #.(flags)"fabs(#0)") (get 'abs 'inline-always)) (push '(((real 0.0)) t #.(flags)"#0") (get 'abs 'inline-always)) (push '(((and cnum (real 0.0))) cnum #.(flags)"#0") (get 'abs 'inline-always)) ;;VECTOR-TYPE (push '((t fixnum) boolean #.(flags rfa) "@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(#1,fixint(#2),#0)") ;; (get 'system:aset 'inline-always)) ;; (push '((t t fixnum) t #.(flags set)"aset1(#1,#2,#0)") ;; (get 'system:aset 'inline-always)) ;; (push '((t t t) t #.(flags set)"aset1(#1,fix(#2),#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((t (array t) fixnum) t #.(flags set)"(#1)->v.v_self[#2]= (#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((character (array character) fixnum) character #.(flags rfa set)"(#1)->ust.ust_self[#2]= (#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((fixnum (array fixnum) fixnum) fixnum #.(flags set rfa)"(#1)->fixa.fixa_self[#2]= (#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((fixnum (array signed-short) fixnum) fixnum #.(flags rfa set)"((short *)(#1)->ust.ust_self)[#2]=(#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((fixnum (array signed-char) fixnum) fixnum #.(flags rfa set)"((#1)->ust.ust_self)[#2]=(#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((fixnum (array unsigned-short) fixnum) fixnum #.(flags rfa set) ;; "((unsigned short *)(#1)->ust.ust_self)[#2]=(#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((fixnum (array unsigned-char) fixnum) fixnum #.(flags rfa set)"((#1)->ust.ust_self)[#2]=(#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((short-float (array short-float) fixnum) short-float #.(flags rfa set)"(#1)->sfa.sfa_self[#2]= (#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((long-float (array long-float) fixnum) long-float #.(flags rfa set)"(#1)->lfa.lfa_self[#2]= (#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((t t t t) t #.(flags set) ;; "@1;aset(#1,fix(#2)*(#1)->a.a_dims[1]+fix(#3),#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((t (array t) fixnum fixnum) t #.(flags set) ;; "@1;(#1)->a.a_self[(#2)*(#1)->a.a_dims[1]+#3]= (#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((character (array character) fixnum fixnum) character ;; #.(flags rfa set) ;; "@1;(#1)->ust.ust_self[(#2)*(#1)->a.a_dims[1]+#3]= (#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((fixnum (array fixnum) fixnum fixnum) fixnum #.(flags set rfa) ;; "@1;(#1)->fixa.fixa_self[(#2)*(#1)->a.a_dims[1]+#3]= (#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((short-float (array short-float) fixnum fixnum) short-float #.(flags rfa set) ;; "@1;(#1)->sfa.sfa_self[(#2)*(#1)->a.a_dims[1]+#3]= (#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((long-float (array long-float) fixnum fixnum) long-float #.(flags rfa set) ;; "@1;(#1)->lfa.lfa_self[(#2)*(#1)->a.a_dims[1]+#3]= (#0)") ;; (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)"(code_char((#0)->ust.ust_self[#1]= char_code(#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) seqind #.(flags rfa set)"(((#0)->st.st_fillp)=(((#0)->st.st_hasfillp) ? (#1) : ((#0)->st.st_fillp)))") (get 'system:fill-pointer-set 'inline-unsafe)) (push '(((vector) seqind) seqind #.(flags rfa set)"(((#0)->st.st_fillp)=(((#0)->st.st_hasfillp) ? (#1) : ((#0)->st.st_fillp)))") (get 'system:fill-pointer-set 'inline-always)) ;;SYSTEM:FIXNUMP ;; (push '((t) boolean #.(flags rfa)"type_of(#0)==t_fixnum") ;; (get 'system:fixnump 'inline-always)) ;; (push '((fixnum) boolean #.(flags rfa)"1") ;; (get 'system:fixnump 'inline-always)) ;;SYSTEM:SEQINDP ;; (push '((t) boolean #.(flags rfa) #.(format nil "(type_of(#0)==t_fixnum && ({fixnum _t=fix(#0);_t>=0 && _t<=~s;}))" array-dimension-limit)) ;; (get 'system::seqindp 'inline-always)) ;; (push '((fixnum) boolean #.(flags rfa)#.(format nil "(#0>=0 && #0<=~s)" array-dimension-limit)) ;; (get 'system::seqindp 'inline-always)) ;; (push '((seqind) boolean #.(flags rfa)"1") ;; (get 'system::seqindp 'inline-always)) ;;SYSTEM:HASH-SET (push '((t t t) t #.(flags rfa) "@2;(sethash(#0,#1,#2),#2)") (get 'si::hash-set 'inline-always));FIXME ;(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)"(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)"(code_char((#0)->ust.ust_self[#1]= char_code(#2)))") (get 'system:schar-set 'inline-unsafe)) ;;SYSTEM:SET-MV (push '((fixnum t) t #.(flags)"(MVloc[(#0)]=(#1))") (get 'system:set-mv 'inline-always)) ;;SYSTEM:SPUTPROP (push '((symbol t t) t #.(flags set)"fSsputprop(#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)) (push '((structure) structure #.(flags)"(#0)->str.str_def") (get 'system:structure-def 'inline-always)) ;;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: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)) ;;ASH ;(si::putprop 'ash 'ash-propagator 'type-propagator) (push '((t t) t #.(compiler::flags) "immnum_shft(#0,#1)") (get 'ash 'compiler::inline-always)) (push '(((integer 0 0) t) fixnum #.(flags rfa)"0") (get 'ash 'inline-always)) (push '((fixnum (integer 0 #.(integer-length most-positive-fixnum))) fixnum #.(flags)"((#0)<<(#1))") (get 'ash 'inline-always)) (push '((fixnum (integer #.most-negative-fixnum 0)) fixnum #.(flags set) #.(concatenate 'string "@1;(-(#1)&" (write-to-string (logxor -1 (integer-length most-positive-fixnum))) "? ((#0)>=0 ? 0 : -1) : (#0)>>-(#1))")) (get 'ash 'inline-always)) ;;+ (push '((t t) t #.(flags ans)"immnum_plus(#0,#1)") (get 'si::number-plus 'inline-always)) (push '((cnum cnum) cnum #.(flags)"(#0)+(#1)") (get 'si::number-plus 'inline-always)) ;;- ;(push '((t) t #.(flags ans)"immnum_negate(#0)") (get '- 'inline-always)) ;(push '((cnum) cnum #.(flags)"-(#0)") (get '- 'inline-always)) ;(push '(((integer #.most-negative-fixnum #.most-negative-fixnum)) t #.(flags)"immnum_negate(#0)") (get '- 'inline-always)) (push '((t t) t #.(flags ans)"immnum_minus(#0,#1)") (get 'si::number-minus 'inline-always)) (push '((cnum cnum) cnum #.(flags)"(#0)-(#1)") (get 'si::number-minus 'inline-always)) (push '(((integer 0 0) t) t #.(flags ans)"immnum_negate(#1)") (get 'si::number-minus 'inline-always)) (push '(((integer 0 0) cnum) cnum #.(flags ans)"-(#1)") (get 'si::number-minus 'inline-always)) ;;* ;(si::putprop '* 'super-range 'type-propagator) (push '((t t) t #.(flags ans)"immnum_times(#0,#1)") (get 'si::number-times 'inline-always)) (push '((fixnum fixnum) integer #.(flags ans rfa)"safe_mul(#0,#1)") (get 'si::number-times 'inline-always)) (push '((cnum cnum) cnum #.(flags)"(#0)*(#1)") (get 'si::number-times 'inline-always)) ;;/ (push '((t t) t #.(flags ans) "number_divide(#0,#1)") (get 'si::number-divide 'inline-always)) (push '((cnum cnum) cnum #.(flags) "(#0)/(#1)") (get 'si::number-divide 'inline-always)) ;;/= (push '((t t) boolean #.(flags rfa)"immnum_ne(#0,#1)") (get '/= 'inline-always)) (push '((cnum cnum) boolean #.(flags rfa)"(#0)!=(#1)") (get '/= 'inline-always)) ;;< (push '((t t) boolean #.(flags rfa)"immnum_lt(#0,#1)") (get '< 'inline-always)) (push '((creal creal) boolean #.(flags rfa)"(#0)<(#1)") (get '< 'inline-always)) ;;compiler::objlt (push '((t t) boolean #.(flags rfa)"((object)(#0))<((object)(#1))") (get 'si::objlt 'inline-always)) ;;<= (push '((t t) boolean #.(flags rfa)"immnum_le(#0,#1)") (get '<= 'inline-always)) (push '((creal creal) boolean #.(flags rfa)"(#0)<=(#1)") (get '<= 'inline-always)) ;;= (push '((t t) boolean #.(flags rfa)"immnum_eq(#0,#1)") (get '= 'inline-always)) (push '((cnum cnum) boolean #.(flags rfa)"(#0)==(#1)") (get '= 'inline-always)) ;;> (push '((t t) boolean #.(flags rfa)"immnum_gt(#0,#1)") (get '> 'inline-always)) (push '((creal creal) boolean #.(flags rfa)"(#0)>(#1)") (get '> 'inline-always)) ;;>= (push '((t t) boolean #.(flags rfa)"immnum_ge(#0,#1)") (get '>= 'inline-always)) (push '((creal creal) boolean #.(flags rfa)"(#0)>=(#1)") (get '>= 'inline-always)) ;;APPEND ;; (push '((t t) t #.(flags ans)"append(#0,#1)") ;; (get 'append 'inline-always)) ;;ARRAY-DIMENSION ;(push '((t fixnum) fixnum #.(flags rfa)"@01;(type_of(#0)==t_array ? (#0)->a.a_dims[(#1)] : (#0)->v.v_dim)") ; (get 'array-dimension 'inline-unsafe)) ;;CMP-ARRAY-DIMENSION ;; (setf (symbol-function 'cmp-array-dimension) (symbol-function 'array-dimension)) ;; (push '(cmp-array-dimension-inline-types nil #.(flags itf) cmp-array-dimension-inline) ;; (get 'cmp-array-dimension 'inline-always)) ;;ARRAY-TOTAL-SIZE (push '((t) fixnum #.(flags rfa)"((#0)->st.st_dim)") (get 'array-total-size 'inline-unsafe)) ;;ARRAYP (push '((t) boolean #.(flags rfa) "@0;({enum type _tp=type_of(#0);_tp>=t_string && _tp<=t_array;})") (get 'arrayp 'inline-always)) ;;ATOM (push '((t) boolean #.(flags rfa)"atom(#0)") (get 'atom 'inline-always)) ;;BIT-VECTOR-P (push '((t) boolean #.(flags rfa)"({enum type tp=type_of(#0);tp==t_bitvector||tp==t_simple_bitvector;})") (get 'bit-vector-p 'inline-always)) ;;HASH-TABLE-P (push '((t) boolean #.(flags)"(type_of(#0)==t_hashtable)") (get 'hash-table-p 'inline-always)) ;;RANDOM-STATE-P (push '((t) boolean #.(flags)"(type_of(#0)==t_random)") (get 'random-state-p 'inline-always)) ;;RANDOM-STATE-P (push '((t) boolean #.(flags)"(type_of(#0)==t_random)") (get 'random-state-p 'inline-always)) ;;PACKAGEP (push '((t) boolean #.(flags)"(type_of(#0)==t_package)") (get 'packagep 'inline-always)) ;;STREAMP (push '((t) boolean #.(flags)"(type_of(#0)==t_stream)") (get 'streamp 'inline-always)) ;;READTABLEP (push '((t) boolean #.(flags)"(type_of(#0)==t_readtable)") (get 'readtablep 'inline-always)) ;;COMPOUND PREDICATES ;; (dolist (l '(integerp rationalp floatp realp numberp vectorp arrayp compiled-function-p)) ;; (push ;; `((t) boolean #.(flags) ,(substitute #\_ #\- (concatenate 'string (string-downcase l) "(#0)"))) ;; (get l 'inline-always))) ;;BOUNDP (push '((t) boolean #.(flags rfa)"(#0)->s.s_dbind!=OBJNULL") (get 'boundp 'inline-unsafe)) (push '((symbol) boolean #.(flags rfa)"(#0)->s.s_dbind!=OBJNULL") (get 'boundp 'inline-always)) ;;CONS-CAR ; (push '((list) t #.(flags rfa)"(#0)->c.c_car") (get 'si::cons-car 'inline-always)) ;;CONS-CDR ; (push '((list) t #.(flags rfa)"(#0)->c.c_cdr") (get 'si::cons-cdr 'inline-always)) ;;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) character #.(flags rfa)"code_char((#0)->ust.ust_self[fix(#1)])") (get 'char 'inline-unsafe)) ;;CHAR-CODE ; (push '((character) fixnum #.(flags rfa)"(#0)") ; (get 'char-code 'inline-always)) ;;CHAR/= (push '((t t) boolean #.(flags rfa)"!eql(#0,#1)") (get 'char/= 'inline-unsafe)) (push '((t t) boolean #.(flags rfa)"char_code(#0)!=char_code(#1)") (get 'char/= 'inline-unsafe)) (push '((character character) boolean #.(flags rfa)"(#0)!=(#1)") (get 'char/= 'inline-unsafe)) ;;CHAR< (push '((character character) boolean #.(flags rfa)"(#0)<(#1)") (get 'char< 'inline-always)) ;;CHAR<= (push '((character character) boolean #.(flags rfa)"(#0)<=(#1)") (get 'char<= 'inline-always)) ;;CHAR= (push '((t t) boolean #.(flags rfa)"eql(#0,#1)") (get 'char= 'inline-unsafe)) (push '((t t) boolean #.(flags rfa)"char_code(#0)==char_code(#1)") (get 'char= 'inline-unsafe)) (push '((character character) boolean #.(flags rfa)"(#0)==(#1)") (get 'char= 'inline-unsafe)) ;;CHAR> (push '((character character) boolean #.(flags rfa)"(#0)>(#1)") (get 'char> 'inline-always)) ;;CHAR>= (push '((character character) boolean #.(flags rfa)"(#0)>=(#1)") (get 'char>= 'inline-always)) ;;CHARACTERP (push '((t) boolean #.(flags rfa)"type_of(#0)==t_character") (get 'characterp 'inline-always)) ;;RPLACA (push '((cons t) t #.(flags)"@0;((#0)->c.c_car=(#1),(#0))") (get 'rplaca 'inline-always)) (push '((t t) t #.(flags)"@0;((#0)->c.c_car=(#1),(#0))") (get 'rplaca 'inline-unsafe)) ;;RPLACD (push '((cons t) t #.(flags)"@0;((#0)->c.c_cdr=(#1),(#0))") (get 'rplacd 'inline-always)) (push '((t t) t #.(flags)"@0;((#0)->c.c_cdr=(#1),(#0))") (get 'rplacd 'inline-unsafe)) ;;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 rfa)"consp(#0)") (get 'consp 'inline-always)) ;;DIGIT-CHAR-P ; (push '((character) (or null (integer 0 9)) #.(flags rfa)"@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)) ;;ENDP (push '((t) boolean #.(flags rfa)"endp(#0)") (get 'endp 'inline-safe)) ;(push '((t) boolean #.(flags rfa)"(#0)==Cnil") ; (get 'endp 'inline-unsafe)) ;;EQ (push '((t t) boolean #.(flags rfa)"(#0)==(#1)") (get 'eq 'inline-always)) (push '((cnum cnum) 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 '((cnum cnum) boolean #.(flags rfa)"(#0)==(#1)") (get 'eql 'inline-always)) (push '((character character) boolean #.(flags rfa)"(#0)==(#1)") (get 'eql 'inline-always)) ;;FIXME -- floats? ;;EQUAL (push '((t t) boolean #.(flags rfa)"equal(#0,#1)") (get 'equal 'inline-always)) (push '((cnum cnum) boolean #.(flags rfa)"(#0)==(#1)") (get 'equal 'inline-always)) (push '((character character) 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)) (push '((short-float short-float) boolean #.(flags rfa)"(#0)==(#1)") (get 'equalp 'inline-always)) (push '((long-float long-float) boolean #.(flags rfa)"(#0)==(#1)") (get 'equalp 'inline-always)) (push '((character character) 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) "fixnum_expt((#0),(#1))") (get 'expt 'inline-always)) (push `(((integer 2 2) fixnum) fixnum #.(flags) "(1L<<(#1))") (get 'expt 'inline-always)) ;; ;;si::FILL-POINTER-INTERNAL ;; (push '((t) seqind #.(flags rfa)"((#0)->v.v_fillp)") ;; (get 'si::fill-pointer-internal 'inline-unsafe)) ;; (push '((vector) seqind #.(flags rfa)"((#0)->v.v_fillp)") ;; (get 'si::fill-pointer-internal 'inline-always)) ;;ARRAY-HAS-FILL-POINTER-P (push '((t) boolean #.(flags rfa)"((#0)->v.v_hasfillp)") (get 'array-has-fill-pointer-p 'inline-unsafe)) (push '((vector) boolean #.(flags rfa)"((#0)->v.v_hasfillp)") (get 'array-has-fill-pointer-p 'inline-always)) ;;FIRST ;; (push '((t) t #.(flags)"car(#0)") ;; (get 'first 'inline-safe)) ;(push '((t) t #.(flags)"CMPcar(#0)") ; (get 'first 'inline-unsafe)) ;;FLOATP (push '((t) boolean #.(flags rfa) "@0;type_of(#0)==t_shortfloat||type_of(#0)==t_longfloat") (get 'floatp 'inline-always)) ;;FLOOR ; (push '((fixnum fixnum) fixnum #.(flags rfa) ; "@01;(#0>=0&&(#1)>0?(#0)/(#1):ifloor(#0,#1))") ; (get 'floor 'inline-always)) ;(si::putprop 'floor 'floor-propagator 'type-propagator) (push '((t t) t #.(compiler::flags) "immnum_floor(#0,#1)") (get 'floor 'compiler::inline-always)) #+intdiv (push '((fixnum fixnum) (returns-exactly fixnum fixnum) #.(flags rfa set) "@01;({fixnum _t=(#0)/(#1);_t=((#0)<=0 && (#1)<=0) || ((#0)>=0 && (#1)>=0) || ((#1)*_t==(#0)) ? _t : _t-1;@1((#0)-_t*(#1))@ _t;})") (get 'floor 'inline-always)) ;;CEILING ;(si::putprop 'ceiling 'floor-propagator 'type-propagator) (push '((t t) t #.(compiler::flags) "immnum_ceiling(#0,#1)") (get 'ceiling 'compiler::inline-always)) #+intdiv (push '((fixnum fixnum) (returns-exactly fixnum fixnum) #.(flags rfa set) "@01;({fixnum _t=(#0)/(#1);_t=((#0)<=0 && (#1)>=0) || ((#0)>=0 && (#1)<=0) || ((#1)*_t==(#0)) ? _t : _t+1;@1((#0)-_t*(#1))@ _t;})") (get 'ceiling 'inline-always)) ;;SI::POWM (push '((t t t) t #.(flags)"powm_bbb(#0,#1,#2)") (get 'si::powm 'inline-unsafe)) (push '((fixnum t t) t #.(flags)"powm_fbb(#0,#1,#2)") (get 'si::powm 'inline-unsafe)) (push '((t fixnum t) t #.(flags)"powm_bfb(#0,#1,#2)") (get 'si::powm 'inline-unsafe)) (push '((t t fixnum) t #.(flags)"powm_bbf(#0,#1,#2)") (get 'si::powm 'inline-unsafe)) (push '((fixnum fixnum t) t #.(flags)"powm_ffb(#0,#1,#2)") (get 'si::powm 'inline-unsafe)) (push '((fixnum t fixnum) t #.(flags)"powm_fbf(#0,#1,#2)") (get 'si::powm 'inline-unsafe)) (push '((t fixnum fixnum) t #.(flags)"powm_bff(#0,#1,#2)") (get 'si::powm 'inline-unsafe)) (push '((fixnum fixnum fixnum) t #.(flags)"powm_fff(#0,#1,#2)") (get 'si::powm 'inline-unsafe)) ;;FOURTH ;; (push '((t) t #.(flags)"cadddr(#0)") ;; (get 'fourth 'inline-safe)) ;(push '((t) t #.(flags)"CMPcadddr(#0)") ; (get 'fourth 'inline-unsafe)) ;;FIFTH ;; (push '((t) t #.(flags)"cadr(cdddr(#0))") ;; (get 'fifth 'inline-safe)) ;(push '((t) t #.(flags)"CMPcadr(CMPcdddr(#0))") ; (get 'fifth 'inline-unsafe)) ;;SIXTH ;; (push '((t) t #.(flags)"caddr(cdddr(#0))") ;; (get 'sixth 'inline-safe)) ;(push '((t) t #.(flags)"CMPcaddr(CMPcdddr(#0))") ; (get 'sixth 'inline-unsafe)) ;;SEVENTH ;; (push '((t) t #.(flags)"cadddr(cdddr(#0))") ;; (get 'seventh 'inline-safe)) ;(push '((t) t #.(flags)"CMPcadddr(CMPcdddr(#0))") ; (get 'seventh 'inline-unsafe)) ;;EIGHTH ;; (push '((t) t #.(flags)"cadr(cdddr(cdddr(#0)))") ;; (get 'eighth 'inline-safe)) ;(push '((t) t #.(flags)"CMPcadr(CMPcdddr(CMPcdddr(#0)))") ; (get 'eighth 'inline-unsafe)) ;;NINTH ;; (push '((t) t #.(flags)"caddr(cdddr(cdddr(#0)))") ;; (get 'ninth 'inline-safe)) ;(push '((t) t #.(flags)"CMPcaddr(CMPcdddr(CMPcdddr(#0)))") ; (get 'ninth 'inline-unsafe)) ;;TENTH ;; (push '((t) t #.(flags)"cadddr(cdddr(cdddr(#0)))") ;; (get 'tenth 'inline-safe)) ;(push '((t) t #.(flags)"CMPcadddr(CMPcdddr(CMPcdddr(#0)))") ; (get 'tenth '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 rfa) "@0;({enum type _tp=type_of(#0);_tp==t_fixnum||_tp==t_bignum;})") (get 'integerp 'inline-always)) (push '((fixnum) boolean #.(flags rfa)"1") (get 'integerp 'inline-always)) ;;KEYWORDP (push '((t) boolean #.(flags rfa) "@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 '((vector) seqind #.(flags rfa)"((#0)->v.v_hasfillp ? (#0)->v.v_fillp : (#0)->v.v_dim)") (get 'length 'inline-always)) ;;LIST (push '(nil t #.(flags)"Cnil") (get 'list 'inline-always)) (push '((t) t #.(flags ans)LIST-INLINE) (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)) ;;CONS (push '((t t) t #.(flags ans) CONS-INLINE) (get 'cons 'inline-always)) ;;LISTP (push '((t) boolean #.(flags rfa)"listp(#0)") (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)) ;;LOGANDC1 (push '((fixnum fixnum) fixnum #.(flags rfa)"(~(#0) & (#1))") (get 'logandc1 'inline-always)) ;;LOGANDC2 (push '((fixnum fixnum) fixnum #.(flags rfa)"((#0) & ~(#1))") (get 'logandc2 '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 '((seqind) proper-list #.(flags ans rfa) MAKE-LIST-INLINE) (get 'make-list 'inline-always)) (push '(((integer 0 0)) null #.(flags rfa) "Cnil") (get 'make-list 'inline-always)) ;;INTEGER-LENGTH (push '((t) t #.(compiler::flags) "immnum_length(#0)") (get 'integer-length 'compiler::inline-always)) (push '((fixnum) fixnum #.(flags rfa set) #.(format nil "({register fixnum _x=labs(#0),_t=~s;for (;_t>=0 && !((_x>>_t)&1);_t--);_t+1;})" (integer-length most-positive-fixnum))) (get 'integer-length 'inline-always)) ;;MAX (push '((t t) t #.(flags) "immnum_max(#0,#1)");"@01;(number_compare(#0,#1)>=0?(#0):#1)" (get 'max 'inline-always));FIXME ;(push '((t t) t #.(flags set)"@01;({register int _r=number_compare(#0,#1); fixnum_float_contagion(_r>=0 ? #0 : #1,_r>=0 ? #1 : #0);})") ; (get 'max 'inline-always)) (push '((creal creal) long-float #.(flags set)"@01;((double)((#0)>=(#1)?(#0):#1))") (get 'max 'inline-always)) (push '((creal creal) short-float #.(flags set)"@01;((float)((#0)>=(#1)?(#0):#1))") (get 'max 'inline-always)) (push '((creal creal) fixnum #.(flags set)"@01;((fixnum)((#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));FIXME ;(push '((t t) t #.(flags set)"@01;({register int _r=number_compare(#0,#1); fixnum_float_contagion(_r<=0 ? #0 : #1,_r<=0 ? #1 : #0);})") ; (get 'min 'inline-always)) (push '((creal creal) long-float #.(flags set)"@01;((double)((#0)<=(#1)?(#0):#1))") (get 'min 'inline-always)) (push '((creal creal) short-float #.(flags set)"@01;((float)((#0)<=(#1)?(#0):#1))") (get 'min 'inline-always)) (push '((creal creal) fixnum #.(flags set)"@01;((fixnum)((#0)<=(#1)?(#0):#1))") (get 'min 'inline-always)) ;;MOD (push '((t t) t #.(compiler::flags) "immnum_mod(#0,#1)") (get 'mod 'compiler::inline-always)) #+intdiv (push '((fixnum fixnum) fixnum #.(flags rfa set)"@01;({register fixnum _t=(#0)%(#1);((#1)<0 && _t<=0) || ((#1)>0 && _t>=0) ? _t : _t + (#1);})") (get 'mod 'inline-always)) ;;CMP-NTHCDR (push '((seqind t) list #.(flags rfa)"({register fixnum _i=#0;register object _x=#1;for (;_i--;_x=_x->c.c_cdr);_x;})") (get 'cmp-nthcdr 'inline-unsafe)) (push '(((not seqind) proper-list) null #.(flags rfa)"Cnil") (get 'cmp-nthcdr 'inline-unsafe)) (push '((seqind proper-list) proper-list #.(flags rfa)"({register fixnum _i=#0;register object _x=#1;for (;_i--;_x=_x->c.c_cdr);_x;})") (get 'cmp-nthcdr 'inline-always)) (push '(((and (integer 0) (not seqind)) proper-list) null #.(flags rfa)"Cnil") (get 'cmp-nthcdr 'inline-always)) ;;NULL (push '((t) boolean #.(flags rfa)"(#0)==Cnil") (get 'null 'inline-always)) ;;RATIONALP (push '((t) boolean #.(flags rfa)"@0;rationalp(#0)") (get 'rationalp 'inline-always)) ;;REALP (push '((t) boolean #.(flags rfa)"@0;realp(#0)") (get 'realp 'inline-always)) ;;NUMBERP (push '((t) boolean #.(flags rfa)"@0;numberp(#0)") (get 'numberp 'inline-always)) ;;EQL-IS-EQ (push '((t) boolean #.(flags rfa)"@0;eql_is_eq(#0)") (get 'eql-is-eq 'inline-always)) (push '((fixnum) boolean #.(flags rfa)"@0;(is_imm_fix(#0))") (get 'eql-is-eq 'inline-always)) ;;EQUAL-IS-EQ (push '((t) boolean #.(flags rfa)"@0;equal_is_eq(#0)") (get 'equal-is-eq 'inline-always)) (push '((fixnum) boolean #.(flags rfa)"@0;(is_imm_fix(#0))") (get 'equal-is-eq 'inline-always)) ;;EQUALP-IS-EQ (push '((t) boolean #.(flags rfa)"@0;equalp_is_eq(#0)") (get 'equalp-is-eq '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)) ;;RATIOP (push '((t) boolean #.(flags rfa) "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)) #+intdiv (push '((fixnum fixnum) fixnum #.(flags rfa)"(#0)%(#1)") (get 'rem '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) character #.(flags rfa)"code_char((#0)->ust.ust_self[fix(#1)])") (get 'schar 'inline-unsafe)) (push '((t fixnum) character #.(flags rfa)"code_char((#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)) ;;STRING (push '((t) t #.(flags ans)"coerce_to_string(#0)") (get 'string 'inline-always)) ;;PATHNAME-DESIGNATORP (push '((t) boolean #.(flags)"pathname_designatorp(#0)") (get 'si::pathname-designatorp 'inline-always)) ;;PATHNAMEP (push '((t) boolean #.(flags)"type_of(#0)==t_pathname") (get 'pathnamep 'inline-always)) ;;STRINGP (push '((t) boolean #.(flags rfa)"({enum type tp=type_of(#0);tp==t_string||tp==t_simple_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) string #.(flags ans rfa)"symbol_name(#0)") (get 'symbol-name 'inline-always)) ;;SYMBOL-VALUE (push '((t) t #.(flags) "((#0)->s.s_dbind)") (get 'symbol-value 'inline-unsafe)) ;;SYMBOL-FUNCTION FIXME (push '((t) (or cons function) #.(flags rfa) "({register object _sym=#0;_sym->s.s_sfdef!=NOT_SPECIAL ? make_cons(sLspecial,make_fixnum((long)_sym->s.s_sfdef)) : (_sym->s.s_mflag ? make_cons(sSmacro,_sym->s.s_gfdef) : _sym->s.s_gfdef);})") (get 'symbol-function 'inline-unsafe)) ;;FUNCALLABLE-SYMBOL-FUNCTION (push '((t) function #.(flags rfa) "#0->s.s_gfdef") (get 'funcallable-symbol-function 'inline-always)) ;;SI::FBOUNDP-SYM (push '((t) boolean #.(flags rfa) "@0;(#0->s.s_sfdef!=NOT_SPECIAL || #0->s.s_gfdef!=OBJNULL)") (get 'si::fboundp-sym 'inline-unsafe)) (push '((symbol) boolean #.(flags rfa) "@0;(#0->s.s_sfdef!=NOT_SPECIAL || #0->s.s_gfdef!=OBJNULL)") (get 'si::fboundp-sym '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)) #+intdiv (push '((fixnum fixnum) (returns-exactly fixnum fixnum) #.(flags rfa)"({fixnum _t=(#0)/(#1);@1(#0)-_t*(#1)@ _t;})") (get 'truncate 'inline-always)) (push '((fixnum) (returns-exactly fixnum fixnum) #.(flags rfa)"({fixnum _t=(#0);@1(#0)-_t@ _t;})") (get 'truncate 'inline-always)) (push '((short-float) (returns-exactly fixnum short-float) #.(flags rfa)"({float _t=(#0);@1(#0)-_t@ _t;})") (get 'truncate 'inline-always)) (push '((long-float) (returns-exactly fixnum long-float) #.(flags rfa)"({double _t=(#0);@1(#0)-_t@ _t;})") (get 'truncate 'inline-always)) ;;COMPLEXP (push '((t) boolean #.(flags rfa) "type_of(#0)==t_complex") (get 'complexp 'inline-always)) ;;COMPLEX (push '((t t) complex #.(flags) "make_complex(#0,#1)") (get 'complex 'inline-always)) (push '((short-float short-float) fcomplex #.(flags) "(#0 + I * #1)") (get 'complex 'inline-always)) (push '((long-float long-float) dcomplex #.(flags) "(#0 + I * #1)") (get 'complex 'inline-always)) ;;VECTORP (push '((t) boolean #.(flags rfa) "@0;({enum type _tp=type_of(#0);_tp>=t_string && _tp<=t_vector;})") (get 'vectorp 'inline-always)) ;;SEQUENCEP (push '((t) boolean #.(flags rfa) "@0;(listp(#0) || ({enum type _tp=type_of(#0);_tp>=t_string && _tp<=t_vector;}))") (get 'sequencep 'inline-always)) ;;FUNCTIONP (push '((t) boolean #.(flags rfa) "(functionp(#0))") (get 'functionp 'inline-always)) ;;COMPILED-FUNCTION-P (push '((t) boolean #.(flags rfa) "(compiled_functionp(#0))") (get 'compiled-function-p 'inline-always)) ;;WRITE-CHAR (push '((t) t #.(flags set) "@0;(writec_stream(char_code(#0),sLAstandard_outputA->s.s_dbind),(#0))") (get 'write-char 'inline-unsafe)) ;;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)) ;;SI::NEXT-HASH-TABLE-INDEX (push '((t t) fixnum #.(flags rfa) "({fixnum _i;for (_i=fix(#1);_i<(#0)->ht.ht_size && (#0)->ht.ht_self[_i].hte_key==OBJNULL;_i++);_i==(#0)->ht.ht_size ? -1 : _i;})") (get 'si::next-hash-table-index 'inline-unsafe)) (push '((t fixnum) fixnum #.(flags rfa) "({fixnum _i;for (_i=(#1);_i<(#0)->ht.ht_size && (#0)->ht.ht_self[_i].hte_key==OBJNULL;_i++);_i==(#0)->ht.ht_size ? -1 : _i;})") (get 'si::next-hash-table-index 'inline-unsafe)) ;;SI::HASH-ENTRY-BY-INDEX (push '((t t) t #.(flags) "(#0)->ht.ht_self[fix(#1)].hte_value") (get 'si::hash-entry-by-index 'inline-unsafe)) (push '((t fixnum) t #.(flags) "(#0)->ht.ht_self[(#1)].hte_value") (get 'si::hash-entry-by-index 'inline-unsafe)) ;;SI::HASH-KEY-BY-INDEX (push '((t t) t #.(flags) "(#0)->ht.ht_self[fix(#1)].hte_key") (get 'si::hash-key-by-index 'inline-unsafe)) (push '((t fixnum) t #.(flags) "(#0)->ht.ht_self[(#1)].hte_key") (get 'si::hash-key-by-index 'inline-unsafe)) ;;si::GENSYM0 (push '(nil symbol #.(flags ans set rfa) "fSgensym0()") (get 'si::gensym0 'inline-always)) ;;si::GENSYM1S (push '((string) symbol #.(flags ans set rfa) "fSgensym1s(#0)") (get 'si::gensym1s 'inline-always)) ;;si::GENSYM1IG (push '((t) symbol #.(flags ans set rfa) "fSgensym1ig(#0)") (get 'si::gensym1ig 'inline-always)) ;;SI::HASH-SET (push '((t t t) t #.(flags) "@2;(sethash(#0,#1,#2),#2)") (get 'si::hash-set 'inline-unsafe)) ;;New C ffi ;; ;(push '((t fixnum opaque *) opaque #.(flags rfa) "(#0(#1))(#2#*)") (get 'addr-call 'inline-always)) ;(push '((t fixnum) opaque #.(flags rfa) "(#0(#1))()") (get 'addr-call 'inline-always)) (push '(((member :address) t) fixnum #.(flags rfa) "object_to_fixnum(#1)") (get 'unbox 'inline-always)) (push '(((member :address) fixnum) fixnum #.(flags rfa) "(#1)") (get 'unbox 'inline-always)) ;; (defun register-key (l tt) ;; (push `(((member ,l) t t t) ,tt ,(flags rfa) "((#1)->#2.#3)") ;; (get 'el 'inline-always)) ;; (push `(((member ,l) t t t seqind) ,tt ,(flags rfa) "((#1)->#2.#3[#4])") ;; (get 'el 'inline-always)) ;; (push `((,tt (member ,l) t t t) ,tt ,(flags rfa) "((#2)->#3.#4=(#0))") ;; (get 'set-el 'inline-always)) ;; (push `((,tt (member ,l) t t t seqind) ,tt ,(flags rfa) "((#2)->#3.#4[#5]=(#0))") ;; (get 'set-el 'inline-always)) ;; ) (deftype stdesig nil '(or string symbol character)) (deftype longfloat nil 'long-float) (deftype shortfloat nil 'short-float) (deftype hashtable nil 'hash-table) (deftype ocomplex nil 'complex) (deftype bitvector nil 'bit-vector) (deftype random nil 'random-state) (deftype cfun nil 'function);FIXME ; (deftype cclosure nil 'function);FIXME ; (deftype closure nil 'function);FIXME ; (deftype sfun nil 'function);FIXME (deftype ifun nil 'function);FIXME ; (deftype vfun nil 'function);FIXME (deftype ustring nil 'string);FIXME (deftype fixarray nil '(array fixnum)) (deftype sfarray nil '(array short-float)) (deftype lfarray nil '(array long-float)) ;;si::c-type (push '((t) #.(cmp-unnorm-tp (c-type-propagator 'si::c-type #tt)) #.(flags rfa) "type_of(#0)") (get 'si::c-type 'inline-always)) (push '((long-float) short-float #.(flags rfa) "((float)#0)" ) (get 'si::long-to-short 'inline-always)) (push '((t) short-float #.(flags) "((float)lf(#0))" ) (get 'si::long-to-short 'inline-unsafe)) (push '((long-float) short-float #.(flags rfa) "((float)#0)" ) (get 'si::long-to-short 'inline-unsafe)) (push '((bignum) long-float #.(flags) "big_to_double(#0)" ) (get 'si::big-to-double 'inline-always)) (push '((t) long-float #.(flags) "big_to_double(#0)" ) (get 'si::big-to-double 'inline-unsafe)) (push '((bignum) long-float #.(flags) "big_to_double(#0)" ) (get 'si::big-to-double 'inline-unsafe)) (push '(((complex)) t #.(flags) "(#0)->cmp.cmp_real") (get 'complex-real 'inline-always)) (push '((fcomplex) short-float #.(flags) "creal(#0)") (get 'complex-real 'inline-always)) (push '((dcomplex) long-float #.(flags) "creal(#0)") (get 'complex-real 'inline-always)) (push '((t) t #.(flags) "(#0)->cmp.cmp_real") (get 'complex-real 'inline-unsafe));FIXME (push '((fcomplex) short-float #.(flags) "creal(#0)") (get 'complex-real 'inline-unsafe)) (push '((dcomplex) long-float #.(flags) "creal(#0)") (get 'complex-real 'inline-unsafe)) (push '(((complex)) t #.(flags) "(#0)->cmp.cmp_imag") (get 'complex-imag 'inline-always)) (push '((fcomplex) short-float #.(flags) "cimag(#0)") (get 'complex-imag 'inline-always)) (push '((dcomplex) long-float #.(flags) "cimag(#0)") (get 'complex-imag 'inline-always)) (push '((t) t #.(flags) "(#0)->cmp.cmp_imag") (get 'complex-imag 'inline-unsafe));FIXME (push '((fcomplex) short-float #.(flags) "cimag(#0)") (get 'complex-imag 'inline-unsafe)) (push '((dcomplex) long-float #.(flags) "cimag(#0)") (get 'complex-imag 'inline-unsafe)) (push '((ratio) integer #.(flags rfa) "(#0)->rat.rat_num") (get 'ratio-numerator 'inline-always)) (push '((ratio) integer #.(flags rfa) "(#0)->rat.rat_den") (get 'ratio-denominator 'inline-always)) (push `((long-float) boolean #.(flags rfa) ,(lambda (x) (add-libc "isinf") (wt "(isinf(" x "))"))) (get 'si::isinf 'inline-always)) (push `((long-float) boolean #.(flags rfa) ,(lambda (x) (add-libc "isnan") (wt "(isnan(" x "))"))) (get 'si::isnan '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)) ;;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)) ;;LOGTEST (push '((t t) boolean #.(compiler::flags) "immnum_logt(#0,#1)") (get 'logtest 'compiler::inline-always)) ;LDB (push '(((cons fixnum fixnum) fixnum) fixnum #.(compiler::flags) "fixnum_ldb(fix(#0->c.c_car),fix(#0->c.c_cdr),#1)") (get 'ldb 'compiler::inline-always)) ;LDB-TEST (push '(((cons fixnum fixnum) fixnum) boolean #.(compiler::flags) "fixnum_ldb(fix(#0->c.c_car),fix(#0->c.c_cdr),#1)") (get 'ldb-test 'compiler::inline-always)) ;DPB (push '((fixnum (cons fixnum fixnum) fixnum) t #.(compiler::flags) "fixnum_dpb(fix(#1->c.c_car),fix(#1->c.c_cdr),#0,#2)") (get 'dpb 'compiler::inline-always)) ;DEPOSIT-FIELD (push '((fixnum (cons fixnum fixnum) fixnum) t #.(compiler::flags) "fixnum_dpf(fix(#1->c.c_car),fix(#1->c.c_cdr),#0,#2)") (get 'deposit-field 'compiler::inline-always)) ;;MINUSP (push '((t) boolean #.(flags) "immnum_minusp(#0)") (get 'minusp 'inline-always));"number_compare(small_fixnum(0),#0)>0" ;;PLUSP (push '((t) boolean #.(flags) "immnum_plusp(#0)") (get 'plusp 'inline-always));"number_compare(small_fixnum(0),#0)>0" ;;ZEROP (push '((t) boolean #.(flags) "immnum_zerop(#0)") (get 'zerop 'inline-always));"number_compare(small_fixnum(0),#0)==0" ;;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)) (setf (get :boolean 'lisp-type) 'boolean) (setf (get :void 'lisp-type) nil) (setf (get :cnum 'lisp-type) 'cnum) (setf (get :creal 'lisp-type) 'creal) (dolist (l '((:float "make_shortfloat" short-float cnum) (:double "make_longfloat" long-float cnum) (:character "code_char" character cnum) (:char "make_fixnum" char cnum) (:short "make_fixnum" short cnum) (:int "make_fixnum" int cnum) (:uchar "make_fixnum" unsigned-char cnum) (:ushort "make_fixnum" unsigned-short cnum) (:uint "make_fixnum" unsigned-int cnum) (:fixnum "make_fixnum" fixnum cnum) (:long "make_fixnum" fixnum cnum) (:fcomplex "make_fcomplex" fcomplex cnum) (:dcomplex "make_dcomplex" dcomplex cnum) (:string "make_simple_string" string) (:object "" t) (:float* nil nil (array short-float) "->sfa.sfa_self") (:double* nil nil (array long-float) "->lfa.lfa_self") (:long* nil nil (array fixnum) "->fixa.fixa_self") (:void* nil nil (array t) "->v.v_self"))) (setf (get (car l) 'lisp-type) (if (cadr l) (caddr l) (cadddr l))) (when (cadr l) (push `(((member ,(car l)) opaque) t #.(flags rfa) ,(strcat (cadr l) "(#1)")) (get 'box 'inline-always)) (push `(((member ,(car l)) t) opaque #.(flags rfa) ,(if (eq (car l) :object) "(#1)" (strcat "object_to_" (car l) "(#1)"))) (get 'unbox 'inline-always))) (when (cadddr l) (push `(((member ,(car l)) ,(cadddr l)) opaque #.(flags rfa) ,(if (fifth l) (strcat "(#1)" (fifth l)) (strcat "(" (car l) ")" "(#1)"))) (get 'unbox 'inline-always)))) (dolist (l '(char short long int integer keyword character real string structure symbol fixnum)) (let ((s (intern (symbol-name l) 'keyword))) (setf (get s 'lisp-type) l))) (dolist (l '((object t)(plist proper-list)(float short-float)(double long-float) (pack (or null package)) (direl (or keyword null string)))) (let ((s (intern (symbol-name (car l)) 'keyword))) (setf (get s 'lisp-type) (cadr l)))) (defvar *box-alist* (mapcar (lambda (x) (cons x (cadr (assoc (get x 'lisp-type) *c-types*)))) '(:char :fixnum :float :double :fcomplex :dcomplex))) (do-symbols (s :keyword) (let ((z (get s 'lisp-type :opaque))) (unless (eq z :opaque) (setf (get s 'cmp-lisp-type) (cmp-norm-tp z))))) gcl27-2.7.0/cmpnew/gcl_cmpspecial.lsp000077500000000000000000000641201454061450500174260ustar00rootroot00000000000000;;; 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 :execute) (return-from c1eval-when (c1progn (cdr args)))) ((load :load-toplevel compile :compile-toplevel)) (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 dtype);FIXME rethink this whole function (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 dtype (max-vtp (car args))) (when *compiler-new-safety* (setq dtype t)) (when (exit-to-fmla-p) (setq dtype (type-or1 (when (type-and #tnull dtype) #tnull) (when (type-and #t(not null) dtype) #ttrue))));FIXME (when (equal dtype #tboolean) (unless (type>= dtype (info-type info)) (return-from c1the (c1expr `(when ,(cadr args) t))))) (setq type (type-and dtype (info-type info))) (setq form (list* (car form) info (cddr form))) (if (type>= #tboolean dtype) (setf (info-type (cadr form)) type) (set-form-type form type)) ; (setf (info-type info) type) form) ;; (defun c1the (args &aux info form type dtype) ;; (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 dtype (max-vtp (car args))) ;; (when *compiler-new-safety* (setq dtype t)) ;; (when (eq dtype #tboolean) ;; (unless (type>= dtype (info-type info)) ;; (return-from c1the (c1expr `(when ,(cadr args) t))))) ;; (setq type (type-and dtype (info-type info))) ;; (when (null type) ;; (when (eq (car form) 'var) ;; (do-setq-tp (car (third form)) nil dtype)) ;; (setq type dtype) ;; (unless (not (and dtype (info-type info))) ;; (cmpwarn "Type mismatch was found in ~s.~%Modifying type ~s to ~s." ;; (cons 'the args) (info-type info) type))) ;; (setq form (list* (car form) info (cddr form))) ;; (if (type>= #tboolean dtype) (setf (info-type (cadr form)) type) (set-form-type form type)) ;; ; (setf (info-type info) type) ;; form) ;; (defun c1the (args &aux info form type dtype) ;; (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 dtype (max-vtp (car args))) ;; (when *compiler-new-safety* (setq dtype t)) ;; (when (eq dtype #tboolean) ;; (unless (type>= dtype (info-type info)) ;; (return-from c1the (c1expr `(when ,(cadr args) t))))) ;; (setq type (type-and dtype (info-type info))) ;; (when (null type) ;; (when (eq (car form) 'var) ;; (let* ((v (car (third form))) ;; (tg (t-to-nil (var-tag v)))) ;; (when tg ;; (unless (type>= (var-mt v) dtype) ;; (setf (var-mt v) (type-or1 (var-mt v) dtype)) ;; (let* ((nmt (bump-tp (var-mt v))) ;; (nmt (type-and nmt (var-dt v)))) ;; (setf (var-mt v) nmt)) ;; (pushnew v *tvc*) ;; (when (member (var-tag v) *catch-tags*) (throw (var-tag v) v)))))) ;; (setq type dtype) ;; (unless (not (and dtype (info-type info))) ;; (cmpwarn "Type mismatch was found in ~s.~%Modifying type ~s to ~s." ;; (cons 'the args) (info-type info) type))) ;; (setq form (list* (car form) info (cddr form))) ;; (if (type>= #tboolean dtype) (setf (info-type (cadr form)) type) (set-form-type form type)) ;; ; (setf (info-type info) type) ;; 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))) (defvar *fun-id-hash* (make-hash-table :test 'eq)) (defvar *fun-ev-hash* (make-hash-table :test 'eq)) (defvar *fun-tp-hash* (make-hash-table :test 'eq)) (defvar *fn-src-fn* (make-hash-table :test 'eq)) ;; (defun funid-to-fn1 (funid) ;; (cond ((symbolp funid) ;; (cond ((local-fun-fn funid)) ;; ((when (fboundp funid) (symbol-function funid))) ;; (funid (cmp-eval `(function (lambda (&rest r) ;; (declare (:dynamic-extent r)) ;; (apply ',funid r))))))) ;; ((gethash funid *fn-src-fn*)) ;; ((setf (gethash funid *fn-src-fn*) (cmp-eval `(function ,funid)))))) ;; (defun funid-to-fn1 (funid) ;; (cond ((symbolp funid) ;; (cond ((local-fun-fn funid)) ;; ((when (fboundp funid) (symbol-function funid))) ;; (funid (cmp-eval `(function (lambda (&rest r) ;; (declare (:dynamic-extent r)) ;; (apply ',funid r))))))) ;; ((cmp-eval `(function ,funid))))) ;; (defun funid-to-fn (funid) ;; (let ((fn (funid-to-fn1 funid))) ;; (setf (gethash fn *fun-id-hash*) funid) ;; fn)) ;; (defun funid-to-fun1 (id) ;; (cond ((let ((id (si::funid-sym-p id))) ;; (cond ((local-fun-fun id)) ;; ((when (fboundp id) (symbol-function id))) ;; (id (cmp-eval `(function (lambda (&rest r) ;; (declare (:dynamic-extent r)) ;; (apply ',id r)))))))) ;; ((functionp id) id) ;; ((cmp-eval `(function ,id))))) ;; (defun funid-to-fun (id) ;; (let ((fun (funid-to-fun1 id))) ;; (setf (gethash fun *fun-id-hash*) id) ;; fun)) ;; (defun portable-closure-src (fn) ;FIXME ;; (let* ((lam nil); (when (si::interpreted-function-p fn) (si::interpreted-function-lambda fn))) ;; (src (when lam (function-lambda-expression fn))) ;; (p (car (member-if-not ;; (lambda (x) ;; (eq x (car (member (var-name x) *vars* :key (lambda (x) (when (var-p x) (var-name x))))))) ;; (cadr lam))))) ;; (if p (keyed-cmpnote '(closure inline) ;; "Not inlining ~s due to redefinition of closure variable ~s." src (var-name p)) ;; src))) (defun coerce-to-funid (fn) (cond ((symbolp fn) fn) ((local-fun-p fn) fn) ((not (functionp fn)) nil) ((fn-get fn 'id)) ((si::function-name fn)))) ; ((portable-closure-src fn)) (defun find-special-var (l f) (when (consp l) (case (car l) (lambda (find-special-var (fifth l) f)) (decl-body (find-special-var (fourth l) f)) (let* (car (member-if f (third l))))))) ;; (defun find-special-var (l f &aux v) ;; (labels ((ccar (x) (when (listp x) (car x)))) ;; (cond ((funcall f l) l) ;; ((atom l) nil) ;; ((setq v (cadr (member 'bind-reg-clv l :key #'ccar))) ;; (when (eq 'let* (ccar v)) (find-special-var (caddr v) f))) ;; ((or (find-special-var (car l) f) (find-special-var (cdr l) f)))))) ;; (defun find-special-var (l f) ;; (cond ((funcall f l) l) ;; ((atom l) nil) ;; ((eq (car l) 'block) nil) ;; ((or (find-special-var (car l) f) (find-special-var (cdr l) f))))) (defun is-narg-le (l) (caadr (caddr l))) ;; (defun is-narg-le (l) ;; (find-special-var l 'is-narg-var)) (defun mv-var (l) (find-special-var l 'is-mv-var)) (defun fun-var (l) (find-special-var l 'is-fun-var)) (defun export-sig (sig) (unique-sigs `((,@(mapcar 'export-type (car sig))) ,(export-type (cadr sig))))) (defun mbt (tp &aux (atp (atomic-tp tp))) (if (and atp (consp (car atp))) (if (cdar atp) #tcons #tproper-cons) tp)) ;; (defun mbt (tp &aux (atp (atomic-tp tp))) ;; (cond (*compiler-new-safety* (if (single-type-p tp) #tt #t*)) ;; ((and atp (consp (car atp))) (if (cdar atp) #tcons #tproper-cons)) ;; (tp))) (defun lam-e-to-sig (l &aux (args (caddr l)) (regs (car args)) (regs (if (is-first-var (car regs)) (cdr regs) regs))) `((,@(mapcar 'var-type regs) ,@(when (or (is-narg-le l) (member-if 'identity (cdr args))) `(*))) ,(mbt (info-type (cadar (last l)))))) ;; (defun lam-e-to-sig (l &aux (args (caddr l)) (regs (car args)) (narg (is-narg-le l)) ;; (first (is-first-var (car regs))) (regs (if first (cdr regs) regs))) ;; `((,@(mapcar (lambda (x) (if *compiler-new-safety* #tt (var-type x))) regs) ;; ,@(when (or narg (member-if 'identity (cdr args))) `(*))) ;; ,(mbt (info-type (cadar (last l)))))) ;; (defun mbt (tp &aux (atp (atomic-tp tp))) ;; (if (and atp (consp (car atp))) ;; (if (cdar atp) #tcons #tproper-cons) ;; tp)) ;; (defun lam-e-to-sig (l &aux (args (caddr l)) (regs (car args)) (narg (is-narg-le l)) ;; (first (is-first-var (car regs))) (regs (if first (cdr regs) regs))) ;; `((,@(mapcar 'var-type regs) ;; ,@(when (or narg (member-if 'identity (cdr args))) `(*))) ;; ,(mbt (info-type (cadar (last l)))))) ;; (defun lam-e-to-sig (l &aux (args (caddr l)) (regs (car args)) (narg (is-narg-le l)) ;; (first (is-first-var (car regs))) (regs (if first (cdr regs) regs))) ;; `((,@(mapcar 'var-type regs) ;; ,@(when (or narg (member-if 'identity (cdr args))) `(*))) ;; ,(info-type (cadar (last l))))) (defun compress-fle (l y z) (let* ((fname (pop l)) (fname (or z fname)) (args (pop l)) (w (make-string-output-stream)) (out (pd fname args l)) (out (if y `(lambda-closure ,y nil nil ,@(cdr out)) out))) (if *compiler-compile* out (let ((ss (si::open-fasd w :output nil nil))) (si::find-sharing-top out (aref ss 1)) (si::write-fasd-top out ss) (si::close-fasd ss) (get-output-stream-string w))))) ;; (defun process-local-fun-env (env b f fun tp) ;; (under-env env (process-local-fun b f fun tp))) (defun fun-def-env (fn) (let ((fun (car (member-if (lambda (x) (when (fun-p x) (eq (fun-fn x) fn))) *funs*)))) (if fun (car (fourth (fun-c1 fun))) (current-env)))) (defun mc nil (let ((env (cons nil nil))) (lambda nil env))) (defun afe (a f) (push a (car (funcall f))) f) (defun fn-get (fn prop) (cdr (assoc prop (car (funcall fn))))) ;; (defun mc nil (let (env) (lambda nil env))) ;; (defun afe (a f) ;; (push a (car (fn-env f))) ;; f) (defun mf (id) (let* ((f (mc))) ; (when (consp id) (setf (caddr (si::call f)) (compress-fle id nil nil))) (afe (cons 'id id) f) (afe (cons 'df (current-env)) f) f)) ;; (defun fn-get (fn prop) ;; (cdr (assoc prop (car (fn-env fn))))) (defun funid-to-fn (funid &aux fun) (cond ((setq fun (local-fun-p funid)) (fun-fn fun)) ; ((gethash funid *fn-src-fn*)) ; ((setf (gethash funid *fn-src-fn*) (mf funid))) ((symbolp funid) (or (gethash funid *fn-src-fn*) (setf (gethash funid *fn-src-fn*) (mf funid)))) ((mf funid)) )) ;; (defun funid-to-fn (funid) ;; (or (local-fun-fn funid) (gethash funid *fn-src-fn*) (setf (gethash funid *fn-src-fn*) (mf funid)))) (defvar *prov* nil) (defun c1function (args &optional (b 'cb) f &aux fd) (when (endp args) (too-few-args 'function 1 0)) (unless (endp (cdr args)) (too-many-args 'function 1 (length args))) (let* ((funid (si::funid (car args))) (funid (if (consp funid) (effective-safety-src funid) funid)) (fn (afe (cons 'ce (current-env)) (funid-to-fn funid))) (tp (if fn (object-type fn) #tfunction)) (info (make-info :type tp))) (cond ((setq fd (c1local-fun funid t)) (add-info info (cadr fd)) `(function ,info ,fd)) ((symbolp funid) (setf (info-sp-change info) (if (null (get funid 'no-sp-change)) 1 0)) `(function ,info (call-global ,info ,funid))) ((let* ((fun (or f (make-fun :name 'lambda :src funid :c1cb t :fn fn :info (make-info :type '*)))) (fd (if *prov* (list fun) (process-local-fun b fun funid tp)))) (add-info info (cadadr fd)) (when *prov* (setf (info-flags info) (logior (info-flags info) (iflags provisional)))) `(function ,info ,fd)))))) ;; (defun c1function (args &optional (b 'cb) f &aux fd) ;; (when (endp args) (too-few-args 'function 1 0)) ;; (unless (endp (cdr args)) (too-many-args 'function 1 (length args))) ;; (let* ((funid (si::funid (car args))) ;; (funid (if (consp funid) (effective-safety-src funid) funid)) ;; (fn (afe (cons 'ce (current-env)) (funid-to-fn funid))) ;; (tp (if fn (object-type fn) #tfunction)) ;; (info (make-info :type tp))) ;; (cond ((setq fd (c1local-fun funid t)) ;; (add-info info (cadr fd)) ;; `(function ,info ,fd)) ;; ((symbolp funid) ;; (setf (info-sp-change info) (if (null (get funid 'no-sp-change)) 1 0)) ;; `(function ,info (call-global ,info ,funid))) ;; ((setq fd (process-local-fun b (or f (make-fun :name 'lambda :src funid :c1cb t :fn fn :info (make-info :type '*))) funid tp)) ;; (add-info info (cadadr fd)) ;; `(function ,info ,fd))))) ;; (defun c1function (args &optional (provisional *provisional-inline*) b f) ;; (when (endp args) (too-few-args 'function 1 0)) ;; (unless (endp (cdr args)) (too-many-args 'function 1 (length args))) ;; (let* ((funid (si::funid (car args))) ;; (fn (funid-to-fn funid)) ;; (tp (if fn (object-type fn) #tfunction)) ;; (info (make-info :type tp))) ;; (cond ((and provisional (not (when (symbolp funid) (not (local-fun-p funid)))));FIXME ;; (let* ((df (fun-def-env fn)) ;; (ce (current-env)) ;; (res (list 'provfn info args (list ce df)))) ;; (afe (cons 'ce ce) fn) ;; (afe (cons 'df df) fn) ;; (afe (cons 'prov res) fn) ;; res)) ;; ((symbolp funid) ;; (let ((fd (c1local-fun funid t))) ;; (unless fd ;; (setf (info-sp-change info) (if (null (get funid 'no-sp-change)) 1 0))) ;; (list 'function info (or fd (list 'call-global info funid))))) ;; ((let ((r (process-local-fun (or b 'cb) (or f (make-fun :name 'lambda :src funid :info (make-info :type '*))) funid tp))) ;; (add-info info (cadadr r)) ;; (setf (info-flags info) (logandc2 (info-flags info) (iflags side-effects))) ;; `(function ,info ,r)))))) ;; (defun c1function (args &optional (provisional *provisional-inline*) b f) ;; (when (endp args) (too-few-args 'function 1 0)) ;; (unless (endp (cdr args)) (too-many-args 'function 1 (length args))) ;; (let* ((funid (si::funid (car args))) ;; (fn (funid-to-fn funid)) ;; (tp (if fn (object-type fn) #tfunction)) ;; ; (tp (if fn (cmp-norm-tp `(member ,fn)) #tfunction)) ;; (info (make-info :type tp))) ;; (cond (provisional ;; (or ;(gethash fn *fun-tp-hash*) ;; (setf (gethash fn *fun-tp-hash*) ;; (list 'provfn info args ;; (setf (gethash fn *fun-ev-hash*) (list (current-env) (fun-def-env fn))))))) ;; ((symbolp funid) ;; (let ((fd (c1local-fun funid t))) ;; (unless fd ;; (setf (info-sp-change info) (if (null (get funid 'no-sp-change)) 1 0))) ;; (list 'function info (or fd (list 'call-global info funid))))) ;; ((let ((r (process-local-fun (or b 'cb) (or f (make-fun :name 'lambda :src funid :info (make-info :type '*))) funid tp))) ;; (add-info info (cadadr r)) ;; (setf (info-flags info) (logandc2 (info-flags info) (iflags side-effects))) ;; `(function ,info ,r)))))) ;; (defun c1function (args &optional (provisional *provisional-inline*) env) ;; (when (endp args) (too-few-args 'function 1 0)) ;; (unless (endp (cdr args)) (too-many-args 'function 1 (length args))) ;; (let* ((fun (car args)) ;; (fid (si::funid-sym-p fun)) ;; (fn (funid-to-fun (or fid fun))) ;; (tp (if fn `(member ,fn) #tfunction)) ; intentionally unnormalized ;; (info (make-info :type tp))) ;; (cond (provisional ;; (or (gethash fn *fun-tp-hash*) ;; (setf (gethash fn *fun-tp-hash*) ;; (list 'foo info args ;; (setf (gethash fn *fun-ev-hash*) (list *vars* *blocks* *tags* *funs*)))))) ;; (fid ;; (let ((fd (c1local-fun fid t))) ;; (unless fd ;; (setf (info-sp-change info) (if (null (get fid 'no-sp-change)) 1 0))) ;; (list 'function info (or fd (list 'call-global info fid))))) ;; ((and (consp fun) (eq (car fun) 'lambda)) ;; (cmpck (endp (cdr fun)) "The lambda expression ~s is illegal." fun) ;; (let ((r (process-local-fun-env env 'cb (make-fun :name 'lambda :src fun :info (make-info :type '*)) fun tp))) ;; (add-info info (cadadr r)) ;; (setf (info-flags info) (logandc2 (info-flags info) (iflags side-effects))) ;; `(function ,info ,r))) ;; ((cmperr "The function ~s is illegal." fun))))) ;; (defun c1function (args &optional (provisional *provisional-inline*) b f) ;; (when (endp args) (too-few-args 'function 1 0)) ;; (unless (endp (cdr args)) (too-many-args 'function 1 (length args))) ;; (let* ((fun (car args)) ;; (fid (si::funid-sym-p fun)) ;; ; (ff (car (member fun *funs* :key (lambda (x) (when (fun-p x) (fun-src x)))))) ;; ; (fid (if ff (fun-name ff) fid)) ;; (fn (funid-to-fun (or fid fun))) ;; (tp (if fn `(member ,fn) #tfunction)) ;; (info (make-info :type tp))) ;; (cond (provisional ;; (or (gethash fn *fun-tp-hash*);FIXME? ;; (setf (gethash fn *fun-tp-hash*) ;; (list 'foo info args ;; (setf (gethash fn *fun-ev-hash*) (list *vars* *blocks* *tags* *funs*)))))) ;; (fid ;; (let ((fd (c1local-fun fid))) ;; (unless fd ;; (setf (info-sp-change info) (if (null (get fid 'no-sp-change)) 1 0))) ;; (list 'function info (or fd (list 'call-global info fid))))) ;; ((and (consp fun) (eq (car fun) 'lambda)) ;; (cmpck (endp (cdr fun)) "The lambda expression ~s is illegal." fun) ;; (let ((r (process-local-fun ;; (or b 'cb) ;; (or f ;; ; (car (member ff *funs* :key (lambda (x) (when (fun-p x) (fun-src x))))) ;; (make-fun :name 'lambda :src fun :info (make-info :type '*))) fun tp))) ;; (add-info info (cadadr r)) ;; (setf (info-flags info) (logandc2 (info-flags info) (iflags side-effects))) ;; `(function ,info ,r))) ;; ((cmperr "The function ~s is illegal." fun))))) (defun update-closure-indices (cl) (mapc (lambda (x &aux (y (var-ref-ccb (car x)))) (setf (cadr x) (if (integerp y) (- y *initial-ccb-vs*) (baboon)) (car x) (var-name (car x)))) (second (third cl))) cl) (defun c2function (funob);FIXME (case (car funob) (call-global (unwind-exit (list 'symbol-function (add-symbol (caddr funob))))) (call-local (let* ((funob (caddr funob))(fun (pop funob))) (unwind-exit (if (cadr funob) (list 'ccb-vs (fun-ref-ccb fun)) (list 'vs* (fun-ref fun)))))) (otherwise (let* ((fun (pop funob)) (lam (car funob)) (cl (update-closure-indices (fun-call fun))) (sig (car cl)) (at (car sig)) (rt (cadr sig)) (clc (export-call-struct cl))) (pushnew (list 'closure (if (null *clink*) nil (cons 0 0)) *ccb-vs* fun lam) *local-funs* :key 'fourth) (cond (*clink* (let ((clc (cons '|#,| clc))) (unwind-exit (list 'make-cclosure (fun-cfun fun) (fun-name fun) (or (fun-vv fun) clc) (new-proclaimed-argd at rt) (argsizes at rt (xa lam)) *clink*)) (unless (fun-vv fun) (setf (fun-vv fun) clc)))) (t (unless (fun-vv fun) (setf (fun-vv fun) (cons '|#,| `(init-function ,clc ,(add-address (c-function-name "&LC" (fun-cfun fun) (fun-name fun))) nil nil -1 ,(new-proclaimed-argd at rt) ,(argsizes at rt (xa lam)))))) (unwind-exit (list 'vv (fun-vv fun))))))))) ;; (defun c2function (funob);FIXME ;; (case (car funob) ;; (call-global ;; (unwind-exit (list 'symbol-function (add-symbol (caddr funob))))) ;; (call-local ;; (let* ((funob (caddr funob))(fun (pop funob))) ;; (unwind-exit (if (cadr funob) (list 'ccb-vs (fun-ref-ccb fun)) (list 'vs* (fun-ref fun)))))) ;; (otherwise ;; (let* ((fun (pop funob)) ;; (lam (car funob)) ;; (cl (fun-call fun)) ;; (sig (car cl)) ;; (at (car sig)) ;; (rt (cadr sig)) ;; (ha (mapcar (lambda (x) `',x) (export-call cl))) ;; (clc `(let ((si::f #'(lambda nil nil))) ;; (si::add-hash si::f ,@ha) ;; ; (si::call si::f) ;; si::f))) ;; (pushnew (list 'closure (if (null *clink*) nil (cons 0 0)) *ccb-vs* fun lam) ;; *local-funs* :key 'fourth) ;; (cond (*clink* ;; (let ((clc (cons '|#,| clc))) ;; (unwind-exit (list 'make-cclosure (fun-cfun fun) (fun-name fun) ;; (or (fun-vv fun) clc) ;; (new-proclaimed-argd at rt) (argsizes at rt (xa lam)) ;; *clink*)) ;; (unless (fun-vv fun) ;; (setf (fun-vv fun) clc)))) ;; (t ;; (unless (fun-vv fun) ;; (setf (fun-vv fun) ;; (cons '|#,| `(init-function ;; ,clc ;; ,(add-address (c-function-name "&LC" (fun-cfun fun) (fun-name fun))) ;; nil nil ;; -1 ,(new-proclaimed-argd at rt) ,(argsizes at rt (xa lam)))))) ;; (unwind-exit (list 'vv (fun-vv fun))))))))) ;; (defun c2function (funob);FIXME ;; (case (car funob) ;; (call-global ;; (unwind-exit (list 'symbol-function (add-symbol (caddr funob))))) ;; (call-local ;; (let* ((funob (caddr funob))(fun (pop funob))) ;; (unwind-exit (if (cadr funob) (list 'ccb-vs (fun-ref-ccb fun)) (list 'vs* (fun-ref fun)))))) ;; (otherwise ;; (let* ((fun (pop funob)) ;; (lam (car funob)) ;; (cl (fun-call fun)) ;; (sig (car cl)) ;; (at (car sig)) ;; (rt (cadr sig)) ;; (ha (mapcar (lambda (x) `',x) (export-call cl))) ;; (clc `(let ((si::f #'(lambda nil nil))) ;; (si::add-hash si::f ,@ha) ;; (si::call si::f)))) ;; (pushnew (list 'closure (if (null *clink*) nil (cons 0 0)) *ccb-vs* fun lam) ;; *local-funs* :key 'fourth) ;; (cond (*clink* ;; (unwind-exit (list 'make-cclosure (fun-cfun fun) (fun-name fun) ;; (or (fun-vv fun) (1+ *next-vv*)) ;; (new-proclaimed-argd at rt) (argsizes at rt (xa lam)) ;; *clink*)) ;; (unless (fun-vv fun) ;; (push-data-incf nil) ;; (setf (fun-vv fun) *next-vv*) ;; (add-init `(si::setvv ,(fun-vv fun) ,clc) t))) ;; (t ;; (unless (fun-vv fun) ;; (push-data-incf nil) ;; (setf (fun-vv fun) *next-vv*) ;; (add-init ;; `(si::setvv ,(fun-vv fun) ;; (si::init-function ;; ,clc ;; ,(add-address (c-function-name "&LC" (fun-cfun fun) (fun-name fun))) ;; nil nil ;; -1 ,(new-proclaimed-argd at rt) ,(argsizes at rt (xa lam)))) t)) ;; (unwind-exit (list 'vv (fun-vv fun))))))))) ;; (defun c2function (funob);FIXME ;; (case (car funob) ;; (call-global ;; (unwind-exit (list 'symbol-function (add-symbol (caddr funob))))) ;; (call-local ;; (let* ((funob (caddr funob)) ;; (fun (pop funob))) ;; (if (car funob) ;; (unwind-exit (list 'ccb-vs (fun-ref-ccb fun))) ;; (unwind-exit (list 'vs* (fun-ref fun)))))) ;; (otherwise ;; (let* ((fun (pop funob)) ;; (funob (car funob)) ;; (cl (fun-call fun)) ;; (sig (pop cl)) ;; (cle (pop cl)) ;; (at (car sig)) ;; (rt (cadr sig)) ;; (ha (mapcar (lambda (x) `',x) (cons sig (cons cle cl)))) ;; (clc `(let ((si::f #'(lambda nil nil))) ;; (si::add-hash si::f ,@ha) ;; (si::call si::f)))) ;; (pushnew (list 'closure (if (null *clink*) nil (cons 0 0)) *ccb-vs* fun funob) ;; *local-funs* :key 'fourth) ;; (cond (*clink* ;; (unwind-exit (list 'make-cclosure (fun-cfun fun) (fun-name fun) ;; (or (fun-vv fun) (1+ *next-vv*)) ;; (new-proclaimed-argd at rt) (argsizes at rt (xa funob)) ;; *clink*)) ;; (unless (fun-vv fun) ;; (push-data-incf nil) ;; (setf (fun-vv fun) *next-vv*) ;; (add-init `(si::setvv ,(fun-vv fun) ,clc) t))) ;; (t ;; (unless (fun-vv fun) ;; (push-data-incf nil) ;; (setf (fun-vv fun) *next-vv*) ;; (add-init ;; `(si::setvv ,(fun-vv fun) ;; (si::init-function ;; ,clc ;; ,(add-address (c-function-name "&LC" (fun-cfun fun) (fun-name fun))) ;; nil nil ;; -1 ,(new-proclaimed-argd at rt) ,(argsizes at rt (xa funob)))) t)) ;; (unwind-exit (list 'vv (fun-vv 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 fname call argd sizes args) (declare (ignore args)) (wt "fSinit_function(") (wt-vv call) (wt ",(void *)" (c-function-name "LC" cfun fname) ",Cdata,") (wt-clink) (wt ",-1," argd "," sizes ")")) gcl27-2.7.0/cmpnew/gcl_cmptag.lsp000077500000000000000000000667501454061450500165740ustar00rootroot00000000000000;;; 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) (si:putprop 'tagbody 'c1tagbody 'c1special) (si:putprop 'tagbody 'c2tagbody 'c2) (si:putprop 'go 'c1go 'c1special) (si:putprop 'go 'c2go 'c2) (defstruct (tag (:print-function (lambda (x s i) (s-print 'tag (tag-name x) (si::address x) s)))) 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 ) (si::freeze-defstruct 'tag) (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. (defvar *reg-amount* 60) ;;amount to increase var-register for each variable reference in side a loop (defun add-reg1 (form) (unless (tag-p form) (mapc (lambda (x) (when (var-p x) (incf (var-register x) (the fixnum *reg-amount*)))) (info-ref (cadr form))))) (defun intersection-p (l1 l2) (member-if (lambda (x) (member x l2)) l1)) (setf (get 'intersection-p 'cmp-inline) t) (defun add-loop-registers (tagbody &aux (first (member-if 'tag-p tagbody)) (tags (cons (pop first) (remove-if-not 'tag-p first))) (end first)) (mapl (lambda (x) (unless (tag-p (car x)) (when (intersection-p tags (info-ref (cadar x))) (setf end (cdr x))))) first) (do ((form first (cdr form))) ((eq form end)) (add-reg1 (car form)))) (defun ref-tags (form tags) (ref-obs form tags (lambda (x) (setf (tag-ref-ccb x) t)) (lambda (x) (setf (tag-ref-clb x) t)) (lambda (x) (setf (tag-ref x) t)) 'tag-name "Tag" (lambda (x &aux (y (pop x))) (when (eq y 'go) (cdr x))))) ;; (defun ref-tags1 (form tags &aux (i (cadr form))) ;; (dolist (tag tags) ;; (when (member tag (info-tref-ccb i)) ;; (setf (tag-ref-ccb tag) t)) ;; (when (member tag (info-tref-clb i)) ;; (setf (tag-ref-clb tag) t)) ;; (when (member tag (info-tref i)) ;; (setf (tag-ref tag) t)))) ;; (defun ref-tags (form tags &optional l) ;; (cond ((not l) ;; (cond (*fast-ref* (ref-tags1 form tags)) ;; ((let* ((l (list (info-tref (cadr form)) (info-tref-ccb (cadr form)) (info-tref-clb (cadr form)))) ;; (l (mapcar (lambda (x) (intersection x tags)) l)) ;; (l (mapcar (lambda (y) (mapcar (lambda (x) (cons x nil)) y)) l))) ;; (ref-tags form tags l) ;; (let* (y (x (member-if (lambda (x) (setq y (member nil x :key 'cdr))) l))) ;; (when y ;; (cmpwarn "~s Tag ~s reffed in info but not in form" (length (ldiff l x)) (tag-name (caar y))))))))) ;; ((atom form)) ;; ((eq (car form) 'go) ;; (let* ((tref (cddr form)) ;; (tag (pop tref)) ;; (ccb (pop tref)) ;; (clb (car tref))) ;; (when (member tag tags) ;; (cond (ccb (setf (tag-ref-ccb tag) t) ;; (let* ((x (cadr l))(x (assoc tag x))) ;; (if x (rplacd x t) (cmpwarn "ccb Tag ~s reffed in form but not in info" (tag-name tag))))) ;; (clb (setf (tag-ref-clb tag) t) ;; (let* ((x (caddr l))(x (assoc tag x))) ;; (if x (rplacd x t) (cmpwarn "clb Tag ~s reffed in form but not in info" (tag-name tag))))) ;; ((setf (tag-ref tag) t) ;; (let* ((x (car l))(x (assoc tag x))) ;; (if x (rplacd x t) (cmpwarn "nil Tag ~s reffed in form but not in info" (tag-name tag)))))) ;; (keyed-cmpnote (list 'tag-ref (tag-name tag)) "Tag is referred with barrier ~s" (tag-name tag) (if ccb 'cb (if clb 'lb)))) ;; (ref-tags tref tags l)));FIXME? ;; (t (ref-tags (car form) tags l) (ref-tags (cdr form) tags l)))) ;FIXME separate pass with no repetitive allocation (defvar *ft* nil) (defvar *bt* nil) (defun tst (y x &aux (z (eq (car x) y))) (unless z (keyed-cmpnote (list 'tagbody-iteration) "Iterating tagbody at ~s ~x on ~s conflicts" (tag-name y) (address y) (length x)) (mapc (lambda (x &aux (v (pop x))) (keyed-cmpnote (list (var-name v) 'tagbody-iteration) " Iterating tagbody: setting ~s type ~s to ~s, store ~s to ~s" v (cmp-unnorm-tp (var-type v)) (cmp-unnorm-tp (car x)) (var-store v) (cadr x)) (setf (var-type v) (car x));FIXME do-setq-tp ? (push-vbinds v (cadr x))) x)) (when z x)) (defun pt (y x) (or (tst y (with-restore-vars (catch y (prog1 (cons y (pr x)) (keep-vars))))) (pt y x))) ;; (defun pt (y x &optional (ws *warning-note-stack*)) ;; (or (tst y (with-restore-vars (catch y (prog1 (cons y (pr x)) (keep-vars))))) (pt y x (setq *warning-note-stack* ws)))) (defun lvars (&aux (v (member-if-not 'var-p *vars*))) (if v (ldiff *vars* v) *vars*)) (defun mch nil (mapcan (lambda (x) (when (var-p x) `((,x ,(var-type x) ,(var-store x) ,(mcpt (var-type x)))))) *vars*)) (defun or-mch (l &optional b) (mapc (lambda (x &aux (y x)(v (pop x))(tp (pop x))(st (pop x))(m (car x)) (t1 (type-or1 (var-type v) (or m tp)));FIXME check expensive (t1 (if b (bbump-tp t1) t1)) (t1 (type-and (var-dt v) t1))) (setf (cadr y) t1 (caddr y) (or-binds (var-store v) st);FIXME union? (cadddr y) (mcpt t1))) l)) (defun mch-set (z l) (mapc (lambda (x) (keyed-cmpnote (list (var-name (car x)) 'tagbody-label) "Initializing ~s at label ~s:~% type from ~s to ~s,~% store from ~s to ~s" (car x) (tag-name z) (var-type (car x)) (cadr x) (var-store (car x)) (if (eq (var-store (car x)) (caddr x)) (caddr x) +opaque+)) (do-setq-tp (car x) 'mch-set (cadr x));FIXME too prolix (push-vbinds (car x) (caddr x))) l)) (defun mch-z (z i &aux (f (cdr (assoc z *ft*)))) (if f (mch-set z (or-mch f)) (mch)));FIXME ccb-ch (if i (or-mch f) f) ;; The right way to do this is to throw ccb assignments via tag-throw on go into something like *ft* (defun pr (x &aux (y (member-if 'tag-p x))(z (mapcar 'c1arg (ldiff x y)))(i (when z (info-type (cadar (last z)))))) (nconc z (when y (let* ((z (pop y)) (*bt* (cons (cons z (mch-z z i)) *bt*))) (pt z y))))) (defconstant +ttl-tag-name+ (gensym "TTL")) (defun make-ttl-tag nil (make-tag :name +ttl-tag-name+)) (defun is-ttl-tag (tag) (when (tag-p tag) (eq (tag-name tag) +ttl-tag-name+))) (defvar *ttl-tags* nil) (defun nttl-tags (body &aux (x (car body))) (if (is-ttl-tag x) (cons (list x *vars*) *ttl-tags*) *ttl-tags*)) (defun c1tagbody (body &aux (info (make-info :type #tnull))) (let* ((body (mapcar (lambda (x) (if (or (symbolp x) (integerp x)) (make-tag :name x) x)) body)) (tags (remove-if-not 'tag-p body)) (body (let* ((*tags* (append tags *tags*)) (*ft* (nconc (mapcar 'list tags) *ft*)) (*ttl-tags* (nttl-tags body))) (pr body))) (body (mapc (lambda (x) (unless (tag-p x) (ref-tags x tags))) body)) (ref-clb (remove-if-not 'tag-ref-clb tags)) (ref-ccb (remove-if-not 'tag-ref-ccb tags)) (tagsc (union ref-clb ref-ccb)) (tags (union (remove-if-not 'tag-ref tags) tagsc)) (body (remove-if-not (lambda (x) (if (tag-p x) (member x tags) t)) body))) (mapc (lambda (x) (setf (tag-var x) (add-object (tag-name x)))) tagsc) (if tagsc (incf *setjmps*) (add-loop-registers body)) (when ref-ccb (mapc (lambda (x) (setf (tag-ref-ccb x) t)) ref-clb));FIXME? (mapc (lambda (x) (unless (tag-p x) (add-info info (cadr x)))) body) (let ((x (car (last body)))) (unless (or (not x) (tag-p x) (info-type (cadr x))) (setf (info-type info) nil))) (if tags `(tagbody ,info ,(when ref-clb t) ,(when ref-ccb t) ,body) (let* ((v (car (last body))) (v (if (when v (not (info-type (cadr v)))) body (nconc body (list (c1nil)))))) (if (cdr v) `(progn ,info ,v) (car v)))))) (defun c2tagbody (ref-clb ref-ccb body) (cond (ref-ccb (c2tagbody-ccb body)) (ref-clb (c2tagbody-clb body)) ((c2tagbody-local body)))) (defun c2tagbody-local (body &aux (label (next-label))) (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 (type>= #tnil (info-type (cadar l))) (unwind-exit nil)))));(eq (caar l) 'go) (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();") (add-libc "setjmp") (setq *frame-used* t) (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) (clink ref-clb) (setq ref-ccb (ccb-vs-push)) (add-libc "setjmp") (setq *frame-used* t) (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 mcpt (tp &aux (a (car (atomic-tp tp)))) (when (consp a) (subst (copy-list a) a tp)));rplacd, etc. (defun tag-throw (tag &aux (b (assoc tag *bt*))) (if b (let ((v (remove-if (lambda (x &aux (v (pop x))(tp (pop x))(st (pop x))(m (car x))) (and (type>= (type-and (var-dt v) tp) (var-type v)) (or (cdr st) (subsetp (var-store v) st)) (if m (equal tp m) t))) (cdr b)))) (when v (throw tag (or-mch v t)))) (let ((f (assoc tag *ft*))) (or (or-mch (cdr f)) (setf (cdr f) (mch)))))) (defun c1go (args &aux (name (car args)) ccb clb inner) (cond ((endp args) (too-few-args 'go 1 0)) ((not (endp (cdr args))) (too-many-args 'go 1 (length args))) ((not (or (symbolp name) (integerp name))) "The tag name ~s is not a symbol nor an integer." name)) (dolist (tag *tags* (cmperr "The tag ~s is undefined." name)) (case tag (cb (setq ccb t inner (or inner 'cb))) (lb (setq clb t inner (or inner 'lb))) (t (when (when (eq (tag-name tag) name) (not (member tag *lexical-env-mask*))) (tag-throw tag) (let* ((ltag (list tag)) (info (make-info :type nil)) (c1fv (when ccb (c1inner-fun-var)))) (cond (ccb (setf (info-ref-ccb info) ltag)) (clb (setf (info-ref-clb info) ltag)) ((setf (info-ref info) ltag))) (when c1fv (add-info info (cadr c1fv))) (return (list 'go info tag ccb clb c1fv)))))))) (defun c2go (tag ccb clb c1fv) (declare (ignore c1fv)) (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)) ");") (unwind-exit nil)) (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)) ");}") (unwind-exit nil)) (defun wt-switch-case (x) (cond (x (wt-nl (if (typep x 'fixnum) "case " "") x ":")))) (defun or-branches (trv) (mapc (lambda (x &aux (v (pop x))) (do-setq-tp v (list 'or-branches nil) (type-or1 (var-type v) (car x))) (push-vbinds v (cadr x))) trv)) (defun c1switch (body) (flet ((tgs-p (x) (or (symbolp x) (integerp x)))) (let* ((switch-op (pop body)) (info (make-info :type #tnil)) (switch-op-1 (c1arg switch-op info)) (st (coerce-to-one-value (info-type (cadr switch-op-1)))) (st (if (type>= #tfixnum st) st (baboon))) tags (body (remove-if (lambda (x) (when (tgs-p x) (prog1 (member x tags) (push x tags)))) body)) skip cs dfp rt (body (remove-if-not (lambda (b) (cond ((tgs-p b) (unless cs (setq cs t skip t rt nil)) (let* ((e (object-type b))(df (member b '(t otherwise)))(e (if df st e))) (cond ((and df dfp) (cmperr "default tag must be last~%")) ((type-and st e) (setq skip nil dfp (or df dfp) rt (type-or1 rt e))) ((keyed-cmpnote 'branch-elimination "Eliminating unreachable switch ~s" b))))) ((not skip) (when cs (setq st (type-and st (tp-not rt)) cs nil)) t))) body)) (body (mapcar (lambda (x) (if (tgs-p x) (make-tag :name x :ref t :switch (if (typep x 'fixnum) x "default")) x)) body)) trv (body (mapcar (lambda (x) (if (tag-p x) x (let ((x (c1branch t nil (list nil x) info))) (prog1 (pop x) (setq trv (append trv (car x))))))) body)) (ls (member-if 'consp body))) (or-branches trv) (when st (baboon)) (mapc (lambda (x) (assert (or (tag-p x) (not (info-type (cadr x)))))) body) (if (unless (cdr ls) (ignorable-form switch-op-1)) (car ls) (list 'switch info switch-op-1 body))))) ;; (defun c1switch(form &aux (*tags* *tags*) st ls) ;; (let* ((switch-op (car form)) ;; (body (cdr form)) ;; (info (make-info :type #tnull)) ;; (switch-op-1 (c1arg switch-op info))) ;; (cond ((and (typep (second switch-op-1 ) 'info) ;; (type>= #tfixnum (setq st (info-type (second switch-op-1))))) ;; ;;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 ;; (let* (skip cs new-body dfp rt) ;; (dolist (b body (nreverse new-body)) ;; (cond ((or (symbolp b) (integerp b)) ;; (unless cs (setq cs t skip t)) ;; (let* ((e (info-type (second (c1arg b)))) ;; (df (type>= #tsymbol e)) ;; (e (if df (cmp-norm-tp `(and integer (not ,rt))) e))) ;; (cond ((and df dfp) (cmperr "default tag must be last~%")) ;; ((type-and (info-type (second switch-op-1)) e) ;; (setq skip nil dfp df rt (type-or1 rt e) ;; st (type-and st (cmp-norm-tp `(not ,e)))) ;; (push b new-body)) ;; ((keyed-cmpnote 'branch-elimination ;; "Eliminating unreachable switch ~s" b))))) ;; ((not skip) (setq cs nil) (push b new-body)))))) ;; (when (and (not st) ;; (not (cdr (setq ls (member-if 'consp body)))) ;; ; (= 1 (count-if (lambda (x) (or (consp x) (symbolp x))) body));FIXME ;; (ignorable-form switch-op-1)) ;; (return-from c1switch (c1expr (car ls)))) ;; (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 #tfixnum) ;; (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 ((d (c1arg `(tagbody ,@body) info))) ;; (setf (info-type info) (info-type (cadr d))) ;; (list* 'switch info switch-op-1 (cddr d)))) ;; ((c1expr (cmp-macroexpand-1 (cons 'switch form))))))) ;; (defun c1switch(form &aux (*tags* *tags*) st ls) ;; (let* ((switch-op (car form)) ;; (body (cdr form)) ;; (switch-op-1 (c1expr switch-op))) ;; (cond ((and (typep (second switch-op-1 ) 'info) ;; (type>= #tfixnum (setq st (info-type (second switch-op-1))))) ;; ;;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 ;; (let* (skip cs new-body dfp rt) ;; (dolist (b body (nreverse new-body)) ;; (cond ((or (symbolp b) (integerp b)) ;; (unless cs (setq cs t skip t)) ;; (let* ((e (info-type (second (c1expr b)))) ;; (df (type>= #tsymbol e)) ;; (e (if df (cmp-norm-tp `(and integer (not ,rt))) e))) ;; (cond ((and df dfp) (cmperr "default tag must be last~%")) ;; ((type-and (info-type (second switch-op-1)) e) ;; (setq skip nil dfp df rt (type-or1 rt e) ;; st (type-and st (cmp-norm-tp `(not ,e)))) ;; (push b new-body)) ;; ((keyed-cmpnote 'branch-elimination ;; "Eliminating unreachable switch ~s" b))))) ;; ((not skip) (setq cs nil) (push b new-body)))))) ;; (when (and (not st) ;; (not (cdr (setq ls (member-if 'consp body)))) ;; ; (= 1 (count-if (lambda (x) (or (consp x) (symbolp x))) body));FIXME ;; (ignorable-form switch-op-1)) ;; (return-from c1switch (c1expr (car ls)))) ;; (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 #tfixnum) ;; (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)))) ;; (add-info (cadr tem) (cadr switch-op-1)) ;; (list* 'switch (cadr tem) switch-op-1 (cddr tem)))) ;; (t (c1expr (cmp-macroexpand-1 (cons 'switch form))))))) ;; (defun c1switch(form &aux (*tags* *tags*) st ls) ;; (let* ((switch-op (car form)) ;; (body (cdr form)) ;; (switch-op-1 (c1expr switch-op))) ;; (cond ((and (typep (second switch-op-1 ) 'info) ;; (type>= #tfixnum (setq st (info-type (second switch-op-1))))) ;; ;;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 ;; (let* (skip cs new-body dfp rt) ;; (dolist (b body (nreverse new-body)) ;; (cond ((or (symbolp b) (integerp b)) ;; (unless cs (setq cs t skip t)) ;; (let* ((e (info-type (second (c1expr b)))) ;; (df (type>= #tsymbol e)) ;; (e (if df (cmp-norm-tp `(and integer (not ,rt))) e))) ;; (cond ((and df dfp) (cmperr "default tag must be last~%")) ;; ((type-and (info-type (second switch-op-1)) e) ;; (setq skip nil dfp df rt (type-or1 rt e) ;; st (type-and st (cmp-norm-tp `(not ,e)))) ;; (push b new-body)) ;; ((keyed-cmpnote 'branch-elimination ;; "Eliminating unreachable switch ~s" b))))) ;; ((not skip) (setq cs nil) (push b new-body)))))) ;; (when (and (not st) ;; (not (cdr (setq ls (member-if 'consp body)))) ;; ; (= 1 (count-if (lambda (x) (or (consp x) (symbolp x))) body));FIXME ;; (ignorable-form switch-op-1)) ;; (return-from c1switch (c1expr (car ls)))) ;; (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 #tfixnum) ;; (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 body &aux (*inline-blocks* 0)(*vs* *vs*)) (let ((args (inline-args (list op) `(,#tfixnum)))) (wt-nl "") (wt-inline-loc "switch(#0){" args) (c2tagbody-local body) (wt "}") (unwind-exit nil) (close-inline-blocks))) ;; (defun c2switch (op ref-clb ref-ccb body &aux (*inline-blocks* 0)(*vs* *vs*)) ;; (let ((args (inline-args (list op) `(,#tfixnum)))) ;; (wt-nl "") ;; (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) gcl27-2.7.0/cmpnew/gcl_cmptest.lsp000077500000000000000000000201041454061450500167570ustar00rootroot00000000000000;;; 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)))) gcl27-2.7.0/cmpnew/gcl_cmptop.lsp000077500000000000000000003027531454061450500166170ustar00rootroot00000000000000;;; 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 *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) (defvar *volatile*) (defvar *setjmps* 0) ;; Functions may use a block of C stack space. ;; (cs . i) will become Vcs[i]. (defvar *cs* 0) ;;; *objects* holds ( { object vv-index }* ). ;;; *function-links* ( {symbol vv-index} ) for function symbols needing link (defvar *global-funs* nil) ;;; *global-funs* holds ;;; ( { global-fun-name cfun }* ) (defvar *local-funs* nil) (defvar *top-level-forms* 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 ) (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 'in-package t 'eval-at-compile) (si:putprop 'si::in-package-internal t 'eval-at-compile) ;;; 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 'macrolet 't1macrolet '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 'progn 't2progn 't2) (si:putprop 'mflag 't3mflag 't3) ;(si:putprop 'defmacro 't2defmacro 't2) (si:putprop 'ordinary 't3ordinary 't3) (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 'progn 't3progn 't3) ;(si:putprop 'defmacro 't3defmacro '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 mv) `(+ ,min (ash ,max 16) (ash (if ,mv 4 0) 8)));;fixme rationalize (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)(*bds-used* nil)(*frame-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) (if sp (let* ((p (truename (merge-pathnames p #p".lsp"))) (pn (pathname-name p)) (g (zerop (si::string-match #v"^gcl_" pn)))) (dash-to-underscore (namestring (make-pathname :host (unless g (pathname-host p)) :device (unless g (pathname-device p)) :directory (unless g (pathname-directory p)) :name pn)))) "code")) (defun c-function-name (prefix num fname) (si::string-concatenate (string prefix) (if (stringp num) num (write-to-string num)) (let ((fname (string fname))) (si::string-concatenate "__" (dash-to-underscore fname) "__" (if (boundp '*compiler-input*) (subseq *init-name* 4) ""))))) (defvar *top-form* nil) (defun t1expr (form &aux (*current-form* form) (*top-form* form) (*first-error* t)) (catch *cmperr-tag* (when (consp form) (let ((fun (car form)) (args (cdr form)) fd) (cond ((symbolp fun) (cond ((eq fun 'si:|#,|) (cmperr "Sharp-comma-macro is in a bad place.")) ((setq fd (get fun 't1)) (when *compile-print* (print-current-form)) (values (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 (macro-function fun *macrolet-env*)) (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*) (defvar *add-hash-calls*) (defun t23expr (form prop &aux (def (when (consp form) (get (car form) prop))) *local-funs* (*first-error* t) *vcs-used*) (when def (apply def (cdr form))) (when (eq prop 't3) ;;; Local function and closure function definitions. (block nil (loop (when (endp *local-funs*) (return)) (let (*vcs-used*) (apply 't3local-fun (pop *local-funs*))))))) (defun ctop-write (name &aux (*function-links* nil) *c-vars* (*volatile* " VOL ") *vaddress-list* (*vind* 0) *inits* *current-form* *vcs-used* *add-hash-calls*) (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*) (t23expr *current-form* 't2)) ;;; C function definitions. (dolist (*current-form* *top-level-forms*) (t23expr *current-form* 't3)) ;;; 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)) (mapc (lambda (x) (add-init x)) *add-hash-calls*) #+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 (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) (dolist (x *function-links*) (let* ((num (second x)) (type (fourth x)) (type (if (link-arg-p type) type t)) (type (or type t));FIXME (args (fifth x)) (pc (eq type 'proclaimed-closure)) (newtype (cond (pc "") ((not type) "") ((rep-type type)))) (d (declaration-type newtype))) (when (eq type 'proclaimed-closure) (wt-h "static object *Lclptr"num";")) (if (and (not (null type)) (not (eq type 'proclaimed-closure)) (or args (not (eq t type)))) (progn (wt-h "static " d " LnkT" num "(object,...);") #-sgi3d (wt-h "static " d " (*Lnk" num ")() = (" d "(*)()) LnkT" num ";") #+sgi3d (wt-h "static " d " (*Lnk" num ")();")) (progn (wt-h "static " d " LnkT" num "();") #-sgi3d (wt-h "static " d " (*Lnk" num ")() = LnkT" num ";") #+sgi3d (wt-h "static " d " (*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* nil);:defaults (defun maybe-eval (def form) (when (or def (intersection '(compile :compile-toplevel) *eval-when-defaults*) (let ((c (car form))) (when (symbolp c) (get c 'eval-at-compile)))) (when 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* (or *eval-when-defaults* (car args)))) (cond (load-flag (t1progn (cdr args))) (compile-flag (cmp-eval (cons 'progn (cdr args))))))) (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)) (let ((f *top-level-forms*)) (dolist (form args) (t1expr form)) (setq *top-level-forms* (cons `(progn ,(nreverse (ldiff *top-level-forms* f))) f))) ))) (defun t3progn (args) (dolist (arg args) (t23expr arg 't3))) (defun t2progn (args) (dolist (arg args) (t23expr arg 't2))) (defun function-symbol (name) (si::funid-sym name)) (defun function-string (name) (unless (symbolp name) (error "function names must be symbols~%")) (delete-if (lambda (x) (or (eq x #\@) (eq x #\/))) (si::string-concatenate (let ((p (symbol-package name))) (if p (package-name p) "")) "::" (symbol-name name)))) (defvar *compiler-auto-proclaim* t) (defvar *mlts* nil) (defmacro ndbctxt (&rest body) `(let ((*debug* *debug*) (*compiler-check-args* *compiler-check-args*) (*safe-compile* *safe-compile*) (*compiler-push-events* *compiler-push-events*) (*compiler-new-safety* *compiler-new-safety*) (*notinline* *notinline*) (*space* *space*)) ,@body)) (defun is-declared-special (sym forms) (dolist (form forms) (cond ((stringp form)) ((and (consp form) (eq (car form) 'declare) (mapc (lambda (x) (and (consp x) (eq (car x) 'special) (member sym (cdr x)) (return t))) (cdr form))))))) (defun printable-tp (tp) (typecase tp (cons (and (printable-tp (car tp)) (printable-tp (cdr tp)))) ((or number array symbol character pathname) t))) (defun ensure-printable-tp (tp) (cond ((printable-tp tp) tp) ((listp tp) (car tp)) (#tt))) (defun portable-source (form &optional cdr) (cond ((atom form) form) (cdr (cons (portable-source (car form)) (portable-source (cdr form) t))) ((case (car form) ((let let* lambda) `(,(car form) ,(mapcar (lambda (x) (if (atom x) x `(,(car x) ,@(portable-source (cdr x) t)))) (cadr form)) ,@(let* ((r (delete-if (lambda (x) (or (not (si::specialp x)) (is-declared-special x (cddr form)))) (mapcar (lambda (x) (if (atom x) x (car x))) (cadr form)))));FIXME key name (when r `((declare (special ,@r))))) ,@(ndbctxt (portable-source (cddr form) t)))) ((quote function side-effects) form) (infer-tp `(,(car form) ,(cadr form) ,(ensure-printable-tp (caddr form)) ,@(portable-source (cdddr form) t))) (declare (let ((opts (mapcan (lambda (x) (if (eq (car x) 'optimize) (cdr x) (list x))) (remove-if-not (lambda (x) (and (consp x) (member (car x) '(optimize notinline)))) (cdr form))))) (when opts (local-compile-decls opts))) form) (the `(,(car form) ,(cadr form) ,@(portable-source (cddr form) t))) ((and or) `(,(car form) ,@(portable-source (cdr form) t))) ((check-type assert) form) ((flet labels macrolet) (let ((fns (mapcar 'car (cadr form)))) `(,(car form) ,(let ((*mlts* (if (eq (car form) 'labels) (append fns *mlts*) *mlts*))) (mapcar (lambda (x) `(,(car x) ,@(cdr (portable-source `(lambda ,@(cdr x)))))) (cadr form))) ,@(let ((*mlts* (append fns *mlts*))) (ndbctxt (portable-source (cddr form) t)))))) (multiple-value-bind `(,(car form) ,(cadr form) ,(portable-source (caddr form)) ,@(let ((r (remove-if (lambda (x) (or (not (si::specialp x)) (is-declared-special x (cdddr form)))) (cadr form)))) (when r `((declare (special ,@r))))) ,@(ndbctxt (portable-source (cdddr form) t)))) ((case ccase ecase) `(,(car form) ,(portable-source (cadr form)) ,@(mapcar (lambda (x) `(,(car x) ,@(portable-source (cdr x) t))) (cddr form)))))) ((let* ((fd (and (symbolp (car form)) (not (member (car form) *mlts*)) (or (unless (member (car form) *notinline*) (get (car form) 'si::compiler-macro-prop)) (macro-function (car form))))) (nf (if fd (cmp-expand-macro fd (car form) (cdr form)) form))) (portable-source nf (equal form nf)))))) ;(defvar *no-proxy-symbols* nil) (defun this-safety-level nil (cond (*compiler-push-events* 4) (*compiler-new-safety* 3) (*safe-compile* 2) (*compiler-check-args* 1) (0))) (defun pd (fname ll args) (multiple-value-bind (doc decls ctps args) (parse-body-header args) (let* ((nal (do (r (y ll)) ((or (not y) (eq (car y) '&aux)) (nreverse r)) (push (pop y) r))) (al (cdr (member '&aux ll))) (ax (mapcar (lambda (x) (if (atom x) x (car x))) al)) (dd (split-decls ax decls t)) (cc (split-ctps ax ctps))) (portable-source `(lambda ,nal ,@(when doc `(,doc)) ,@(nconc (nreverse (cadr dd)) (cadr cc)) ,@(let* ((r args)(bname (blocked-body-name r))(fname (if (when bname (eq fname 'lambda)) bname fname)) (r (if (eq fname bname) (cddar r) r)) (r (if (or al (car dd)) `((let* ,al ,@(append (car dd) (car cc)) ,@r)) r))) `((block ,fname ,@r)))))))) (defvar *recursion-detected* nil) (defun split-decls (auxs decls &optional ro &aux ad dd) (dolist (l decls (list (nreverse ad) (nreverse dd))) (dolist (bb (cdr l)) (let ((b (if (member (car bb) '(type ftype)) (cdr bb) bb))) (cond ((eq (car b) 'optimize) (if ro (push `(declare ,b) dd) (push `(declare ,b) ad))) ((eq (car b) 'class) (unless (<= (length b) 3) (cmperr "Unknown class declaration: ~s" b)) (if (member (cadr b) auxs) (push `(declare ,b) ad) (push `(declare ,b) dd))) ((multiple-value-bind (tt q) (list-split (cdr b) auxs) (let ((z (if (eq b bb) (list (car bb)) (list (car bb) (cadr bb))))) (when tt (push `(declare (,@z ,@tt)) ad)) (when q (push `(declare (,@z ,@q)) dd)))))))))) ;; (defun split-decls (auxs decls &aux ad dd) ;; (dolist (l decls (list (nreverse ad) (nreverse dd))) ;; (dolist (bb (cdr l)) ;; (let ((b (if (eq (car bb) 'type) (cdr bb) bb))) ;; (cond ((eq (car b) 'optimize) (push `(declare ,b) dd)) ;; ((eq (car b) 'class) ;; (unless (<= (length b) 3) ;; (cmperr "Unknown class declaration: ~s" b)) ;; (if (member (cadr b) auxs) (push `(declare ,b) ad) (push `(declare ,b) dd))) ;; ((multiple-value-bind ;; (tt q) ;; (list-split (cdr b) auxs) ;; (let ((z (if (eq b bb) (list (car bb)) (list (car bb) (cadr bb))))) ;; (when tt ;; (push `(declare (,@z ,@tt)) ad)) ;; (when q ;; (push `(declare (,@z ,@q)) dd)))))))))) ;; (defun split-decls (auxs decls &aux ad dd) ;; (dolist (l decls (list (nreverse ad) (nreverse dd))) ;; (dolist (bb (cdr l)) ;; (let ((b (if (eq (car bb) 'type) (cdr bb) bb))) ;; (cond ((eq (car b) 'optimize) (push `(declare ,b) dd)) ;; ((eq (car b) 'class) ;; (unless (<= (length b) 3) ;; (cmperr "Unknown class declaration: ~s" b)) ;; (if (member (cadr b) auxs) (push `(declare ,b) ad) (push `(declare ,b) dd))) ;; ((eq (car b) 'special) (push `(declare ,b) ad)) ;; ((multiple-value-bind ;; (tt q) ;; (list-split (cdr b) auxs) ;; (let ((z (if (eq b bb) (list (car bb)) (list (car bb) (cadr bb))))) ;; (when tt ;; (push `(declare (,@z ,@tt)) ad)) ;; (when q ;; (push `(declare (,@z ,@q)) dd)))))))))) (defun split-ctps (auxs ctps) (let (ad dd) (dolist (l ctps) (if (member (cadr l) auxs) (push l ad) (push l dd))) (list (nreverse ad) (nreverse dd)))) (defun c1retnote (le) (case (car le) (call-global (list (third le) (export-type (info-type (second le))))) ((let let*) (list (car le) (export-type (info-type (second le))) (mapcar (lambda (x y) (list (var-name x) (c1retnote y))) (third le) (fourth le)) (c1retnote (fifth le)))) ((flet labels) (list (car le) (export-type (info-type (second le))) (mapcar (lambda (x y) (list (fun-name (car x)) (c1retnote y))) (third le) (fourth le)) (c1retnote (fifth le)))) (recur (list (car le) (export-type (info-type (second le))))) (progn (list (car le) (export-type (info-type (second le))) (mapcar 'c1retnote (car (last le))))) ((lambda decl-body) (list (car le) (export-type (info-type (second le))) (c1retnote (car (last le))))) (inline (list (car le) (caddr le) (export-type (info-type (second le))) (c1retnote (car (last le))))) (if (list (car le) (export-type (info-type (second le))) (c1retnote (fourth le)) (c1retnote (fifth le)))) (var (list (car le) (export-type (info-type (second le))) (var-name (car (third le))))) (location (list (car le) (export-type (info-type (second le))))) (return-from (list (car le) (c1retnote (car (last le))))) (tagbody `(,(car le) ,(export-type (info-type (second le))) ,@(mapcar (lambda(x) (unless (tag-p x) (c1retnote x))) (car (last le))))) (block `(,(car le) ,(export-type (info-type (second le))) ,@(mapcar 'c1retnote (last le)))) (otherwise (list (car le) 'foo)))) ;; (defun c1retnote (le) ;; (case (car le) ;; (call-global (list (third le) (export-type (info-type (second le))))) ;; ((let let* flet labels) ;; (list (car le) (export-type (info-type (second le))) ;; (mapcar (lambda (x y) (list (var-name x) (c1retnote y))) ;; (third le) (fourth le)) ;; (c1retnote (fifth le)))) ;; (recur (list (car le) (export-type (info-type (second le))))) ;; (progn ;; (list (car le) ;; (export-type (info-type (second le))) ;; (mapcar 'c1retnote (car (last le))))) ;; ((lambda decl-body) ;; (list (car le) ;; (export-type (info-type (second le))) ;; (c1retnote (car (last le))))) ;; (inline ;; (list (car le) (caddr le) ;; (export-type (info-type (second le))) ;; (c1retnote (car (last le))))) ;; (if ;; (list (car le) ;; (export-type (info-type (second le))) ;; (c1retnote (fourth le)) ;; (c1retnote (fifth le)))) ;; (var (list (car le) (export-type (info-type (second le))) (var-name (car (third le))))) ;; (location (list (car le) (export-type (info-type (second le))))) ;; (return-from (list (car le) (c1retnote (car (last le))))) ;; (tagbody `(,(car le) ;; ,(export-type (info-type (second le))) ;; ,@(mapcar (lambda(x) (unless (tag-p x) (c1retnote x))) (car (last le))))) ;; (block `(,(car le) ;; ,(export-type (info-type (second le))) ;; ,@(mapcar 'c1retnote (last le)))) ;; (otherwise (list (car le) 'foo)))) ;(defvar *callees* nil) (defconstant +nargs+ (let ((s (tmpsym))) (setf (get s 'tmp) t) s)) (defconstant +fun+ (let ((s (tmpsym))) (setf (get s 'tmp) t) s)) (defconstant +mv+ (let ((s (tmpsym))) (setf (get s 'tmp) t) s)) (defconstant +first+ (let ((s (tmpsym))) (setf (get s 'tmp) t) s)) (defun mll (ll) (let ((a (pop ll))) (cond ((not a) 0) ((eq a '&optional) (mll ll)) ((member a '(&rest &key)) 63) ((member a lambda-list-keywords) 0) ((1+ (mll ll)))))) (defun is-narg-var (v) (when (var-p v) (eq (var-name v) +nargs+))) (defun is-mv-var (v) (when (var-p v) (eq (var-name v) +mv+))) (defun is-fun-var (v) (when (var-p v) (eq (var-name v) +fun+))) (defun is-first-var (v) (when (var-p v) (eq (var-name v) +first+))) (dolist (l '(is-narg-var is-mv-var is-fun-var is-first-var)) (si::putprop l t 'cmp-inline)) (defun list-split (x y &optional iy niy (cx nil cxp));FIXME intersection/set-difference bootstrap (cond (cxp (if (or (not y) (eq cx (car y))) y (list-split x (cdr y) iy niy cx))) ((not x) (values iy niy)) (t (let* ((cx (car x)) (v (list-split x y iy niy cx))) (if v (push cx iy) (push cx niy)) (list-split (cdr x) y iy niy))))) (defun decl-safety (d &optional s) (cond ((consp (car d)) (max (decl-safety (car d) s) (decl-safety (cdr d) s))) ((eq (car d) 'declare) (decl-safety (cdr d) 1)) ((and s (= s 1) (eq (car d) 'optimize)) (decl-safety (cdr d) 2)) ((and s (= s 2) (eq (car d) 'safety)) (or (cadr d) 3)) (0))) (defun effective-safety (decls) (max (decl-safety decls) (this-safety-level))) (defun new-defun-args (args tag) (let* ((nm (si::funid-to-sym (car args))) (args (ttl-tag-src args tag nm)) (args (cdr args)) (ll (pop args)) (opts (member-if (lambda (x) (member x '(&optional &rest &key &aux))) ll)));FIXME centralize (multiple-value-bind (doc decls ctps args) (parse-body-header args) (let* ((regs (ldiff ll opts)) (dl (decl-safety decls)) (sl (effective-safety decls)) (s (> sl 0)) (od (split-decls regs decls)) (rd (pop od)) (oc (split-ctps regs ctps)) (rc (pop oc)) ;FIXME check-type must refer to top regular variable binding, but must be beneath argument number logic (oc (append (when s rc) (car oc))) (rc (mapcar (lambda (x) `(declare (,@(when s `(hint)) ,(caddr x) ,(cadr x)))) rc)) (rc (cons `(declare (optimize (safety ,dl))) rc)) (narg (when opts +nargs+));FIXME (cdr opts) (nr (length regs)) (regs (or regs (when narg (list +first+)))) (m (min 63 (mll ll))) (args `(,@(car od) ,@oc ,@args)) (opts (if narg (cons narg opts) opts)) (args (if narg (cons `(declare ((integer ,(- m) ,m) ,narg)) args) args)) (rc (if narg (cons `(declare (hint (integer ,(- m) ,m) ,narg)) rc) rc)) (opts `(,+fun+ ,+mv+ ,@opts)) (args `((declare (ignorable ,+fun+ ,+mv+) (fixnum ,+mv+)) ,@args)) (vals `((fun-fun) (fun-valp) ,@(when narg `((vfun-nargs)))));FIXME (bl (list (blla opts vals nil args narg nr (when (eq (car regs) +first+) +first+))))) `(,nm ,regs ,@(when doc `(,doc)) ,@rd ,@rc ,@bl))))) ;; (defun new-defun-args (args &optional (tag (tmpsym))) ;; (let* ((nm (si::funid-to-sym (car args))) ;; (args (ttl-tag-src args tag nm)) ;; (args (cdr args)) ;; (ll (pop args)) ;; (opts (member-if (lambda (x) (member x '(&optional &rest &key &aux))) ll)));FIXME centralize ;; (multiple-value-bind ;; (doc decls ctps args) ;; (parse-body-header args) ;; (let* ((regs (ldiff ll opts)) ;; (dl (decl-safety decls)) ;; (sl (effective-safety decls)) ;; (s (> sl 0)) ;; (od (split-decls regs decls)) ;; (rd (pop od)) ;; (oc (split-ctps regs ctps)) ;; (rc (pop oc)) ;; (oc (append (when s rc) (car oc))) ;; (rc (mapcar (lambda (x) `(declare (,@(when s `(hint)) ,(caddr x) ,(cadr x)))) rc)) ;; (rc (cons `(declare (optimize (safety ,dl))) rc)) ;; (narg (when opts +nargs+)) ;; (nr (length regs)) ;; (regs (or regs (when narg (list +first+)))) ;; (m (min 63 (mll ll))) ;; (args `(,@(car od) ,@oc ,@args)) ;; (opts (if narg (cons narg opts) opts)) ;; (args (if narg `((declare ((integer ,(- m) ,m) ,narg)) ,@args) args)) ;; (opts (cons +mv+ opts)) ;; (args `((declare (ignorable ,+mv+) (fixnum ,+mv+)) ,@args)) ;; (vals `((fun-valp) ,@(when narg `((vfun-nargs)))));FIXME ;; (bl (list (blla opts vals nil args narg nr (when (eq (car regs) +first+) +first+)))) ;; (bl `((let ((,+fun+ (fun-fun))) (declare (ignorable ,+fun+)) (bind-reg-clv) ,@bl)))) ;; `(,nm ,regs ;; ,@(when doc `(,doc)) ;; ,@rd ,@rc ,@bl))))) ;; (defun new-defun-args (args &optional (tag (tmpsym))) ;; (let* ((nm (si::funid-to-sym (car args))) ;; (args (ttl-tag-src args tag nm)) ;; (args (cdr args)) ;; (ll (pop args)) ;; (opts (member-if (lambda (x) (member x '(&optional &rest &key &aux))) ll)));FIXME centralize ;; (multiple-value-bind ;; (doc decls ctps args) ;; (parse-body-header args) ;; (let* ((regs (ldiff ll opts)) ;; (dl (decl-safety decls)) ;; (sl (effective-safety decls)) ;; (s (> sl 0)) ;; (od (split-decls regs decls)) ;; (rd (pop od)) ;; (oc (split-ctps regs ctps)) ;; (rc (pop oc)) ;; (oc (append (when s rc) (car oc))) ;; (rc (mapcar (lambda (x) `(declare (,@(when s `(hint)) ,(caddr x) ,(cadr x)))) rc)) ;; (rc (cons `(declare (optimize (safety ,dl))) rc)) ;; (narg (when opts +nargs+)) ;; (nr (length regs)) ;; (regs (or regs (when narg (list +first+)))) ;; (m (min 63 (mll ll))) ;; (args `(,@(car od) ,@oc (bind-reg-clv) ,@args)) ;; (opts (if narg (cons narg opts) opts)) ;; (args (if narg `((declare ((integer ,(- m) ,m) ,narg)) ,@args) args)) ;; (opts (cons +fun+ (cons +mv+ opts))) ;; (args `((declare (ignorable ,+fun+ ,+mv+) (fixnum ,+mv+)) ,@args)) ;; (vals `((fun-fun) (fun-valp) ,@(when narg `((vfun-nargs)))));FIXME ;; (bl (list (blla opts vals nil args narg nr (when (eq (car regs) +first+) +first+))))) ;; `(,nm ,regs ;; ,@(when doc `(,doc)) ;; ,@rd ,@rc ,@bl))))) ;; (defun new-defun-args (args &optional (tag (tmpsym))) ;; (let* ((nm (si::funid-to-sym (car args))) ;; (args (ttl-tag-src args tag nm)) ;; (args (cdr args)) ;; (ll (pop args)) ;; (opts (member-if (lambda (x) (member x '(&optional &rest &key))) ll))) ;; (multiple-value-bind ;; (doc decls ctps args) ;; (parse-body-header args) ;; (let* ((regs (ldiff ll opts)) ;; (dl (decl-safety decls)) ;; (sl (effective-safety decls)) ;; (s (> sl 0)) ;; (rd (split-decls regs decls)) ;; (od (cadr rd)) ;; (rd (car rd)) ;; (rc (split-ctps regs ctps)) ;; (oc (cadr rc)) ;; (rc (car rc)) ;; (oc (append (when s rc) oc)) ;; (rc (mapcar (lambda (x) `(declare (,@(when s `(hint)) ,(caddr x) ,(cadr x)))) rc)) ;; (rc (cons `(declare (optimize (safety ,dl))) rc)) ;; (narg (when opts +nargs+)) ;; (nr (length regs)) ;; (regs (or regs (when narg (list +first+)))) ;; (m (min 63 (mll ll))) ;; (args `(,@od ,@oc (bind-reg-clv) ,@args)) ;; (opts (if narg (cons narg opts) opts)) ;; (args (if narg `((declare ((integer ,(- m) ,m) ,narg)) ,@args) args)) ;; (opts (cons +fun+ (cons +mv+ opts))) ;; (args `((declare (ignorable ,+fun+ ,+mv+) (fixnum ,+mv+)) ,@args)) ;; (vals `((fun-fun) (fun-valp) ,@(when narg `((vfun-nargs)))));FIXME ;; (bl (list (blla opts vals nil args narg nr (when (eq (car regs) +first+) +first+))))) ;; `(,nm ,regs ;; ,@(when doc `(,doc)) ;; ,@rd ,@rc ,@bl))))) (defun c1va-pop (args) (declare (ignore args)) `(location ,(make-info :type #tt :flags (iflags side-effects)) (inline 0 "va_arg(ap,object)" nil))) (setf (get 'va-pop 'c1) 'c1va-pop) (defun c1vfun-nargs (args) (declare (ignore args)) (list 'location (make-info :type #t(integer -63 63)) (list 'inline-fixnum 0 "fcall.argd" nil))) (setf (get 'vfun-nargs 'c1) 'c1vfun-nargs) (defun c1fun-valp (args) (declare (ignore args)) (list 'location (make-info :type #tfixnum) (list 'inline-fixnum 0 "fcall.valp" nil))) (setf (get 'fun-valp 'c1) 'c1fun-valp) (defun c1fun-fun (args) (declare (ignore args)) (list 'fun-fun (make-info :type #tt))) (defun c2fun-fun nil (unwind-exit (list 'fun-fun) nil 'single-value)) (defun wt-fun-fun nil (wt "fcall.fun;") (wt-nl "#undef base0") (wt-nl "#define base0 ") (wt *value-to-go*) (wt "->fun.fun_env") (wt-nl)) (setf (get 'fun-fun 'c1) 'c1fun-fun) (setf (get 'fun-fun 'c2) 'c2fun-fun) (setf (get 'fun-fun 'wt-loc) 'wt-fun-fun) (defmacro side-effects nil nil) (defun c1side-effects (args) (declare (ignore args)) (mapc (lambda (x &aux (b (get-vbind x))) (when b (unless (eq 'var (car (binding-form b))) (setf (binding-repeatable b) nil)))) *vars*) (list 'side-effects (make-info :flags (iflags side-effects)))) (defun c2side-effects nil nil) (setf (get 'side-effects 'c1) 'c1side-effects) (setf (get 'side-effects 'c2) 'c2side-effects) (defun c1bind-reg-clv (args) (declare (ignore args)) (list 'bind-reg-clv (make-info :type #tt :flags (iflags side-effects)))) (defun c2bind-reg-clv (&aux x clb var) (do nil ((not (setq x (pop *reg-clv*) clb (pop x) var (car x))));FIXME ? eliminate clb var here (wt-nl) (setf (var-ref var) (vs-push));FIXME ? clb and ccb vars just appear in info-ref-ccb, only need push clb (wt-vs (var-ref var)) (wt "= " `(gen-loc :object (cvar ,(var-loc var))) ";") (when (var-ref-ccb var) (clink (var-ref var)) (setf (var-ref-ccb var) (ccb-vs-push))))) ;; (defun c2bind-reg-clv (&aux x clb var) ;; (do nil ;; ((not (setq x (pop *reg-clv*) clb (pop x) var (car x))));FIXME ? eliminate clb var here ;; (wt-nl) ;; (setf (var-ref var) (vs-push));FIXME ? clb and ccb vars just appear in info-ref-ccb, only need push clb ;; (wt-vs (var-ref var)) (wt "= " (list 'cvar (var-loc var)) ";") ;; (when (var-ref-ccb var) ;; (clink (var-ref var)) ;; (setf (var-ref-ccb var) (ccb-vs-push))))) ;; (defun c2bind-reg-clv (&aux x clb var) ;; (do nil ;; ((not (setq x (pop *reg-clv*) clb (pop x) var (car x)))) ;; (wt-nl) ;; (cond (clb ;; (setf (var-ref var) (vs-push));FIXME ? ;; (wt-vs (var-ref var)) (wt "= " (list 'cvar (var-loc var)) ";")) ;; ((setf (var-ref var) (list 'cvar (var-loc var))))) ;; (when (var-ref-ccb var) ;; (clink (var-ref var)) ;; (setf (var-ref-ccb var) (ccb-vs-push))))) ;; (defun c2bind-reg-clv (&aux var) ;; (do nil ;; ((not (setq var (pop *reg-clv*)))) ;; (wt-nl) ;; (cond ((and (var-ref-ccb var) (not (eq 'clb (var-loc var)))) ;; (setf (var-ref var) (list 'cvar (var-loc var))) ;; (clink (var-ref var)) ;; (setf (var-ref-ccb var) (ccb-vs-push))) ;; ((setf (var-ref var) (vs-push));FIXME ;; (wt-vs (var-ref var)) (wt "= " (list 'cvar (var-loc var)) ";"))))) (setf (get 'bind-reg-clv 'c1) 'c1bind-reg-clv) (setf (get 'bind-reg-clv 'c2) 'c2bind-reg-clv) (defun c1ub (args) (let* ((key (pop args)) ; (info (make-info :type #topaque :flags (iflags side-effects)));FIXME (info (make-info :type #topaque)) (nargs (c1args args info))) (list* 'ub info key nargs))) (setf (get 'ub 'c1) 'c1ub) (setf (get 'unbox 'c1) 'c1ub) (let ((ars (let ((i -1)) (mapl (lambda (x) (setf (car x) (concatenate 'string "#" (write-to-string (incf i))))) (make-list call-arguments-limit))))) (defun c1lit (args &aux (as ars)) (flet ((as nil (assert as) (pop as))) (let* ((tp (get (pop args) 'cmp-lisp-type :opaque)) (info (make-info :type tp)) ;FIXME boolean (inl (apply 'concatenate 'string (mapcar (lambda (x) (if (stringp x) x (as))) args))) (nargs (mapcan (lambda (x) (unless (stringp x) (list (c1arg (cons 'ub x) info)))) args))) (when (eq tp :opaque) (baboon)) (when (search "=" inl) (setf (info-flags info) (logior (iflags side-effects) (info-flags info)))) (list 'lit info (info-type info) inl nargs (make-vs info)))))) (defun c2lit (tp inl args stores) (let* ((*inline-blocks* 0) (*restore-avma* *restore-avma*)) (unwind-exit (lit-loc tp inl args stores) nil (cons 'values (if (equal tp #t(returns-exactly)) 0 1))) (close-inline-blocks))) ;; (defun c2lit (tp inl args) ;; (let* ((*inline-blocks* 0) ;; (*restore-avma* *restore-avma*)) ;; (unwind-exit (lit-loc tp inl args) nil (cons 'values (if (eq tp #t(returns-exactly)) 0 1))) ;; (close-inline-blocks))) ;; (defun c2lit (tp inl args) ;; (let* ((sig (list (mapcar (lambda (x) (info-type (cadr x))) args) tp)) ;; (*inline-blocks* 0) ;; (*restore-avma* *restore-avma*)) ;; (unwind-exit (get-inline-loc (list (car sig) (cadr sig) (flags rfa) inl) args) ;; nil (cons 'values (if (eq (cadr sig) #t(returns-exactly)) 0 1))) ;; (close-inline-blocks))) (setf (get 'lit 'c1) 'c1lit) (setf (get 'lit 'c2) 'c2lit) (defun ttl-ll (ll) (let ((a (member '&aux ll))) (ldiff ll a))) (defun suppress-unfinalized-local-fun-warnings (name b l) (let ((fun (local-fun-p name))) (when fun (member-if (lambda (x) (when (fun-p x) (unless (eq x fun) (not (consp (if (eq b 'cb) (fun-c1cb x) (fun-c1 x))))))) (append (info-ref (cadr l)) (info-ref-ccb (cadr l))))))) (defun do-l1-fun (name src e b &aux (wns *warning-note-stack*) (*recursion-detected* (cons (list name) *recursion-detected*))) (let* ((l (c1lambda-expr src)) (osig (car e)) (sig (lam-e-to-sig l)) (rd (cdar *recursion-detected*)) (rep (when rd (not (type<= (cadr sig) (cadr osig))))) (sig (if (and osig rep) (list (car sig) (bbump-tp (cadr sig))) sig))) (setf (car e) sig); (cadr e) *callees*) (cond (rep (keyed-cmpnote (list name 'recursion) "Reprocessing ~s: ~s ~s" name osig sig) (setq *warning-note-stack* wns);FIXME try to use with-restore-vars (do-l1-fun name src e b)) (l)))) ;; (defun do-l1-fun (name src e b &aux *callees* (*recursion-detected* (cons (list name) *recursion-detected*)) ;; *warning-note-stack* *undefined-vars*) ;; (let* ((l (c1lambda-expr src)) ;; (osig (car e)) ;; (sig (lam-e-to-sig l)) ;; (rd (cdar *recursion-detected*)) ;; (sig (if rd (list (car sig) (bbump-tp (cadr sig))) sig))) ;; (setf (car e) sig (cadr e) *callees*) ;; (if (and rd (not (eq (cadr osig) (cadr sig)))) ;; (progn ;; (keyed-cmpnote (list name 'recursion) "Reprocessing ~s: ~s ~s" name osig sig) ;; (do-l1-fun name src e b)) ;; (progn ;; (unless (suppress-unfinalized-local-fun-warnings name b l) ;; (output-warning-note-stack)) ;; l)))) ;; (defun do-l1-fun (name src e &aux *callees* (*recursion-detected* (cons (list name) *recursion-detected*)) *warning-note-stack*) ;; (let* ((l (c1lambda-expr src)) ;; (osig (car e)) ;; (sig (lam-e-to-sig l)) ;; (rd (cdar *recursion-detected*)) ;; (sig (if rd (list (car sig) (bbump-tp (cadr sig))) sig))) ;; (setf (car e) sig (cadr e) *callees*) ;; (if (and rd (not (eq (cadr osig) (cadr sig)))) ;; (progn (keyed-cmpnote (list name 'recursion) "Reprocessing ~s: ~s ~s" name osig sig) (do-l1-fun name src e)) ;; l))) ;; (defun do-l1-fun (name src e &aux *callees* *recursion-detected* *warning-note-stack*) ;; (let* ((l (c1lambda-expr src)) ;; (osig (car e)) ;; (sig (lam-e-to-sig l)) ;; (sig (if *recursion-detected* (list (car sig) (bbump-tp (cadr sig))) sig))) ;; (setf (car e) sig (cadr e) *callees*) ;; (if (and *recursion-detected* (not (eq (cadr osig) (cadr sig)))) ;; (progn (keyed-cmpnote (list name 'recursion) "Reprocessing ~s: ~s ~s" name osig sig) (do-l1-fun name src e)) ;; l))) ;; (defun do-l1-fun (name src e &aux *callees* *recursion-detected* *warning-note-stack*) ;; (let* ((l (c1lambda-expr src)) ;; (osig (car e)) ;; (sig (lam-e-to-sig l)) ;; (sig (if *recursion-detected* (list (car sig) (bbump-tp (cadr sig))) sig))) ;; (setf (car e) sig (cadr e) *callees*) ;; (if (and *recursion-detected* (not (eq (cadr osig) (cadr sig)))) ;; (do-l1-fun name src e) ;; l))) ;; (defun do-l1-fun (name src e &aux *callees* *recursion-detected* *warning-note-stack*) ;; (let* ((l (c1lambda-expr src)) ;; (osig (car e)) ;; (sig (lam-e-to-sig l)) ;; (sig (if *recursion-detected* (list (car sig) (bbump-tp (cadr sig))) sig))) ;; (setf (car e) sig (cadr e) *callees*) ;; (cond ((and *recursion-detected* (not (eq (cadr osig) (cadr sig)))) ;; (do-l1-fun name src e)) ;; (t (output-warning-note-stack) l)))) ;; (defun do-l1-fun (name src e &aux *callees* *recursion-detected* *warning-note-stack*) ;; (let* ((l (c1lambda-expr src name)) ;; (osig (car e)) ;; (sig (lam-e-to-sig l)) ;; (sig (if *recursion-detected* (list (car sig) (bbump-tp (cadr sig))) sig))) ;; (setf (car e) sig (cadr e) *callees*) ;; (cond ((and *recursion-detected* (not (eq (cadr osig) (cadr sig)))) ;; (do-l1-fun name src e)) ;; (t (output-warning-note-stack) l)))) ; (unless (member v (caaddr l));FIXME not in info referred? ; (when (and (var-p v) (var-cb v)) ; ))) (defun get-clv (l &aux (i (cadr l))) (mapcan (lambda (v) (when (var-p v) (list (list v nil)))) (append (info-ref-ccb i) (info-ref-clb i)))) ;; (defun get-clv (l &aux r) ;; (do-referred-cb (v (cadr l)) (push (list (var-name v) (car (atomic-tp (var-type v)))) r)) ;; (nreverse r)) (defvar *top-tag* nil) (defun top-level-src-p nil (not (member *top-tag* *lexical-env-mask*))) (defun do-fun (name src e vis b) (let* ((*vars* (when b (cons b *vars*))) (*funs* (when b (cons b *funs*))) (*blocks* (when b (cons b *blocks*))) (*tags* (when b (cons b *tags*))) (*top-tag* (make-tag)) (*tags* (cons *top-tag* *tags*)) (tag (make-ttl-tag)) (*prev-sri* (append *src-inline-recursion* *prev-sri*)) (*src-inline-recursion* (when vis (list (make-tagged-sir (list (sir-name name)) tag (ttl-ll (cadr src)))))) (*c1exit* (list (make-c1exit name))) (*current-form* `(defun ,name)) (l (do-l1-fun name (cdr (new-defun-args src tag)) e b)) (clv (get-clv l))) (setf (car e) (export-sig (car e)) (second e) (mapcan (lambda (x) (when (symbolp x) (list (cons x (get-sig x))))) (info-ref (cadr l))) (third e) (list src clv name) (fourth e) *function-filename* (fifth e) (if (= (length clv) 0) 1 0) (sixth e) name) (when *sig-discovery* (when (symbol-package name) (unless (eq name 'lambda) (push (cons name (apply 'si::make-function-plist e)) si::*sig-discovery-props*)))) l)) ;; (defun do-fun (name src e vis b) ;; (let* ((*vars* (when b (cons b *vars*))) ;; (*funs* (when b (cons b *funs*))) ;; (*blocks* (when b (cons b *blocks*))) ;; (*tags* (when b (cons b *tags*))) ;; (tag (tmpsym)) ;; (*prev-sri* (append *src-inline-recursion* *prev-sri*)) ;; (*src-inline-recursion* (when vis (list (list (list (sir-name name)) tag (ttl-ll (cadr src)))))) ;; (*c1exit* (list name)) ;; (*current-form* `(defun ,name)) ;; (l (do-l1-fun name (cdr (new-defun-args src tag)) e)) ;; (clv (get-clv l))) ;; (setf (car e) (export-sig (car e)) ;; (third e) (list src clv name) ;; (fourth e) (unless *compiler-compile* (namestring (truename (pathname *compiler-input*)))) ;; (fifth e) (if (= (length clv) 0) 1 0)) ;; (if (suppress-unfinalized-local-fun-warnings name b l) ;; (output-warning-note-stack)) ;; l)) ;; (defun do-fun (name src e vis b) ;; (let* ((*vars* (when b (cons b *vars*))) ;; (*funs* (when b (cons b *funs*))) ;; (*blocks* (when b (cons b *blocks*))) ;; (*tags* (when b (cons b *tags*))) ;; (tag (tmpsym)) ;; (*prev-sri* (append *src-inline-recursion* *prev-sri*)) ;; (*src-inline-recursion* (when vis (list (list (list (sir-name name)) tag (ttl-ll (cadr src)))))) ;; *provisional-inline* ;; (*c1exit* (list name)) ;; (*current-form* `(defun ,name)) ;; (l (do-l1-fun name (cdr (new-defun-args src tag)) e)) ;; (clv (get-clv l))) ;; (setf (car e) (export-sig (car e)) ;; (third e) (list src clv name) ;; (fourth e) (unless *compiler-compile* (namestring (truename (pathname *compiler-input*)))) ;; (fifth e) (if (= (length clv) 0) 1 0)) ;; l)) ;; (defun do-fun (name src e vis b) ;; (let* ((*vars* (when b (cons b *vars*))) ;; (*funs* (when b (cons b *funs*))) ;; (*blocks* (when b (cons b *blocks*))) ;; (*tags* (when b (cons b *tags*))) ;; (tag (tmpsym)) ;; (*prev-sri* (append *src-inline-recursion* *prev-sri*)) ;; (*src-inline-recursion* (when vis (list (list (list (sir-name name)) tag (ttl-ll (cadr src)))))) ;; *provisional-inline* ;; (*c1exit* (list name)) ;; (*current-form* `(defun ,name)) ;; (l (do-l1-fun name (cdr (new-defun-args src tag)) e)) ;; (clv (get-clv l))) ;; (setf (car e) (export-sig (car e)) ;; (third e) (compress-fle src clv name) ;; (fourth e) (unless *compiler-compile* (namestring (pathname *compiler-input*))) ;; (fifth e) (if (= (length clv) 0) 1 0)) ;; l)) (defun t1defun (args &aux *warning-note-stack*) (when (or (endp args) (endp (cdr args))) (too-few-args 'defun 2 (length args))) (maybe-eval nil (cons 'defun args)) (let* ((fname (car args)) (fname (or (function-symbol fname) (cmperr "The function name ~s is not valid." fname))) (cfun (next-cfun)) (oal (get-arg-types fname)) (ort (get-return-type fname)) (osig (export-sig (list oal ort))) (e (or (gethash fname *sigs*) (setf (gethash fname *sigs*) (make-list 6)))) (setjmps *setjmps*) (lambda-expr (do-fun fname args e t nil)) (sig (car e)) (osig (if (equal '((*) *) osig) sig osig));FIXME (doc (cadddr lambda-expr))) (or (eql setjmps *setjmps*) (setf (info-volatile (cadr lambda-expr)) 1)) (keyed-cmpnote (list 'return-type fname) "~s return type ~s" fname (c1retnote lambda-expr)) (unless (or (equal osig sig) (eq fname 'cmp-anon));FIXME (cmpwarn "signature change on function ~s,~% ~s -> ~s~%" fname (ex-sig osig) (ex-sig sig)) (setq *new-sigs-in-file* (some (lambda (x) (unless (eq x fname) (multiple-value-bind (s f) (gethash x *sigs*) (declare (ignore s)) (when f (list x fname osig sig))))) (si::callers fname)))) (push (let* ((at (car sig)) (al (mapcar (lambda (x) (link-rt x nil)) at)) (rt (link-rt (cadr sig) nil))) (list fname al rt (if (single-type-p rt) (flags set ans) (flags set ans sets-vs-top)) (make-inline-string cfun at fname))) *inline-functions*) (push (list 'defun fname cfun lambda-expr doc nil nil) *top-level-forms*) (push (cons fname cfun) *global-funs*) (output-warning-note-stack))) ;; (defun t1defun (args) ;; (when (or (endp args) (endp (cdr args))) ;; (too-few-args 'defun 2 (length args))) ;; (maybe-eval nil (cons 'defun args)) ;; (let* ((fname (car args)) ;; (fname (or (function-symbol fname) (cmperr "The function name ~s is not valid." fname))) ;; (cfun (next-cfun)) ;; (oal (get-arg-types fname)) (ort (get-return-type fname)) ;; (osig (export-sig (list oal ort))) ;; (e (or (gethash fname *sigs*) (setf (gethash fname *sigs*) (make-list 5)))) ;; (setjmps *setjmps*) ;; (lambda-expr (do-fun fname args e t nil)) ;; (sig (car e)) ;; (osig (if (equal '((*) *) osig) sig osig));FIXME ;; (doc (cadddr lambda-expr))) ;; (or (eql setjmps *setjmps*) (setf (info-volatile (cadr lambda-expr)) 1)) ;; (keyed-cmpnote (list 'return-type fname) "~s return type ~s" fname (c1retnote lambda-expr)) ;; (unless (or (equal osig sig) (eq fname 'cmp-anon));FIXME ;; (cmpwarn "signature change on function ~s, ~s -> ~s~%" fname osig sig) ;; (setq *new-sigs-in-file* ;; (some ;; (lambda (x) ;; (unless (eq x fname) ;; (multiple-value-bind ;; (s f) (gethash x *sigs*) ;; (declare (ignore s)) ;; (when f (list x fname osig sig))))) (si::callers fname)))) ;; (push (let* ((at (car sig)) ;; (al (mapcar (lambda (x) (link-rt (cmp-norm-tp x) nil)) at)) ;; (rt (link-rt (cmp-norm-tp (cadr sig)) nil))) ;; (list fname al rt ;; (if (single-type-p rt) (flags set ans) (flags set ans sets-vs-top)) ;; (make-inline-string cfun at fname))) ;; *inline-functions*) ;; (push (list 'defun fname cfun lambda-expr doc nil) *top-level-forms*) ;; (push (cons fname cfun) *global-funs*) ;; (when *sig-discovery* ;; (si::add-hash fname (car e) (cadr e) nil nil)))) (defun make-inline-string (cfun args fname) (format nil "~d(~a)" (c-function-name "LI" cfun fname) (make-inline-arg-str (list args (get-return-type fname))))) (defun cs-push (&optional type local) (let ((tem (next-cvar))) (let ((type (if (or (not type) (eq type 'object)) t type))) (when (or (not local) (not (eq type t))) (push (if local (cons tem type) (cons type 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))) (let ((x (promoted-c-type x))) (let ((x (position x +c-global-arg-types+ :test 'type<=))) (if x (1+ x) 0)))) (defun new-proclaimed-argd (args return) (do* ((type (f-type return) (f-type (pop args))) (i 0 (+ 2 i)) (ans type (logior ans (ash type i)))) ((or (>= i 32) (null args)) ans))) (defun type-f (x) (declare (fixnum x)) (if (zerop x) t (nth (1- x) +c-global-arg-types+))) (defun argsizes (args return &optional max pushed) (let* ((x (vald return)) (vv (or (> x 0) (when (zerop x) (not (single-type-p return))))) (x (if vv x (- x))) (la (length args)) (varg (eq (car (last args)) '*)) (la (if varg (1- la) la))) (let ((r (logior la (ash (or max la) 6) (ash x 12) (ash (if vv 1 0) 17) (ash (if varg 1 0) 18) (ash (if pushed 1 0) 19)))) (when (< r 0) (print r) (break)) r))) (defun vald (tp) (cond ((single-type-p tp) 0) ((type>= #t(values t) tp) 0) ((eq tp '*) (- multiple-values-limit 2)) ((> (length tp) multiple-values-limit) (baboon));FIXME ((eq (car tp) 'returns-exactly) (- 2 (length tp))) ((- (length tp) 2)))) (defun ty-contains-binding-p (tp) (typecase tp (binding t) (atom nil) (cons (or (ty-contains-binding-p (car tp)) (ty-contains-binding-p (cdr tp)))))) (defun ex-tp (tp) (if (ty-contains-binding-p tp) (car tp) tp)) (defun exp-sig (sig) (list (mapcar 'ex-tp (car sig)) (if (consp (cadr sig)) (cons (caadr sig) (mapcar 'ex-tp (cdadr sig))) (ex-tp (cadr sig))))) (defun ex-sig (sig) (list (mapcar 'cmp-unnorm-tp (car sig)) (cmp-unnorm-tp (cadr sig)))) (defun export-call-struct (l) `(apply 'make-function-plist ',(exp-sig (pop l)) ',(pop l) ',(apply 'compress-fle (pop l)) ',l)) (defun wt-if-proclaimed (fname cfun lambda-expr macro-p) (when (fast-link-proclaimed-type-p fname);(and (not (member '* (get-arg-types fname)))) (let* ((sig (lam-e-to-sig lambda-expr)) (at (pop sig)) (rt (car sig))) (cond ((assoc fname *inline-functions*) (let ((finit `(init-function ,(export-call-struct (gethash fname *sigs*)) ,(add-address (c-function-name "LI" cfun fname)) nil nil -1 ,(new-proclaimed-argd at rt) ,(argsizes at rt (xa lambda-expr))))) (add-init `(fset ',fname ,(if macro-p `(cons 'macro ,finit) finit))))) ((let ((arg-c (length (car (lambda-list lambda-expr)))) (arg-p (length at)) (va (member '* at))) (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 wt-if-proclaimed (fname cfun lambda-expr macro-p) ;; (when (fast-link-proclaimed-type-p fname);(and (not (member '* (get-arg-types fname)))) ;; (let* ((sig (lam-e-to-sig lambda-expr)) ;; (at (pop sig)) ;; (rt (car sig))) ;; (cond ((assoc fname *inline-functions*) ;; (add-init `(si::init-function ',(if macro-p (cons 'macro fname) fname) ;; ,(add-address (c-function-name "LI" cfun fname)) ;; nil nil -1 ,(new-proclaimed-argd at rt) ;; ,(argsizes at rt (xa lambda-expr))))) ;; ((let ((arg-c (length (car (lambda-list lambda-expr)))) ;; (arg-p (length at)) ;; (va (member '* at))) ;; (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 wt-if-proclaimed (fname cfun lambda-expr) ;; (when (fast-link-proclaimed-type-p fname);(and (not (member '* (get-arg-types fname)))) ;; (let ((at (get-arg-types fname)) ;; (rt (get-return-type fname))) ;; (cond ((assoc fname *inline-functions*) ;; (add-init `(si::init-function ',fname ;; ,(add-address (c-function-name "LI" cfun fname)) ;; nil nil -1 ,(new-proclaimed-argd at rt) ;; ,(argsizes at rt (xa lambda-expr))))) ;; ((let ((arg-c (length (car (lambda-list lambda-expr)))) ;; (arg-p (length at)) ;; (va (member '* at))) ;; (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) 0) "VOL " "")) (defun register (var) (cond ((and (equal *volatile* "") (>= (the fixnum (var-register var)) (the fixnum *register-min*))) "register ") (t ""))) (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)) 63) (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*))) ;FIXME obsolete ;; (defun collect-objects (le) ;; (cond ((atom le) nil) ;; ((and (eq (car le) 'location) (consp (caddr le)) (eq (caaddr le) 'vv)) ;; (list (or (car (member (cadr (caddr le)) *top-level-forms* :key 'cadr)) ;; (aref (data-vector) (cadr (caddr le)))))) ;; ((append (collect-objects (car le)) (collect-objects (cdr le)))))) (defun xa (l) (let ((v (is-narg-le l))) (if v (or (cadr (real-bnds (var-type v))) (baboon)) (length (caaddr l))))) (defun global-type-bump (tp) (let* ((mv (cmpt tp)) (tpp (nil-to-t (if mv (coerce-to-one-value tp) tp))) (tppn (car (member tpp `(,@+c-global-arg-types+ ,#tt ,#t*) :test 'type<=))));FIXME (if mv `(,(car tp) ,@(when (cdr tp) `(,tppn)) ,@(cddr tp)) tppn))) (defun t2defun (fname cfun lambda-expr doc sp macro-p) (declare (ignore cfun lambda-expr doc sp macro-p)) (cond ((get fname 'no-global-entry)(return-from t2defun nil))) (when (< *space* 2) (setf (get fname 'debug-prop) t))) ;; (defun t2defun (fname cfun lambda-expr doc sp) ;; (declare (ignore sp)) ;; (cond ((get fname 'no-global-entry)(return-from t2defun nil))) ;; (when doc (add-init `(si::putprop ',fname ,doc 'si::function-documentation))) ;; (cond ((wt-if-proclaimed fname cfun lambda-expr)) ;; ((numberp cfun) ;; (let ((at (mapcar 'global-type-bump (get-arg-types fname))) ;; (rt (global-type-bump (get-return-type fname)))) ;; (add-init `(si::init-function ;; ',fname ;; ; ,(add-address (c-function-name "LI" (format nil "G~a" cfun) fname)) ;; ,(add-address (c-function-name "LI" (format nil "~a" cfun) fname)) ;; nil nil -1 ,(new-proclaimed-argd at rt) ;; ,(argsizes at rt (xa lambda-expr))))) ;; ; (wt-h "static void " (c-function-name "L" cfun fname) "();") ;; ; (add-init `(si::mf ',fname ,(add-address (c-function-name "L" cfun fname)))) ;; ) ;; (t (baboon)(wt-h cfun "();") ;; (add-init `(si::mf ',fname ,(add-address (c-function-name "" cfun fname)))))) ;; (when *compiler-auto-proclaim* ;; (add-init `(si::add-hash ',fname ,@(mapcar (lambda (x) `(quote ,x)) (export-call (gethash fname *sigs*)))))) ;; (when (< *space* 2) ;; (setf (get fname 'debug-prop) t))) ;; (defun t2defun (fname cfun lambda-expr doc sp) ;; (declare (ignore sp)) ;; (cond ((get fname 'no-global-entry)(return-from t2defun nil))) ;; (when doc (add-init `(si::putprop ',fname ,doc 'si::function-documentation))) ;; (cond ((wt-if-proclaimed fname cfun lambda-expr)) ;; ((numberp cfun) ;; (let ((at (mapcar 'global-type-bump (get-arg-types fname))) ;; (rt (global-type-bump (get-return-type fname)))) ;; (add-init `(si::init-function ;; ',fname ;; ; ,(add-address (c-function-name "LI" (format nil "G~a" cfun) fname)) ;; ,(add-address (c-function-name "LI" (format nil "~a" cfun) fname)) ;; nil nil -1 ,(new-proclaimed-argd at rt) ;; ,(argsizes at rt (xa lambda-expr))))) ;; ; (wt-h "static void " (c-function-name "L" cfun fname) "();") ;; ; (add-init `(si::mf ',fname ,(add-address (c-function-name "L" cfun fname)))) ;; ) ;; (t (baboon)(wt-h cfun "();") ;; (add-init `(si::mf ',fname ,(add-address (c-function-name "" cfun fname)))))) ;; (when *compiler-auto-proclaim* ;; (add-init `(si::add-hash ',fname ,@(mapcar (lambda (x) `(quote ,x)) (gethash fname *sigs*))))) ;; (when (< *space* 2) ;; (setf (get fname 'debug-prop) t))) (defun si::add-debug (fname x) (si::putprop fname x 'si::debugger)) (defun t3init-fun (fname cfun lambda-expr doc macro-p) (when doc (add-init `(putprop ',fname ,doc 'function-documentation))) (unless (wt-if-proclaimed fname cfun lambda-expr macro-p) (assert (numberp cfun)) (let* ((sig (lam-e-to-sig lambda-expr)) (at (mapcar 'global-type-bump (pop sig))) (rt (global-type-bump (car sig))) (finit `(init-function ,(export-call-struct (gethash fname *sigs*)) ,(add-address (c-function-name "LI" (format nil "~a" cfun) fname)) nil nil -1 ,(new-proclaimed-argd at rt) ,(argsizes at rt (xa lambda-expr))))) (add-init `(fset ',fname ,(if macro-p `(cons 'macro ,finit) finit)))))) ;; (defun t3init-fun (fname cfun lambda-expr doc macro-p) ;; (when doc (add-init `(putprop ',fname ,doc 'function-documentation))) ;; (unless (wt-if-proclaimed fname cfun lambda-expr macro-p) ;; (assert (numberp cfun)) ;; (let* ((sig (lam-e-to-sig lambda-expr)) ;; (at (mapcar 'global-type-bump (pop sig))) ;; (rt (global-type-bump (car sig)))) ;; (add-init `(init-function ;; ',(if macro-p (cons 'macro fname) fname) ;; ,(add-address (c-function-name "LI" (format nil "~a" cfun) fname)) ;; nil nil -1 ,(new-proclaimed-argd at rt) ;; ,(argsizes at rt (xa lambda-expr)))))) ;; (when *compiler-auto-proclaim* ;; (push `(si::add-hash ',fname ,@(mapcar (lambda (x) `(quote ,x)) (export-call (gethash fname *sigs*)))) *add-hash-calls*))) ;; (defun t3init-fun (fname cfun lambda-expr doc) ;; (when doc (add-init `(putprop ',fname ,doc 'function-documentation))) ;; (unless (wt-if-proclaimed fname cfun lambda-expr) ;; (assert (numberp cfun)) ;; (let* ((sig (lam-e-to-sig lambda-expr)) ;; (at (mapcar 'global-type-bump (pop sig))) ;; (rt (global-type-bump (car sig)))) ;; (add-init `(init-function ;; ',fname ;; ,(add-address (c-function-name "LI" (format nil "~a" cfun) fname)) ;; nil nil -1 ,(new-proclaimed-argd at rt) ;; ,(argsizes at rt (xa lambda-expr)))))) ;; (when *compiler-auto-proclaim* ;; (add-init `(si::add-hash ',fname ,@(mapcar (lambda (x) `(quote ,x)) (export-call (gethash fname *sigs*))))))) ;; (defun t3init-fun (fname cfun lambda-expr doc) ;; (when doc (add-init `(putprop ',fname ,doc 'function-documentation))) ;; (unless (wt-if-proclaimed fname cfun lambda-expr) ;; (assert (numberp cfun)) ;; (let ((at (mapcar 'global-type-bump (get-arg-types fname))) ;; (rt (global-type-bump (get-return-type fname)))) ;; (add-init `(init-function ;; ',fname ;; ,(add-address (c-function-name "LI" (format nil "~a" cfun) fname)) ;; nil nil -1 ,(new-proclaimed-argd at rt) ;; ,(argsizes at rt (xa lambda-expr)))))) ;; (when *compiler-auto-proclaim* ;; (add-init `(si::add-hash ',fname ,@(mapcar (lambda (x) `(quote ,x)) (export-call (gethash fname *sigs*))))))) (defun t3defun (fname cfun lambda-expr doc sp macro-p &aux inline-info ; (macro-p (equal `(mflag ,fname) (cadr (member *current-form* *top-level-forms*)))) (*current-form* (list 'defun fname)) (*volatile* (volatile (second lambda-expr)))) (declare (ignore doc)) (let ((*compiler-check-args* *compiler-check-args*) (*safe-compile* *safe-compile*) (*compiler-push-events* *compiler-push-events*) (*compiler-new-safety* *compiler-new-safety*) (*notinline* *notinline*) (*space* *space*) (*debug* *debug*)) (when (eq (car (caddr (cddr lambda-expr))) 'decl-body) (local-compile-decls (caddr (caddr (cddr lambda-expr))))) (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. ;; (push (list fname cfun (cadr inline-info) (caddr inline-info)) ;; *global-entries*)) ;;; Local entry (analyze-regs (cadr lambda-expr) 0) (mapc (lambda (x) (setf (var-type x) (global-type-bump (var-type x)))) (caaddr lambda-expr)) (setf (info-type (cadr (fifth lambda-expr))) (global-type-bump (info-type (cadr (fifth lambda-expr))))) (setf (caddr inline-info) (global-type-bump (cadr (lam-e-to-sig lambda-expr)))) (t3defun-aux 't3defun-local-entry (or (cdr (assoc (promoted-c-type (caddr inline-info)) +return-alist+)) 'return-object) fname cfun lambda-expr sp inline-info)) ((baboon))) (t3init-fun fname cfun lambda-expr doc macro-p) (add-debug-info fname lambda-expr))) ;; (defun t3defun (fname cfun lambda-expr doc sp &aux inline-info ;; (macro-p (equal `(mflag ,fname) (cadr (member *current-form* *top-level-forms*)))) ;; (*current-form* (list 'defun fname)) ;; (*volatile* (volatile (second lambda-expr)))) ;; (declare (ignore doc)) ;; (let ((*compiler-check-args* *compiler-check-args*) ;; (*safe-compile* *safe-compile*) ;; (*compiler-push-events* *compiler-push-events*) ;; (*compiler-new-safety* *compiler-new-safety*) ;; (*notinline* *notinline*) ;; (*space* *space*) ;; (*debug* *debug*)) ;; (when (eq (car (caddr (cddr lambda-expr))) 'decl-body) ;; (local-compile-decls (caddr (caddr (cddr lambda-expr))))) ;; (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. ;; ;; (push (list fname cfun (cadr inline-info) (caddr inline-info)) ;; ;; *global-entries*)) ;; ;;; Local entry ;; (analyze-regs (cadr lambda-expr) 0) ;; (mapc (lambda (x) (setf (var-type x) (global-type-bump (var-type x)))) (caaddr lambda-expr)) ;; (setf (info-type (cadr (fifth lambda-expr))) (global-type-bump (info-type (cadr (fifth lambda-expr))))) ;; (setf (caddr inline-info) (global-type-bump (cadr (lam-e-to-sig lambda-expr)))) ;; (t3defun-aux 't3defun-local-entry ;; (or (cdr (assoc (promoted-c-type (caddr inline-info)) +return-alist+)) 'return-object) ;; fname cfun lambda-expr sp inline-info)) ;; ((baboon))) ;; (t3init-fun fname cfun lambda-expr doc macro-p) ;; (add-debug-info fname lambda-expr))) ;; (defun t3defun (fname cfun lambda-expr doc sp &aux inline-info ;; (*current-form* (list 'defun fname)) ;; (*volatile* (volatile (second lambda-expr)))) ;; (declare (ignore doc)) ;; (let ((*compiler-check-args* *compiler-check-args*) ;; (*safe-compile* *safe-compile*) ;; (*compiler-push-events* *compiler-push-events*) ;; (*compiler-new-safety* *compiler-new-safety*) ;; (*notinline* *notinline*) ;; (*space* *space*) ;; (*debug* *debug*)) ;; (when (eq (car (caddr (cddr lambda-expr))) 'decl-body) ;; (local-compile-decls (caddr (caddr (cddr lambda-expr))))) ;; (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. ;; ;; (push (list fname cfun (cadr inline-info) (caddr inline-info)) ;; ;; *global-entries*)) ;; ;;; Local entry ;; (analyze-regs (cadr lambda-expr) 0) ;; (let ((lambda-expr (if (fast-link-proclaimed-type-p fname) lambda-expr (ttl-to-top lambda-expr fname)))) ;; (t3defun-aux 't3defun-local-entry ;; (or (cdr (assoc (promoted-c-type (caddr inline-info)) +return-alist+)) 'return-object) ;; fname cfun lambda-expr sp inline-info)) ;; (when (not (fast-link-proclaimed-type-p fname)) ;; (let* ((sig (lam-e-to-sig lambda-expr)) ;; (lsig (list (car sig) (if (type>= #tboolean (cadr sig)) #tt (cadr sig))));FIXME ;; (fun (make-fun :level -1 ;; :info (make-info :type (cadr lsig)) :call (list lsig) ;; :name fname :cfun (format nil "I~a" cfun))) ;; (ttl (find-ttl-vars lambda-expr)) ;; (vp (member-if-not 'var-p ttl)) ;; (ttl (ldiff ttl vp)) ;; (v (mapcar (lambda (x) (list 'var (make-info :type (var-type x)) (list x nil))) ttl)) ;; (tp (cadr sig)) ;; (inline-info (copy-tree inline-info))) ;; (setf (caddr inline-info) (global-type-bump tp)) ;; (rcl lambda-expr fun v fname) ;; (t3defun-aux 't3defun-local-entry ;; (or (cdr (assoc (promoted-c-type (caddr inline-info)) +return-alist+)) 'return-object) ;; fname (format nil "G~a" cfun) lambda-expr sp inline-info)))) ;; ((baboon))) ;; (add-debug-info fname lambda-expr))) (defun t3defun-aux (f *exit* &rest lis) (let-pass3 () (apply f lis))) (defvar *mv-var* nil) ;; (defun tail-recursion-info (fname mv-var ll) ;; (when *do-tail-recursion* ;; (cons fname (append (if mv-var (cdr (car ll)) (car ll)) (ll-optionals ll) (list (ll-rest ll)) (ll-keywords ll))))) ;; (defun tail-recursion-info (fname mv-var l) ;; (declare (ignore mv-var)) ;; (when *do-tail-recursion* ;; (cons fname (find-ttl-vars l)))) (defun t3defun-local-entry (fname cfun lambda-expr sp inline-info &aux specials *reg-clv* (requireds (caaddr lambda-expr)) nargs) (do ((vl requireds (cdr vl)) (types (cadr inline-info) (cdr types))) ((endp vl)) (cond ((eq (var-kind (car vl)) 'special) (push (cons (car vl) (var-loc (car vl))) specials)) ((var-cb (car vl)) (push (list (eq 'clb (var-loc (car vl))) (car vl)) *reg-clv*)) ; ((var-cb (car vl)) (push (car vl) *reg-clv*)) ((setf (var-kind (car vl)) (or (car (member (promoted-c-type (var-type (car vl))) +c-local-arg-types+)) 'object)))) (setf (var-loc (car vl)) (cs-push (var-type (car vl)) t))) (let ((rt (get-return-type fname))) (unless (single-type-p rt) (let ((ns (abs (vald rt)))) (unless (= ns (- multiple-values-limit 2)) (setq *max-vs* (max *max-vs* ns)))))) (when (is-narg-le lambda-expr) (setq nargs (car (last requireds))) (setf (var-register nargs) 0)) (let* ((s (function-string fname)) (g (when (stringp cfun) (char= #\G (char cfun 0))))) (wt-comment (strcat (if g "global" "local") " entry for function ") s)) (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) nil nargs) (wt-h ";") (let* ((cm *reservation-cmacro*)) ;; (tri (tail-recursion-info fname nil lambda-expr)) ;; (*unwind-exit* (if tri (cons 'tail-recursion-mark *unwind-exit*) *unwind-exit*))) (wt-nl1 "{ ") (wt " VMB" cm " VMS" cm " VMV" cm) (when nargs (wt-nl "va_list ap;")(wt-nl "va_start(ap,V" (var-loc nargs) ");")) (when sp (wt-nl "bds_check;")) (when *compiler-push-events* (wt-nl "ihs_check;")) ; (dolist (v clv) (setf (var-ref v) (list 'cvar (var-loc v))) (c2bind v)) (dolist (v specials) (setq *bds-used* t) (wt-nl "bds_bind(" (vv-str (cdr v)) "," `(gen-loc :object (cvar ,(var-loc (car v)))) ");") (push 'bds-bind *unwind-exit*) (setf (var-kind (car v)) 'SPECIAL) (setf (var-loc (car v)) (cdr v))) (let ((*mv-var* (mv-var lambda-expr))) (c2expr (caddr (cddr lambda-expr))) (wt-V*-macros cm (caddr inline-info))) ;;; Make sure to return object if necessary ; (if (equal "object " (rep-type (caddr inline-info))) (wt-nl "return Cnil;")) (when nargs (wt-nl "va_end(ap);")) (wt-nl1 "}"))) (defvar *vararg-use-vs* nil) (defun set-up-var-cvs (var) (setf (var-ref var) (if *vararg-use-vs* (vs-push) (cvs-push)))) ;;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*) (let ((vstb (if (or *mv-var* (> *max-vs* 0) *base-used*) (concatenate 'string " register object * " *volatile* " base=vs_top;") "")) (bdsb (if *bds-used* (concatenate 'string " bds_ptr " *volatile* " old_bds_top=bds_top;") "")) (frsb (if *frame-used* (concatenate 'string " frame_ptr " *volatile* " old_frs_top=frs_top;") ""))) (wt-h "#define VMB" cm vstb bdsb frsb)) (wt-cvars) (cond (*sup-used* (wt-h "#define VMS" cm " register object *" *volatile* "sup=vs_top+" *max-vs* ";vs_top=sup;")) ((zerop *max-vs*) (wt-h "#define VMS" cm)) ((wt-h "#define VMS" cm " vs_top += " *max-vs* ";"))) (cond ((zerop *max-vs*) (wt-h "#define VMV" cm)) (*safe-compile* (wt-h "#define VMV" cm " vs_reserve(" *max-vs* ");")) ((wt-h "#define VMV" cm " vs_check;"))) (let ((vstu (cond (*mv-var* (let ((loc (write-to-string (var-loc *mv-var*)))) (concatenate 'string " if ((b_)>=-1) vs_top=V" loc " ? (object *)V" loc "+(b_) : base;"))) ((or (> *max-vs* 0) *base-used*) " vs_top=base;") (""))) (bdsu (if *bds-used* " for (;bds_top>old_bds_top;) bds_unwind1;" "")) (frsu (if *frame-used* " for (;frs_top>old_frs_top;) frs_pop();" ""))) (wt-h "#define VMRV" cm "(a_,b_)" vstu bdsu frsu " return(a_);") (wt-h "#define VMR" cm "(a_) VMRV" cm "(a_,0);"))) (defun wt-requireds (requireds arg-types &optional first narg) (declare (ignore arg-types)) (flet ((wt (x) (wt x) (let ((*compiler-output1* *compiler-output2*)) (wt x)))) (dolist (v requireds (wt (if narg ",...)" ")"))) (setq narg (or narg (is-narg-var v))) (let ((cvar (cs-push (var-type v) t))) (when first (wt ",")) (setq first t) (setf (var-loc v) cvar) (wt *volatile*) (wt (register v)) (wt (rep-type (var-type v))) (wt "V") (wt cvar))))) ;;Write the required args as c arguments, and declarations for the arguments. (defun wt-requireds-old (requireds arg-types) (do ((vl requireds (cdr vl))) ((endp vl)) (let ((cvar (cs-push (var-type (car vl)) t))) (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 ";")) (if prev-type (wt ";")) (wt *volatile* (register (car vl)) (rep-type (car types)));(var-kind (car vl))));(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::debugger) locals) (let ((locals (get fname 'si::debugger))) (if (and locals (or (cdr locals) (not (null (car locals))))) (add-init `(debug ',fname ',locals) ) )) )))) (defun if1 (f) (flet ((tbp (l) (member-if (lambda (x) (or (tag-p x) (blk-p x))) l))) (not (or (info-ch f) (tbp (info-ref f)) (tbp (info-ref-ccb f)) (tbp (info-ref-clb f)) (/= 0 (logand (info-flags f) (iflags side-effects compiler))))))) ;; (defun if1 (f) ;; (not (or (info-ch f) (info-blocks f) (info-tags f) ;; (iflag-p (info-flags f) side-effects)))) (defun ignorable-form-old (f) (cond ((> (changed-length (cadr f)) 0) nil) ((side-effects-p f) nil) (t))) (defun ignorable-form (f) (case (car f) (function t) ((cadd-dladdress infer-tp) nil) (otherwise (if1 (cadr f))))) ;; (defun ignorable-form (f) ;; (or (eq (car f) 'function) ;; (if1 (cadr f)))) ;; (defun ignorable-form (f) ;; (if1 (cadr f))) ;;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) +c-local-var-types+) (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 (seqind tem real-min this-min want have)) (tagbody START (do-referred (v info) (setq tem (var-register v)) (when (>= tem real-min) (incf have) (when (< tem this-min) (setq this-min tem)) (when (> have want) (go NEXT)))) (when (< have want) (decf real-min)) (do-referred (v info) (when (< (var-register v) real-min) (setf (var-register v) 0))) (return-from analyze-regs1 real-min) NEXT (setq have 0 real-min (1+ this-min) this-min 1000000) (go START)))) (defun find-block-by-name (form name) (cond ((atom form) nil) ((and (eq (car form) 'block) (blk-p (caddr form)) (eq (blk-name (caddr form)) name)) form) ((or (find-block-by-name (car form) name) (find-block-by-name (cdr form) name))))) (defun find-ttl (form name) (cond ((atom form) nil) ((and (consp (car form)) (eq (caar form) 'bind-reg-clv)) (cadr form)) ((or (find-ttl (car form) name) (find-ttl (cdr form) name))))) (defun ttl-to-top (form name) (cond ((atom form) form) ((not (eq (car form) 'lambda)) form) ((list (car form) (cadr form) (caddr form) (cadddr form) (find-ttl (fifth form) name))))) ;; (defun rcl (form fun vars name) ;; (cond ((var-p form) ;; ; (setf form (copy-var form)) ;; (when (eq (var-kind form) 'replaced) ;; (setf (var-kind form) (if (var-aliases form) (var-kind (car (var-aliases form))) 'object)))) ;; ((atom form)) ;; ((and (eq (car form) 'block) (blk-p (caddr form)) (eq (blk-name (caddr form)) name)) ;; (setf (cadddr form) (list 'call-local (fun-info fun) (list fun nil) vars))) ;; ((and (consp (car form)) (eq (caar form) 'bind-reg-clv)) ;; (setf (cadr form) (list 'call-local (fun-info fun) (list fun nil) vars))) ;; ((eq (car form) 'lambda) ;; (mapc (lambda (x) (setf (var-type x) (global-type-bump (var-type x)))) (caaddr form)) ;; (let* ((x (car (last form))) ;; (y (cadr x)) ;; (tp (info-type y))) ;; (setf (info-type y) (global-type-bump tp)) ;; (mapl (lambda (x) (mapl (lambda (y) (when (var-p (car y)) (setf (car y) (copy-var (car y))))) (car x))) (caddr form)) ;; (rcl x fun vars name))) ;; (t (rcl (car form) fun vars name) (rcl (cdr form) fun vars name)))) (defconstant +wt-c-rep-alist+ `((,#tnil ."object ") (,#tchar ."int8_t ") (,#tfixnum ."fixnum ") ; (,#tinteger ."GEN ") ; (,#tcharacter ."unsigned char ") (,#tlong-float ."double ") (,#tshort-float ."float ") (,#tfcomplex ."fcomplex ") (,#tdcomplex ."dcomplex ") (object . "object "))) ;; (defconstant +wt-c-rep-alist+ `((,#tchar ."int8_t ") ;; (,#tfixnum ."fixnum ") ;; ; (,#tinteger ."GEN ") ;; ; (,#tcharacter ."unsigned char ") ;; (,#tlong-float ."double ") ;; (,#tshort-float ."float ") ;; (,#tfcomplex ."fcomplex ") ;; (,#tdcomplex ."dcomplex ") ;; (object . "object "))) (defun rep-type (type &aux (type (if (eq type 'object) t type))) (let ((z (promoted-c-type type))) (or (cdr (assoc z +wt-c-rep-alist+)) "object "))) ;; (defun rep-type (type) ;; (let ((z (promoted-c-type type))) ;; (or (cdr (assoc z +wt-c-rep-alist+)) "object "))) ;; (defun t1defmacro (args &aux (w args) (n (pop args)) (ll (pop args))) ;; (t1expr `(defun ,n ,@(cdr (si::defmacro-lambda n ll args)))) ;; (maybe-eval (not (macro-function n)) (cons 'defmacro w));FIXME? ;; (push `(mflag ,n) *top-level-forms*)) (defun t1macrolet (args &aux env (*funs* *funs*) (*vars* *vars*) (*macrolet-env* *macrolet-env*)) (when (endp args) (too-few-args 'macrolet 1 0)) (dolist (def (car args)) (let* ((x (car def))(y (si::funid-sym x))) (unless (eq x y) (setq def (cons y (cdr def))))) (cmpck (or (endp def) (endp (cdr def))) "The macro definition ~s is illegal." def) (let* ((n (car def)) (b (eval (si::defmacro-lambda n (cadr def) (cddr def))))) (push (list n 'macro b) env))) (when env (setq *macrolet-env* (list nil (append (cadr *macrolet-env*) (nreverse env)) nil))) (mapc 't1expr (cdr args))) (defun t1defmacro (args &aux (w args)(n (pop args)) (macp (when (listp n) (eq 'macro (car n))))(n (if macp (cdr n) n))) (t1expr `(defun ,n ,@(if macp args (cdr (si::defmacro-lambda n (pop args) args))))) (setf (car (last (car *top-level-forms*))) t) (maybe-eval (not (macro-function n)) (cons 'defmacro w));FIXME? ; (push `(mflag ,n) *top-level-forms*) ) (defun t3mflag (n) (declare (ignore n)) nil) ;; (defun t3mflag (n) ;; (add-init `(c-set-symbol-mflag ',n 1))) ;; (define-compiler-macro fset (&whole form &rest args) ;; (let* ((info (make-info)) ;; (nargs (with-restore-vars (c1args args info))) ;; (ff (cadr nargs))) ;; (if (and (car (atomic-tp (info-type (cadar nargs)))) (eq (car ff) 'function) (fun-p (caaddr ff)));FIXME ;; (let* ((fun (caaddr ff)) ;; (cl (fun-call fun))) ;; (when *sig-discovery* (apply 'si::add-hash (cmp-eval (car args)) (export-call cl))) ;; (list* 'fset1 info (car args) (cdr nargs))) form))) ;; (defun c1fset1 (args) (cons 'fset1 args)) ;; (defun c2fset1 (sym ff) ;; (let* ((fl (caddr ff)) ;; (fun (car fl)) ;; (cl (fun-call fun)) ;; (at (caar cl)) ;; (rt (cadar cl))) ;; (c2expr ff) ;; (add-init `(si::init-function ;; ,sym ;; ,(add-address (c-function-name "&LC" (fun-cfun fun) (fun-name fun))) ;; nil nil -1 ,(new-proclaimed-argd at rt) ;; ,(argsizes at rt (xa (cadr fl))))) ;; (push `(si::add-hash ,sym ,@(mapcar (lambda (x) `',x) (export-call cl))) *add-hash-calls*))) ;; (setf (get 'fset1 'c1) 'c1fset1) ;; (setf (get 'fset1 'c2) 'c2fset1) ;; (defun c1fset (args) ;; (let* ((info (make-info)) ;; (nargs (c1args (cdr args) info))) ;; (list* 'fset info (car args) nargs))) ;; (defun c2fset (sym f &aux (ff (if (eq 'function (car f)) (caddr f) f))) ;; (let* ((fun (car ff)) ;; (lam (cadr ff)) ;; (cl (fun-call fun)) ;; (at (caar cl)) ;; (rt (cadar cl))) ;; (c2expr f) ;; (add-init `(si::init-function ;; ,sym ;; ,(add-address (c-function-name "&LC" (fun-cfun fun) (fun-name fun))) ;; nil nil -1 ,(new-proclaimed-argd at rt) ;; ,(argsizes at rt (xa lam)))))) (defvar *compiling-ordinary* nil) (defun compile-ordinary-p (form) (when (consp form) (or (eq (car form) 'fset) (compile-ordinary-p (car form)) (compile-ordinary-p (cdr form))))) (defun compile-ordinaryp (form) (compile-ordinary-p (pd 'cmp-anon nil (list form)))) (defun t1ordinary (form) (cond ((unless *compiling-ordinary* (or *compile-ordinaries* (compile-ordinaryp form))) (maybe-eval nil form) ;; (let ((*compiling-ordinary* t)) ;; (t1expr `(funcall (lambda nil ,form nil)))) (let ((gen (gensym "progncompile"))(*compiling-ordinary* t)) (t1expr `(progn (defun ,gen nil ,form nil) (,gen)))) ) (t (maybe-eval nil form) (let (*vars* *funs* *blocks* *tags*) (push (list 'ordinary form) *top-level-forms*) nil)))) (defun t3ordinary (form) (cond ((atom form)) ((constantp form)) ((add-init form)))) (defun t2declare (vv) (declare (ignore 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 'si::define-structure 't1) 't1define-structure) (defun t1define-structure (args) (maybe-eval t `(si::define-structure ,@(copy-tree args) ,(not (maybe-eval nil nil))));FIXME (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-operator-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-operator-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(" (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 (length y) 0) "," "") x)) args :initial-value "")) (decl (concatenate 'string (string-downcase rt) " " m "(" decl ");")) (decl (if st "" decl)) (syms (mapcar (lambda (x) (declare (ignore x)) (pop tsyms)) args))) `(defun ,n ,syms (declare (optimize (safety 2))) ,@(mapcar (lambda (x y) `(check-type ,x ,(get y 'lisp-type))) syms tps) (lit ,(if (eq rt :void) :object rt) "({" ,decl ,@(when (eq rt :void) `("(")) ,m "(" ,@(mapcon (lambda (x y z) `((,(car z) ,(car y)) ,(if (cdr x) (if (consp (car x)) "+" ",") ""))) args syms tps) ")" ,@(when (eq rt :void) `(",Cnil)")) ";})")))) ;; (defmacro defentry (n args c &optional (lt t)) ;; (let* ((cp (consp c)) ;; (c (if (and cp (eq (car c) 'static)) (cdr c) c)) ;; (m (if cp (cadr c) c)) ;; (m (if (symbolp m) (string-downcase m) m)) ;; (rt (intern (symbol-name (if cp (car c) lt)) 'keyword)) ;; (tps (mapcar (lambda (x) (intern (string (if (consp x) (car x) x)) 'keyword)) args)) ;; (decl (reduce (lambda (y x) (strcat y (if (> (length y) 0) "," "") x)) args :initial-value "")) ;; (decl (concatenate 'string (string-downcase rt) " " m "(" decl ");")) ;; (syms (mapcar (lambda (x) (declare (ignore x)) (tmpsym)) args))) ;; `(defun ,n ,syms ;; (declare (optimize (safety 2))) ;; ,@(mapcar (lambda (x y) `(check-type ,x ,(get y 'lisp-type))) syms tps) ;; (lit ,rt ;; (cstr "({") (cstr ,decl) ;; ,@(when (eq rt :void) `((cstr "("))) ;; (cstr ,m) (cstr "(") ;; ,@(mapcon (lambda (x y z) `((unbox ,(car z) ,(car y)) ;; (cstr ,(if (cdr x) (if (consp (car x)) "+" ",") "")))) args syms tps) ;; (cstr ")") ;; ,@(when (eq rt :void) `((cstr ",Cnil)"))) ;; (cstr ";})"))))) ;; (defmacro defentry1 (n args c &optional (lt t)) ;; (let* ((cp (consp c)) ;; (c (if (and cp (eq (car c) 'static)) (cdr c) c)) ;; (m (if cp (cadr c) c)) ;; (rt (if cp (intern (symbol-name (car c)) 'keyword) :t)) ;; (syms (mapcar (lambda (x) (declare (ignore x)) (tmpsym)) args))) ;; `(progn ;; (defdlfun2 (,rt ,m) ,@(mapcar (lambda (x) (intern (symbol-name x) 'keyword)) args)) ;; (defun ,n ,syms (,(mdlsym m "") ,@syms))))) ;; (defun t1defentry (args &aux type cname (cfun (next-cfun)) cfspec static) ;; (when (or (endp args) (endp (cdr args)) (endp (cddr args))) ;; (too-few-args 'defentry 3 (length args))) ;; (cmpck (not (symbolp (car args))) ;; "The function name ~s is not a symbol." (car args)) ;; (dolist (x (cadr args)) ;; (cmpck (not (member x '(object char int fixnum float double string))) ;; "The C-type ~s is illegal." x)) ;; (setq cfspec (caddr args)) ;; (cond ((symbolp cfspec) ;; (setq type 'object) ;; (setq cname (string-downcase (symbol-name cfspec)))) ;; ((stringp cfspec) ;; (setq type 'object) ;; (setq cname cfspec)) ;; ((and (consp cfspec) (eq (car cfspec) 'static) ;; (setq static t cfspec (cdr cfspec)) nil)) ;; ((and (consp cfspec) ;; (member (car cfspec) '(void object char int fixnum float double string)) ;; (consp (cdr cfspec)) ;; (or (symbolp (cadr cfspec)) (stringp (cadr cfspec))) ;; (endp (cddr cfspec))) ;; (setq cname (if (symbolp (cadr cfspec)) ;; (string-downcase (symbol-name (cadr cfspec))) ;; (cadr cfspec))) ;; (setq type (car cfspec))) ;; (t (cmperr "The C function specification ~s is illegal." cfspec))) ;; (push (list 'defentry (car args) cfun (cadr args) (if static (list 'static type) type) cname) ;; *top-level-forms*) ;; (push (cons (car args) cfun) *global-funs*)) ;; (defun t2defentry (fname cfun arg-types type cname) ;; (declare (ignore arg-types type cname)) ;; (wt-h "static void " (c-function-name "L" cfun fname) "();") ;; (add-init `(si::mf ',fname ,(add-address (c-function-name "L" cfun fname))))) ;; (defun t3defentry (fname cfun arg-types type cname) ;; (wt-h ;; (if (and (consp type) (eq (car type) 'static) (setq type (cadr type))) "static " "") ;; (if (eq type 'string) "char *" (string-downcase (symbol-name type))) ;; " " cname "(" ;; (with-output-to-string ;; (s) ;; (do ((l arg-types (cdr l))) ((not l) (princ ");"s )) ;; (princ (if (eq (car l) 'string) "char *" (string-downcase (symbol-name (car l)))) s) ;; (when (cdr l) (princ "," s))))) ;; (wt-comment "function definition for " fname) ;; (wt-nl1 "static void " (c-function-name "L" cfun fname) "()") ;; (wt-nl1 "{ object *old_base=vs_base;") ;; (case type ;; (void) ;; (string (wt-nl "char *x;")) ;; (t (wt-nl (string-downcase (symbol-name type)) " x;"))) ;; (when *safe-compile* (wt-nl "check_arg(" (length arg-types) ");")) ;; (unless (eq type 'void) (wt-nl "x=")) ;; (wt-nl cname "(") ;; (unless (endp arg-types) ;; (do ((types arg-types (cdr types)) ;; (i 0 (1+ i))) ;; (nil) ;; (declare (fixnum i)) ;; (case (car types) ;; (object (wt-nl "vs_base[" i "]")) ;; (otherwise ;; (wt-nl "object_to_" ;; (string-downcase (symbol-name (car types))) ;; "(vs_base[" i "])"))) ;; (when (endp (cdr types)) (return)) ;; (wt ","))) ;; (wt ");") ;; (wt-nl "vs_top=(vs_base=old_base)+1;") ;; (wt-nl "vs_base[0]=") ;; (case type ;; (void (wt "Cnil")) ;; (object (wt "x")) ;; (char (wt "code_char(x)")) ;; ((fixnum int) (when (zerop *space*) (wt "CMP")) (wt "make_fixnum(x)")) ;; (string (wt "make_simple_string(x)")) ;; (float (wt "make_shortfloat(x)")) ;; (double (wt "make_longfloat(x)")) ;; ) ;; (wt ";") ;; (wt-nl1 "}")) (defun t1defla (args) (declare (ignore args))) (defun parse-cvspecs (x &aux (cvspecs nil)) (dolist (cvs x (nreverse cvspecs)) (cond ((symbolp cvs) (push (list 'object (string-downcase (symbol-name cvs))) cvspecs)) ((stringp cvs) (push (list 'object cvs) cvspecs)) ((and (consp cvs) (member (car cvs) '(object char int float double))) (dolist (name (cdr cvs)) (push (list (car cvs) (cond ((symbolp name) (string-downcase (symbol-name name))) ((stringp name) name) (t (cmperr "The C variable name ~s is illegal." name)))) cvspecs))) (t (cmperr "The C variable specification ~s is illegal." cvs)))) ) ;; Add optional argument initial-ccb-vs here defaulting to ccb-vs. ;; Local functions will set this to the value of *initial-ccb-vs* ;; prevalent at the time of the local function creation. Closures ;; will let it default to ccb-vs, which will be the value of *ccb-vs* ;; prevalent at the time the environment stack was pushed and the ;; closure was created. CM 20031130 (defvar *reg-clv*) (defun t3local-fun (closure-p clink ccb-vs fun lambda-expr &optional (initial-ccb-vs ccb-vs) &aux (requireds (caaddr lambda-expr)) nargs specials *reg-clv* h at rt (level (if closure-p (if clink 0 -1) (fun-level fun))) (*volatile* (volatile (cadr lambda-expr)))) (declare (fixnum level)) (setq h (fun-call fun) at (caar h) rt (cadar h) at (mapcar 'global-type-bump at) rt (global-type-bump rt));FIXME (dolist (vl requireds) (cond ((eq (var-kind vl) 'special) (push (cons vl (var-loc vl)) specials)) ((var-cb vl) (push (list (eq 'clb (var-loc vl)) vl) *reg-clv*)) ; ((var-cb vl) (push vl *reg-clv*)) ((setf (var-kind vl) (or (car (member (promoted-c-type (var-type vl)) +c-local-arg-types+)) 'object)))) (setf (var-loc vl) (cs-push (var-type vl) t))) (wt-comment "local function " (if (fun-name fun) (fun-name fun) nil)) (wt-h "static " (declaration-type (rep-type rt)) (c-function-name (if closure-p "LC" "L") (fun-cfun fun) (fun-name fun)) "(") (wt-nl1 "static " (declaration-type (rep-type rt)) (c-function-name (if closure-p "LC" "L") (fun-cfun fun) (fun-name fun)) "(") (unless (single-type-p rt) (let ((ns (abs (vald rt)))) (unless (= ns (- multiple-values-limit 2)) (setq *max-vs* (max *max-vs* ns))))) (when (is-narg-le lambda-expr) (setq nargs (car (last requireds))) (setf (var-register nargs) 0)) (let (first) (unless closure-p (flet ((wt2 (x) (wt x) (let ((*compiler-output1* *compiler-output2*)) (wt x)))) (dotimes (i (1+ level)) (when first (wt2 ",")) (setq first t) (wt2 "object *") (wt2 *volatile*) (wt2 "base") (wt2 i)))) (wt-requireds requireds at first nargs)) (wt-h ";") (analyze-regs (cadr lambda-expr) 2) (let-pass3 ((*clink* clink) (*ccb-vs* ccb-vs) ;; Use new optional parameter to initialize ;; *initial-ccb-vs* for correct use in ;; wt-ccb-vs. CM 20031130 (*level* (1+ level)) (*initial-ccb-vs* initial-ccb-vs) (*exit* (or (cdr (assoc (promoted-c-type rt) +return-alist+)) 'return-object)) (*compiler-check-args* *compiler-check-args*) (*safe-compile* *safe-compile*) (*compiler-push-events* *compiler-push-events*) (*compiler-new-safety* *compiler-new-safety*) (*notinline* *notinline*) (*space* *space*) (*debug* *debug*)) (when (eq (car (caddr (cddr lambda-expr))) 'decl-body) (local-compile-decls (caddr (caddr (cddr lambda-expr))))) (wt-nl1 "{ ") (let* ((cm *reservation-cmacro*)) ;; (tri (tail-recursion-info (fun-name fun) nil lambda-expr)) ;; (*unwind-exit* (if tri (cons 'tail-recursion-mark *unwind-exit*) *unwind-exit*))) (wt-nl "VMB" cm " VMS" cm " VMV" cm) (when nargs (wt-nl "va_list ap;")(wt-nl "va_start(ap,V" (var-loc nargs) ");")) (if *safe-compile* (wt-nl "vs_reserve(VM" cm ");") (wt-nl "vs_check;")) (when *compiler-push-events* (wt-nl "ihs_check;")) ; (when clv (wt-nl "#define base0 fcall.fun->fun.fun_env")) ; (dolist (v clv) (setf (var-ref v) (list 'cvar (var-loc v))) (c2bind v)) (dolist (v specials) (setq *bds-used* t) (wt-nl "bds_bind(" (vv-str (cdr v)) "," `(gen-loc :object (cvar ,(var-loc (car v)))) ");") (push 'bds-bind *unwind-exit*) (setf (var-kind (car v)) 'SPECIAL) (setf (var-loc (car v)) (cdr v))) (let ((*mv-var* (mv-var lambda-expr))) (c2expr (caddr (cddr lambda-expr))) (wt-V*-macros cm rt))) (wt-nl "#undef base0") (when nargs (wt-nl "va_end(ap);")) (wt-nl1 "}"))) (defun wt-cvars(&aux type ) (let (vars) (dolist (v *c-vars*) (when (integerp (cdr v)) (setq vars t) (let* ((t1 (car v)) (v (cdr v))) (cond ((eq type t1)(format *compiler-output2* " ,V~a" v)) (t (or (null type) (format *compiler-output2* ";")) (setq type t1) (if (eq (promoted-c-type type) 'integer) (format *compiler-output2* "IDECL1(V~a,V~abody,V~aalloc)" v v v) (format *compiler-output2* " ~a ~a V~a" *volatile* (rep-type type) v))))))) (when vars (format *compiler-output2* ";"))) (unless (or (not *vcs-used*) (= *cs* 0)) ; (format *compiler-output2* " object Vcs[~a]={Cnil" *cs*) ; (dotimes (temp (- *cs* 1) t) (format *compiler-output2* ",Cnil")) ; (format *compiler-output2* "};")) (format *compiler-output2* " ~a object Vcs[~a];" *volatile* *cs*))) gcl27-2.7.0/cmpnew/gcl_cmptype.lsp000077500000000000000000001126671454061450500170010ustar00rootroot00000000000000;;; CMPTYPE Type information. ;;; ;; 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 get-sym (args) (intern (apply 'concatenate 'string (mapcar 'string args)))) (defvar *c-types* (mapcar (lambda (x &aux (y (pop x))) (list* y (cmp-norm-tp y) x)) `((nil nil nil nil "" "" "object ") (null nil nil inline-cond "" "" "object ") (true nil nil inline-cond "" "" "object ") (boolean nil nil inline-cond "" "" "object ") (character wt-character-loc nil inline-character "char_code" "code_char" "int8_t ") (bit wt-char-loc return-char inline-char "fix" "make_fixnum" "int8_t ") (non-negative-char wt-char-loc return-char inline-char "fix" "make_fixnum" "int8_t ") (unsigned-char wt-char-loc return-char inline-char "fix" "make_fixnum" "uint8_t ") (signed-char wt-char-loc return-char inline-char "fix" "make_fixnum" "int8_t ") (char wt-char-loc return-char inline-char "fix" "make_fixnum" "int8_t ") (non-negative-short wt-fixnum-loc return-fixnum inline-fixnum "fix" "make_fixnum" "int16_t ") (unsigned-short wt-fixnum-loc return-fixnum inline-fixnum "fix" "make_fixnum" "int16_t ") (signed-short wt-fixnum-loc return-fixnum inline-fixnum "fix" "make_fixnum" "uint16_t ") (non-negative-int wt-fixnum-loc return-fixnum inline-fixnum "fix" "make_fixnum" "int32_t ") (unsigned-int wt-fixnum-loc return-fixnum inline-fixnum "fix" "make_fixnum" "int32_t ") (signed-int wt-fixnum-loc return-fixnum inline-fixnum "fix" "make_fixnum" "uint32_t ") (non-negative-fixnum wt-fixnum-loc return-fixnum inline-fixnum "fix" "make_fixnum" "fixnum ") (fixnum wt-fixnum-loc return-fixnum inline-fixnum "fix" "make_fixnum" "fixnum ") (short-float wt-short-float-loc return-short-float inline-short-float "sf" "make_shortfloat" "float ") (long-float wt-long-float-loc return-long-float inline-long-float "lf" "make_longfloat" "double ") (creal nil nil nil "" "" "") (fcomplex wt-fcomplex-loc return-fcomplex inline-fcomplex "sfc" "make_fcomplex" "fcomplex ") (dcomplex wt-dcomplex-loc return-dcomplex inline-dcomplex "lfc" "make_dcomplex" "dcomplex ") (cnum nil nil nil "" "" "") (t wt-loc return-object inline "" "" "object ")))) (defconstant +c-global-arg-types-syms+ `(fixnum)) ;FIXME (long-float short-float) later (defconstant +c-local-arg-types-syms+ (union +c-global-arg-types-syms+ '(char fixnum long-float short-float fcomplex dcomplex))) (defconstant +c-local-var-types-syms+ (union +c-local-arg-types-syms+ '(char fixnum long-float short-float fcomplex dcomplex))) (defvar +value-types+ (mapcar (lambda (x) (cons (cadr (assoc x *c-types*)) (get-sym `(,x "-VALUE")))) (cons 'character +c-local-var-types-syms+))) (defconstant +return-alist+ (mapcar (lambda (x) (cons (if (eq x 'object) x (cadr (assoc x *c-types*))) (get-sym `("RETURN-" ,x)))) (cons 'object +c-local-arg-types-syms+))) (defconstant +wt-loc-alist+ `((object . wt-loc) ,@(mapcar (lambda (x) (cons (cadr (assoc x *c-types*)) (get-sym `("WT-" ,x "-LOC")))) +c-local-var-types-syms+))) (defconstant +inline-types-alist+ `(,@(mapcar (lambda (x) (cons (cadr (assoc x *c-types*)) (case x ((t) 'inline) (boolean 'inline-cond) (otherwise (get-sym `("INLINE-" ,x)))))) (list* 'boolean t +c-local-var-types-syms+)))) (defconstant +c-global-arg-types+ (mapcar (lambda (x) (cadr (assoc x *c-types*))) +c-global-arg-types-syms+)) (defconstant +c-local-arg-types+ (mapcar (lambda (x) (cadr (assoc x *c-types*))) +c-local-arg-types-syms+)) (defconstant +c-local-var-types+ (mapcar (lambda (x) (cadr (assoc x *c-types*))) +c-local-var-types-syms+)) (defconstant +wt-c-var-alist+ (nconc (mapcar (lambda (x &aux (z (assoc x *c-types*))) (cons (cadr z) (seventh z))) '(char fixnum character short-float long-float fcomplex dcomplex)) `((object . "")))) (defconstant +to-c-var-alist+ (nconc (mapcar (lambda (x &aux (z (assoc x *c-types*))) (cons (cadr z) (sixth z))) '(char fixnum character short-float long-float fcomplex dcomplex)) `((object . "")))) (defconstant +c-type-string-alist+ (mapcar (lambda (x &aux (z (assoc x *c-types*))) (cons (cadr z) (eighth z))) `(t bit character signed-char non-negative-char unsigned-char signed-short non-negative-short unsigned-short fixnum non-negative-fixnum signed-int non-negative-int unsigned-int long-float short-float fcomplex dcomplex))) (defconstant +cmp-array-types+ (mapcar (lambda (x) (cadr (assoc x *c-types*))) +array-types+)) (defconstant +wt-c-rep-alist+ (nconc (mapcar (lambda (x &aux (z (assoc x *c-types*))) (cons (cadr z) (eighth z))) `(nil char fixnum long-float short-float fcomplex dcomplex)) `((object . "object ")))) (defconstant +cmp-type-alist+ (mapcar (lambda (x) (cons (cmp-norm-tp (car x)) (cdr x))) +type-alist+)) ;FIXME? (defconstant +promoted-c-types+ (nconc (mapcar (lambda (x) (cadr (assoc x *c-types*))) '(nil null boolean)) +c-local-var-types+)) (defconstant +clzl0+ (let ((x (1- fixnum-length))) (cmp-norm-tp `(integer ,x ,x)))) (defconstant +coersion-alist+ (mapcar (lambda (x) (cons (cadr (assoc x *c-types*)) (get-sym `(,x "-LOC")))) +c-local-var-types-syms+)) (defconstant +number-inlines+ (mapcar 'cdr (remove-if-not (lambda (x) (type>= #tnumber (car x))) +inline-types-alist+))) (defstruct opaque) (defmacro nil-to-t (x) `(or ,x t)) (defun name-to-sd (x &aux (sd (when (symbolp x) (get x 's-data)))) (unless sd (error "The structure ~a is undefined." x)) sd) (defvar *tmpsyms* nil) (defun tmpsym nil (let ((x (or (pop *tmpsyms*) (gensym)))) (setf (symbol-plist x) '(tmp t)) x)) (defconstant +tmpsyms+ (let ((*gensym-counter* 0)) (mapl (lambda (x) (rplaca x (tmpsym))) (make-list 1000)))) (defconstant +opaque+ (gensym)) (defvar *car-limit* -1);1) (defvar *cdr-limit* -1);5) (defun cons-tp-limit (x i j) (declare (seqind i j)) (cond ((> i *car-limit*) nil) ((> j *cdr-limit*) nil) ((atom x) t) ((and (cons-tp-limit (car x) (1+ i) 0) (cons-tp-limit (cdr x) i (1+ j)))))) (defun cons-tp-limit-tp (x i j) (declare (seqind i j)) (cond ((> i *car-limit*) nil) ((> j *cdr-limit*) nil) ((atom x)) ((not (eq (car x) 'cons))) ((and (cons-tp-limit-tp (cadr x) (1+ i) 0) (cons-tp-limit-tp (caddr x) i (1+ j)))))) (defun object-type (thing) (object-tp thing)) (defconstant +real-contagion-list+ si::+range-types+) (defun get-inf (x) (etypecase x (rational (if (plusp x) '+rinf (if (minusp x) '-rinf 'rnan))) (float (float (if (plusp x) +inf (if (minusp x) -inf nan)) x)))) (defun pole-type (y) (etypecase y (integer 'integer) (short-float 'short-float) (long-float 'long-float))) (defun tp-to-inf (tp x) (ecase tp ((integer ratio) (if x '-rinf '+rinf)) (short-float (if x -sinf +sinf)) (long-float (if x -inf +inf)))) (defun bnds-to-bounds (tp x) (when x (let ((y (pop x))) (cons (cond ((eq y '*) (tp-to-inf tp x)) ((consp y) (cons (if x 1 -1) y)) (y)) (bnds-to-bounds tp x))))) (defun bound-num (x) (cond ((eq x '+rinf) +sinf) ((eq x '-rinf) -sinf) ((eq x '+rnan) snan) ((consp x) (cadr x)) (x))) (defun rat-bound-p (x) (or (member x '(+rinf -rinf rnan)) (rationalp (if (consp x) (cadr x) x)))) ;; (& ^ \| ~) ;; (logand logior logxor logeqv logandc1 logandc2 logorc1 logorc2 lognand lognor lognot) ;; (+ - * max min si::number-plus si::number-times si::number-minus pexpt /-pole) ;; (gcd lcm) ;; (mod rem) ;; (floor ceiling truncate round ffloor fceiling ftruncate fround) ;; (ash >> << integer-length clzl ctzl abs ) (defun ?rationalize (x f r) (cond ((not (member f '(+ - * max min si::number-plus si::number-times si::number-minus pexpt /-pole))) x);closed functions over rationals ((member-if-not 'rat-bound-p r) x) ((isinf x) (if (> x 0) '+rinf '-rinf)) ((isnan x) 'rnan) ((numberp x) (rational x)) (x))) (defun ?list-bound (x r) (if (unless (isinf x) (unless (isnan x) (when (numberp x) (member-if 'consp r)))) (list x) x)) (defun pole-d (x) (if (consp x) (car x) 0)) (defun pole-check (f r) (apply f (if (when (symbolp f) (get f 'pole)) r (mapcar 'bound-num r)))) (defun mfc1 (f &rest r) (?list-bound (?rationalize (pole-check f r) f r) r)) (defun infp (x m) (or (eq x (if m '-rinf '+rinf)) (eql x (if m -inf +inf)) (eql x (if m -sinf +sinf)))) (defun nanp (x) (or (eq x 'rnan) (isnan x))) (defun minmax1 (tp m) (reduce (lambda (y x &aux (x (if (when (consp x) (eq (cdr x) 'incl)) (car x) x))) (cond ((eq y '*) y) ((infp x m) '*) ((infp x (not m)) y) ((nanp x) '*) ((not y) x) ((funcall (if m '< '>) (if (consp x) (car x) x) (if (consp y) (car y) y)) x) ((when (atom x) (when (consp y) (eql x (car y)))) x) (y))) tp :initial-value nil)) (defun mk-tp1 (e tp) (cmp-norm-tp `(,(let* ((x (car (member e si::+range-types+ :test 'typep)))) (case x (ratio 'rational)(otherwise x))) ,(minmax1 tp t) ,(minmax1 tp nil)))) (defun outer-merge (&rest r &aux (z (pop r))) (mapcan (lambda (z) (mapcar (lambda (x) (cons z x)) (if r (apply 'outer-merge r) (list nil)))) z)) (defun ar-merge (&rest r) (mapcar (lambda (x &aux (p1 (pop x))(b1 (real-bnds x))) (unless (car b1) (return-from ar-merge nil)) (bnds-to-bounds p1 b1)) r)) (defun mk-contagion-rep (f ?complex r &aux (i 1)) (apply f (mapcar (lambda (x &aux (p (pop x)) (y (contagion-irep (incf i) p))) (if ?complex (complex y (contagion-irep (incf i) p)) y)) r))) (defun dsrg (f &rest r &aux (z (apply 'ar-merge r))) (if z (let* ((v (mapcar (lambda (x) (apply 'mfc1 f x)) (apply 'outer-merge z))) (vc (remove-if-not 'mfc-complexp v)) (vr (set-difference v vc))) (reduce 'type-or1 (mapcar 'complex-contagion vc) :initial-value (when vr (mk-tp1 (mk-contagion-rep f nil r) vr)))) (complex-contagion (mk-contagion-rep f t r)))) (defun super-range (f &rest r) (reduce 'type-or1 (mapcar (lambda (x) (apply 'dsrg f x)) (apply 'outer-merge (mapcar 'range-decomp r))) :initial-value nil)) ; libm standard poles ; / mod rem truncate etc. 0 two-sided ; atanh +-1 branch-cut ; log 0 branch-cut ; expt/pow 0 neg same as / ; lgamma/tgamma neg int (defconstant +small-rat+ (rational least-positive-long-float)) (defun contagion-irep (x tp) (case tp (ratio (if (or (= 0 x) (= 1 x)) x (+ x (/ 1 x)))) (integer x) (otherwise (coerce x tp)))) (defconstant +cmp-range-types+ (let ((z '(integer ratio short-float long-float))) (nconc (mapcar (lambda (x) (cons x (cmp-norm-tp x))) z) (mapcar (lambda (x) (cons x (case x (integer #t(complex rational)) (ratio #t(and (complex rational) (not (complex integer)))) (otherwise (cmp-norm-tp `(complex ,x)))))) z)))) (defun complex-contagion (z) (car (member (object-tp z) '(#t(complex integer) #t(complex rational) #t(complex short-float) #t(complex long-float) #tcomplex) :test 'type<=))) (defun mfc-complexp (x &aux (x (if (listp x) (car x) x))) (complexp x)) (defun range-decomp (tp) (mapcan (lambda (x &aux (f (pop x))(z (type-and tp x))) (when z (list (cons f z)))) +cmp-range-types+)) (dolist (l '(si::number-plus si::number-minus si::number-times + - * exp tanh sinh asinh)) (si::putprop l 'super-range 'type-propagator)) (defun atan-propagator (f t1 &optional (t2 nil t2p)) (if t2p (type-or1 (super-range f (type-and #tnon-negative-real t1) (type-and #tnon-negative-real t2)) (type-or1 (super-range f (type-and #tnon-negative-real t1) (type-and #tnegative-real t2)) (type-or1 (super-range f (type-and #tnegative-real t1) (type-and #tnon-negative-real t2)) (super-range f (type-and #tnegative-real t1) (type-and #tnegative-real t2))))) (super-range f t1))) (si::putprop 'atan 'atan-propagator 'type-propagator) (defun float-propagator (f t1 &optional (t2 #tnull)) (if (equal t2 #tnull) (super-range f (type-and #treal t1)) (super-range f (type-and #treal t1) (type-and #tfloat t2)))) (setf (get 'float 'type-propagator) 'float-propagator) (defun bit-type (tp) (cond ((not tp) tp) ((atomic-tp tp) tp) ((type>= #tinteger tp) (let* ((tp (list* 'integer (real-bnds tp))) (l (cadr tp)) (l (if (consp l) (car l) l)) (h (caddr tp)) (h (if (consp h) (car h) h)) (h (if (eq h '*) h (if (>= h 0) (1- (ash 1 (integer-length h))) -1))) (l (if (eq l '*) l (if (< l 0) (- (ash 1 (integer-length l))) 0)))) (cmp-norm-tp `(integer ,l ,h)))))) (defun logand2-propagator (f t1 t2) (when (and (type>= #tfixnum t2) (type>= #tfixnum t1));FIXME (let ((t1 (bit-type t1))(t2 (bit-type t2))) (super-range '* (if (and (atomic-tp t1) (atomic-tp t2)) #t(integer 1 1) #t(integer 0 1)) (type-or1 (super-range f (type-and #tnon-negative-integer t1) (type-and #tnon-negative-integer t2)) (type-or1 (super-range f (type-and #tnegative-integer t1) (type-and #tnon-negative-integer t2)) (type-or1 (super-range f (type-and #tnon-negative-integer t1) (type-and #tnegative-integer t2)) (super-range f (type-and #tnegative-integer t1) (type-and #tnegative-integer t2))))))))) (dolist (l '(& ^ \|)) (si::putprop l 'logand2-propagator 'type-propagator)) (defun logand1-propagator (f t1) (when (type>= #tfixnum t1);FIXME (super-range '* #t(integer 0 1) (super-range f t1)))) (si::putprop '~ 'logand1-propagator 'type-propagator) (defun logand-propagator (f &optional (t1 nil t1p) (t2 nil t2p) &rest r) (cond (r (apply 'logand-propagator f (logand-propagator f t1 t2) (car r) (cdr r))) (t2p (logand2-propagator f t1 t2)) (t1p (logand1-propagator f t1)) ((not t1p) (super-range f)))) (dolist (l '(logand logior logxor logeqv logandc1 logandc2 logorc1 logorc2 lognand lognor lognot)) (si::putprop l 'logand-propagator 'type-propagator)) (defun min-max-propagator (f &optional (t1 nil t1p) (t2 nil t2p)) (cond (t2p (super-range f (type-and #treal t1) (type-and #treal t2))) (t1p (super-range f (type-and #treal t1))))) (si::putprop 'max 'min-max-propagator 'type-propagator) (si::putprop 'min 'min-max-propagator 'type-propagator) (defun /-pole (x y &aux (d (pole-d y))(x (bound-num x))(y (bound-num y))) (if (zerop y) (get-inf (* x (if (floatp y) (float d y) d))) (let ((x (/ x y))) (if (integerp x) (cons x 'incl) x)))) (setf (get '/-pole 'pole) t) (defun /-propagator (f t1 &optional t2) (cond (t2 (reduce 'type-or1 (mapcar (lambda (x) (super-range '/-pole t1 (type-and t2 x))) '(#tcomplex #tpositive-real #tnegative-real)) :initial-value nil)) (t1 (/-propagator f (object-tp 1) t1)))) (si::putprop '/ '/-propagator 'type-propagator) (si::putprop 'si::number-divide '/-propagator 'type-propagator) (defun real-imag-tp (x rp) (when (consp x) (case (car x) (member (reduce (lambda (y x) (type-or1 y (object-tp (if rp (realpart x) (imagpart x))))) (cdr x) :initial-value nil)) (or (reduce (lambda (y x) (type-or1 y (real-imag-tp x rp))) (cdr x) :initial-value nil)) (complex (cmp-norm-tp (cadr x))) (si::complex* (cmp-norm-tp (if rp (cadr x) (caddr x))))))) (defun complex-real-imag-type-propagator (f t1 rp) (declare (ignore f)) (when (type>= #tcomplex t1) (reduce (lambda (&rest r) (when r (apply 'type-or1 r))) (mapcar (lambda (x) (real-imag-tp (si::tp-type (cdr x)) rp)) (range-decomp t1))))) (defun complex-real-type-propagator (f t1) (declare (ignore f)) (complex-real-imag-type-propagator f t1 t)) (defun complex-imag-type-propagator (f t1) (declare (ignore f)) (complex-real-imag-type-propagator f t1 nil)) (si::putprop 'si::complex-real 'complex-real-type-propagator 'type-propagator) (si::putprop 'si::complex-imag 'complex-imag-type-propagator 'type-propagator) (si::putprop 'c-ocomplex-real 'complex-real-type-propagator 'type-propagator) (si::putprop 'c-ocomplex-imag 'complex-imag-type-propagator 'type-propagator) (defun tp-contagion (tp c &aux (s #tshort-float)(l #tlong-float)) (cond ((type>= c s) (if (type>= s tp) tp (cmp-norm-tp `(short-float ,@(real-bnds tp))))) ((type>= c l) (if (type>= l tp) tp (cmp-norm-tp `(long-float ,@(real-bnds tp))))) (tp))) (defun c-type-propagator (f t1) (declare (ignore f)) (cmp-norm-tp (cons 'member (reduce (lambda (y x) (when (type-and t1 (car x)) (pushnew (c-type (eval (cdr x))) y)) y) si::+rn+ :initial-value nil)))) (si::putprop 'c-type 'c-type-propagator 'type-propagator) (defconstant +e+ 2.7182818284590451) (defun log-pole (&rest r &aux (x (pop r))(d (pole-d x))(x (bound-num x))(x (if (integerp x) (float x) x))) (if (zerop x) (let ((x (coerce -inf (pole-type x)))) (if (plusp d) x (complex (realpart x) (float +pi+ (realpart x))))) (apply 'log x (mapcar 'bound-num r)))) (setf (get 'log-pole 'pole) t) (defun log-propagator (f t1 &rest r) (declare (ignore f)) (reduce 'type-or1 (mapcar (lambda (x) (apply 'super-range 'log-pole (type-and t1 x) r)) '(#tcomplex #tpositive-real #tnegative-real)) :initial-value nil)) (si::putprop 'log 'log-propagator 'type-propagator) (defun last-cons-type (tp &optional l) (cond ((and l (atom tp)) tp) ((and (consp tp) (eq (car tp) 'cons) (cddr tp) (not (cdddr tp))) (last-cons-type (caddr tp) t)))) (defun cdr-propagator (f t1 &aux (t1 (type-and #tlist t1))) (declare (ignore f)) (cond ((type>= #tnull t1) t1) ;FIXME clb ccb do-setq-tp ((let ((a1 (atomic-tp t1))) (when a1 (let ((tp (cdar a1))) (unless (binding-p tp) (object-type tp))))));FIXME bind-type? ((and (consp t1) (eq (car t1) 'cons)) (caddr t1)) ((type>= #tproper-list t1) #tproper-list))) (si::putprop 'cdr 'cdr-propagator 'type-propagator) (defun make-list-propagator (f t1 &rest r &aux (a (atomic-tp t1))) (declare (ignore f r)) (cond ((and (type>= #t(integer 0 5) t1) a) ; (object-type (make-list (cadr t1)))) (cmp-norm-tp (reduce (lambda (y x) (declare (ignore x)) `(cons t ,y)) (make-list (car a)) :initial-value 'null))) (#tproper-list))) (si::putprop 'make-list 'make-list-propagator 'type-propagator) (defun nth-cons-tp (n tp) (cond ((= n 0) tp) ((and (consp tp) (eq 'cons (car tp)) (cddr tp) (not (cdddr tp))) (nth-cons-tp (1- n) (caddr tp))))) (defun nthcdr-propagator (f t1 t2) (declare (ignore f)) (let ((t1 (type-and #tinteger t1)) (t2 (type-and #tlist t2))) (cond ((type>= #tnull t2) t2) ;FIXME clb ccb do-setq-tp ((type>= #t(integer 0 0) t1) t2) ((and (consp t2) (eq (car t2) 'cons) (atomic-tp t1) (typep (cadr t1) 'seqind)) (nth-cons-tp (cadr t1) t2)) ((type>= #tproper-list t2) #tproper-list)))) (si::putprop 'nthcdr 'nthcdr-propagator 'type-propagator) (defun bump-pcons (v p) (let ((tp (if p #tproper-cons #tcons))) (unless (type>= (var-type v) tp) (when (type>= #tproper-cons (var-type v)) (do-setq-tp v nil tp) (mapc (lambda (x) (bump-pcons x p)) (var-aliases v)))))) (defun bump-pconsa (v ctp) (let ((tp (cons-propagator 'cons ctp (cdr-propagator 'cdr (var-type v))))) (unless (type>= (var-type v) tp) (do-setq-tp v nil tp) (mapc (lambda (x) (bump-pconsa x ctp)) (var-aliases v))))) (defun c1rplacd (args) (let* ((info (make-info :flags (iflags side-effects))) (nargs (c1args args info)) (p (type>= #tproper-list (info-type (cadadr nargs)))) (atp (car (atomic-tp (info-type (cadar nargs))))) (atp1 (car (atomic-tp (info-type (cadadr nargs)))))) (c1side-effects nil) (when (consp atp) (when (eq atp atp1) (setq atp1 (copy-list atp1))) (setf (cdr atp) (or atp1 (new-bind)))) (when (eq (caar nargs) 'var) (bump-pcons (caaddr (car nargs)) p)) (setf (info-type info) (if p #tproper-cons #tcons)) (list 'call-global info 'rplacd nargs))) (si::putprop 'rplacd 'c1rplacd 'c1) (defun c1rplaca (args) (let* ((info (make-info :flags (iflags side-effects))) (nargs (c1args args info)) (atp (car (atomic-tp (info-type (cadar nargs))))) ; (atp1 (car (atomic-tp (narg-list-type (cdr nargs)))))) (atp1 (car (atomic-tp (info-type (cadadr nargs)))))) (c1side-effects nil) (when (consp atp) (when (eq atp atp1) (setq atp1 (copy-list atp1))) (setf (car atp) (or atp1 (new-bind)))) (when (eq (caar nargs) 'var) (bump-pconsa (caaddr (car nargs)) (info-type (cadadr nargs)))) (setf (info-type info) (cons-propagator 'cons (info-type (cadadr nargs)) (cdr-propagator 'cdr (info-type (cadar nargs))))) (list 'call-global info 'rplaca nargs))) (si::putprop 'rplaca 'c1rplaca 'c1) (defun cons-propagator (f t1 t2 &aux tmp) (declare (ignore f)) (cond ((let ((a1 (atomic-tp t1)) (a2 (atomic-tp t2))) (and a1 a2 (object-type (cons (car a1) (car a2)))))) ((cons-tp-limit (setq tmp `(cons ,t1 ,t2)) 0 0) (cmp-norm-tp tmp)) ((type>= #tproper-list t2) #tproper-cons) (#tcons))) (si::putprop 'cons 'cons-propagator 'type-propagator) (defvar *in-co1carcdr* nil);FIXME (defun co1carcdr (f x) (unless *in-co1carcdr* (let ((*in-co1carcdr* t)) (let* ((tp (car (atomic-tp (info-type (cadr (with-restore-vars (c1arg (car x)))))))) (tp (when (consp tp) (funcall f tp))) (tp (get-var tp))) (when tp (c1var tp)))))) (setf (get 'car 'co1) 'co1carcdr) (setf (get 'cdr 'co1) 'co1carcdr) (defun car-propagator (f t1 &aux (t1 (type-and #tlist t1))) (declare (ignore f)) (cond ((type>= #tnull t1) t1) ;FIXME clb ccb do-setq-tp ((let ((a1 (atomic-tp t1))) (when a1 (let ((tp (caar a1))) (unless (binding-p tp) (object-type tp)))))) ((and (consp t1) (eq (car t1) 'cons)) (cadr t1)))) (si::putprop 'car 'car-propagator 'type-propagator) (defun contagion (t1 t2) (car (member (type-or1 t1 t2) `(,#tlong-float ,#tshort-float #tratio #tinteger) :test 'type-and))) (defun mod-propagator (f t1 t2 &aux (t1 (type-and #treal t1))(t2 (type-and #treal t2)) (r1 (range-decomp t1))(r2 (range-decomp t2))) (declare (ignore f)) (cond ((cdr r1) (reduce 'type-or1 (mapcar (lambda (x) (mod-propagator f (cdr x) t2)) r1) :initial-value nil)) ((cdr r2) (reduce 'type-or1 (mapcar (lambda (x) (mod-propagator f t1 (cdr x))) r2) :initial-value nil)) ((let ((a (atomic-tp t1))(b (atomic-tp t2))) (when (and a b) (unless (zerop (car b)) (object-tp (mod (car a) (car b))))))) ((and (type>= #treal t1) (type>= #treal t2)) (let* ((tp (super-range '* #t(integer 0 1) t2));FIXME this might break for integers in the future (r (real-bnds tp)) (r (labels ((b (x) (if (when (numberp x) (not (zerop x))) (list x) x))) (list (b (car r)) (b (cadr r)))))) (type-and (contagion t1 t2) (cmp-norm-tp (cons 'real r))))))) (si::putprop 'mod 'mod-propagator 'type-propagator) (defun random-propagator (f t1 &optional t2) (declare (ignore t2)) (mod-propagator f (super-range '* #t(integer 0 1) t1) t1)) (si::putprop 'random 'random-propagator 'type-propagator) (defun lgcd2-propagator (f t1 t2 t3 &aux (a1 (car (atomic-tp t1)))(a2 (car (atomic-tp t2))) (a3 (car (atomic-tp t3)))) (cond ((and a1 a2 a3) (object-type (funcall f a1 a2 a3))) ((type-and #t(not (integer 0 0)) (super-range '* #t(integer 0 1) (super-range 'min t1 t2)))))) (si::putprop 'si::lgcd2 'lgcd2-propagator 'type-propagator) (defun rem-propagator (f t1 t2 &aux (ta (abs-propagator 'abs t2))) (let ((tm (mod-propagator f t1 t2))) (when tm (cond ((type>= #tnon-negative-real t1) (type-or1 (type-and #tnon-negative-real tm) (super-range '+ (type-and #tnon-positive-real tm) ta))) ((type>= #tnon-positive-real t1) (type-or1 (type-and #tnon-positive-real tm) (super-range '- (type-and #tnon-negative-real tm) ta))) ((type-or1 tm (super-range '- tm))))))) (si::putprop 'rem 'rem-propagator 'type-propagator) (defun floor-propagator (f t1 &optional (t2 #t(member 1)) &aux (t1 (type-and #treal t1))(t2 (type-and #treal t2)) (i (member f '(floor truncate round ceiling)))) (let* ((sr (super-range (lambda (x) (cond ((isinf x) (if i (if (> x 0) '+rinf '-rinf) x)) ((isnan x) (if i 'rnan x)) ((funcall f x)))) (/-propagator '/ t1 t2))) (sr (if i (type-and #tinteger sr) sr))) (when sr `(returns-exactly ,sr ,(cond ((member f '(floor ffloor)) (mod-propagator f t1 t2)) ((member f '(ceiling fceiling)) (super-range '- (mod-propagator f t1 t2))) ((member f '(truncate ftruncate round fround)) (rem-propagator f t1 t2))))))) (dolist (l '(floor ceiling truncate round ffloor fceiling ftruncate fround)) (si::putprop l 'floor-propagator 'type-propagator) (si::putprop l t 'c1no-side-effects)) (defun ash-propagator (f t1 t2) (and (type>= #tfixnum t1) (type>= #t(integer #.most-negative-fixnum #.(integer-length most-positive-fixnum)) t2) (super-range f t1 t2))) (si::putprop 'ash 'ash-propagator 'type-propagator) (si::putprop 'si::mpz_mul_2exp 'ash-propagator 'type-propagator) (si::putprop 'si::mpz_fdiv_q_2exp 'ash-propagator 'type-propagator) (defun <<-propagator (f t1 t2) (when (type>= #tfixnum t1) (super-range (lambda (x y) (if (when (typep y 'fixnum) (> (- #.(1+ (integer-length most-positive-fixnum)) (integer-length x)) y)) (funcall f x y) (return-from <<-propagator nil))) t1 t2))) (si::putprop 'si::<< '<<-propagator 'type-propagator) (defun >>-propagator (f t1 t2) (when (and (type>= #tfixnum t1) (type>= #t(integer 0 #.(integer-length most-positive-fixnum)) t2)) (super-range f t1 t2))) (si::putprop 'si::>> '>>-propagator 'type-propagator) (defun pexpt (x y) ;; x>=0, y>=0 (typecase y ((real 0 0) (1+ y)) ((integer 1000) '+rinf) (otherwise (expt x y)))) (defun expt-propagator (f t1 t2) (declare (ignore f)) (when (type>= #tnon-negative-real t1) (when (type>= #treal t2) (type-or1 (super-range 'pexpt t1 (type-and #tnon-negative-real t2)) (/-propagator '/ (super-range 'pexpt t1 (super-range '- (type-and #tnegative-real t2)))))))) (si::putprop 'expt 'expt-propagator 'type-propagator) ;; (defun exp-propagator (f t1) ;; (declare (ignore f)) ;; (expt-propagator 'expt (if (type>= #tshort-float t1) (object-type (float +e+ 0.0s0)) (object-type +e+)) t1)) ;; (si::putprop 'exp 'exp-propagator 'type-propagator) (defun integer-length-propagator (f t1) (when (type>= #tfixnum t1) (type-or1 (super-range f (type-and #tnon-negative-real t1)) (super-range f (type-and #tnon-positive-real t1))))) (si::putprop 'integer-length 'integer-length-propagator 'type-propagator) ;(defconstant +clzl0+ (let ((x (1+ (si::clzl 1)))) (cmp-norm-tp `(integer ,x ,x)))) ;(defconstant +clzl0+ (let ((x (1- si::fixnum-length))) (cmp-norm-tp `(integer ,x ,x)))) (defun bnd-clzl (x y) (let* ((lx (si::clzl x))(ly (si::clzl y))(m (if (if (minusp x) (plusp y) (minusp y)) (si::clzl 0) lx))) (cmp-norm-tp `(integer ,(min lx ly m) ,(max lx ly m))))) (defun clzl-propagator (f t1 &aux (t1 (type-and #tfixnum t1)));FIXME wrap (declare (ignorable f)) (unless (type<= #tfixnum t1) (if (atom t1) (apply 'bnd-clzl (real-bnds t1)) (reduce 'type-or1 (mapcar (lambda (x) (bnd-clzl (car x) (cdr x))) (cdr (assoc 'integer (caaddr t1)))) :initial-value nil)))) (si::putprop 'si::clzl 'clzl-propagator 'type-propagator) (si::putprop 'si::clzl t 'cmp-inline);FIXME no declaim (defun bnd-ctzl (x y &optional (i 0) res) (if (eql x y) (cmp-norm-tp (cons 'member (cons (+ (if (zerop x) 0 i) (si::ctzl x)) res))) (bnd-ctzl (>> (if (oddp x) (1+ x) x) 1) (>> (if (oddp y) (1- y) y) 1) (1+ i) (cons i res)))) (defun ctzl-propagator (f t1 &aux (t1 (type-and #tfixnum t1))) (declare (ignorable f)) (unless (type<= #tfixnum t1) (if (atom t1) (apply 'bnd-ctzl (real-bnds t1)) (reduce 'type-or1 (mapcar (lambda (x) (bnd-ctzl (car x) (cdr x))) (cdr (assoc 'integer (caaddr t1)))) :initial-value nil)))) (si::putprop 'si::ctzl 'ctzl-propagator 'compiler::type-propagator) (si::putprop 'si::ctzl t 'compiler::cmp-inline);FIXME no declaim (defun abs-propagator (f t1) (when t1 (type-and #tnon-negative-real (type-or1 (let ((t1 (type-and t1 #tcomplex))) (when t1 (super-range '+ (abs-propagator f (complex-real-type-propagator 'complex-real t1)) (abs-propagator f (complex-imag-type-propagator 'complex-imag t1))))) (let ((t1 (type-and #treal t1))) (type-or1 t1 (super-range '- t1))))))) (si::putprop 'abs 'abs-propagator 'type-propagator) (defun cosh-propagator (f t1) (type-or1 (super-range f (type-and t1 #t(not real))) (type-or1 (super-range f (type-and t1 #tnon-negative-real)) (super-range f (type-and t1 #tnegative-real))))) (si::putprop 'cosh 'cosh-propagator 'type-propagator) (defun shrnfm (t1 m o &aux (sf (type>= #tshort-float t1)) (m (if sf (float m 0.0s0) m)) (o (if sf (float o 0.0s0) o)));FIXME (let* ((r (real-bnds t1)) (s (if (numberp (car r)) (ftruncate (+ o (car r)) m) 0)) (k (cmp-norm-tp `(real ,(- o) (,(- m o))))) (st (super-range '- t1 (object-tp (* s m))))) (type-and k (type-or1 st (super-range '- st (object-tp m))))));FIXME max period (defconstant +pi+ (atan 0 -1)) (defconstant +pid2+ (* 0.5 (atan 0 -1))) (defun float-proxy-propagator (f t1) (declare (ignore f)) (reduce 'type-or1 (mapcar (lambda (x) (super-range (lambda (x) (cond ((isinf x) (if (> x 0) +inf -inf)) ((isnan x) nan) ((float x)))) (type-and t1 x))) '(#tnegative-real #tnon-negative-real)) :initial-value nil)) (si::putprop 'si::big-to-double 'float-proxy-propagator 'type-propagator) (si::putprop 'si::ratio-to-double 'float-proxy-propagator 'type-propagator) (defun sqrt-propagator (f t1) (type-or1 (super-range f (type-and t1 #tcomplex)) (type-or1 (super-range f (type-and t1 #tnon-negative-real)) (super-range 'sqrt (type-and t1 #tnegative-real))))) (si::putprop 'sqrt 'sqrt-propagator 'type-propagator) (defun cos-propagator (f t1) (type-or1 (super-range f (type-and t1 #tcomplex)) (let ((z (shrnfm (type-and t1 #treal) (* 2 +pi+) +pi+))) (type-or1 (super-range f (type-and z #tnon-negative-real)) (super-range f (type-and z #tnegative-real)))))) (si::putprop 'cos 'cos-propagator 'type-propagator) (defun sin-propagator (f t1) (type-or1 (super-range f (type-and t1 #tcomplex)) (let ((z (shrnfm (type-and t1 #treal) (* 2 +pi+) +pid2+))) (type-or1 (super-range f (type-and z (cmp-norm-tp `(real * (,+pid2+))))) (super-range f (type-and z (cmp-norm-tp `(real ,+pid2+))))))));FIXME (si::putprop 'sin 'sin-propagator 'type-propagator) (defun tan-propagator (f t1) (type-or1 (super-range f (type-and t1 #tcomplex)) (let ((z (shrnfm (type-and t1 #treal) +pi+ +pid2+))) (type-or1 (super-range f (type-and z #tnon-negative-real)) (super-range f (type-and z #tnegative-real)))))) (si::putprop 'tan 'tan-propagator 'type-propagator) (defun asin-propagator (f t1) (type-or1 (super-range f (type-and t1 #tcomplex)) (type-or1 (super-range (lambda (x) (funcall f (/ x 6))) (super-range '* #t(integer 6 6) (type-and t1 #t(real -1 1)))) (super-range f (type-and t1 #t(not (real -1 1))))))) (si::putprop 'asin 'asin-propagator 'type-propagator) (si::putprop 'acos 'asin-propagator 'type-propagator) (defun atanh-pole (x &aux (d (pole-d x))(x (bound-num x))(x (if (integerp x) (float x) x))) (cond ((= x 1) (let ((x (coerce +inf (pole-type x)))) (if (minusp d) x (complex (realpart x) (float +pid2+ (realpart x)))))) ((= x -1) (let ((x (coerce -inf (pole-type x)))) (if (plusp d) x (complex (realpart x) (float +pid2+ (realpart x)))))) ((atanh x)))) (setf (get 'atanh-pole 'pole) t) (defun atanh-propagator (f t1) (declare (ignore f)) (reduce 'type-or1 (mapcar (lambda (x) (super-range 'atanh-pole (type-and t1 x))) '(#tcomplex #t(real * (-1)) #t(real (-1) (1)) #t(real (1)))) :initial-value nil)) (si::putprop 'atanh 'atanh-propagator 'type-propagator) (defun acosh-propagator (f t1) (type-or1 (super-range f (type-and t1 #tcomplex)) (type-or1 (super-range f (type-and t1 #t(real 1))) (super-range f (type-and t1 #t(real * (1))))))) (si::putprop 'acosh 'acosh-propagator 'type-propagator) (defun make-vector-propagator (f et st &rest r) (declare (ignore f)) (cmp-norm-tp `(,(if (and (type>= #tnull (pop r)) (type>= #tnull (pop r)) (type>= #tnull (car r))) 'simple-array 'array) ,(or (car (atomic-tp et)) '*) (,(or (car (atomic-tp st)) '*))))) (si::putprop 'si::make-vector 'make-vector-propagator 'type-propagator) (defun make-array1-propagator (f &rest r) (declare (ignore f)) (cmp-norm-tp `(array ,(or (car (atomic-tp (car r))) '*) ,(or (let* ((x (car (atomic-tp (sixth r))));FIXME centralize (x (if (integerp x) (make-list x :initial-element '*) x))) (mapcar (lambda (x) (if (integerp x) x '*)) x)) '*)))) (si::putprop 'si::make-array1 'make-array1-propagator 'type-propagator) (defun promoted-c-type (type &aux r) (let ((type (coerce-to-one-value type))) (cond ((eq type 'object) type);FIXME ((setq r (member type +promoted-c-types+ :test 'type<=)) (car r)) (#tt)))) (defun single-type-p (type) (if (listp type) (case (car type) (returns-exactly (when (cdr type) (unless (cddr type) (cadr type)))) (values nil) (otherwise type)) (unless (eq type '*) type))) (defun coerce-to-one-value (type) (type-and type t)) (defun unprintable-individualsp (u) (case (when (listp u) (car u)) ((or returns-exactly values) (member-if 'unprintable-individualsp (cdr u))) (member (member-if (lambda (x) (or (si::si-classp x) (typep x '(or function cons binding array)))) (cdr u))) ((short-float long-float) (member-if (lambda (x) (or (isinf x) (isnan x))) (cdr u))) (otherwise (si::si-classp u)))) (defun export-type (type) (if (unprintable-individualsp (cmp-unnorm-tp type)) (bump-tp type) type)) (defun unique-sigs (sig) (si::uniq-list sig)) (defun tsrch (tp &optional (y *useful-type-tree*)) (let ((x (member tp y :test 'type<= :key 'car))) (when x (or (tsrch tp (cdar x)) (caar x))))) (defun bump-tp (tp) (cond ((eq tp '*) tp) ((and (consp tp) (member (car tp) '(values returns-exactly))) `(,(car tp) ,@(mapcar 'bump-tp (cdr tp)))) ((type>= tp #tnull) (type-or1 #tnull (bump-tp (type-and #t(not null) tp)))) ((tsrch tp)) (t))) (defun check-form-type (type form original-form) (when (and (null (type-and type (info-type (cadr form)))) type (info-type (cadr form))) (cmpwarn "The type of the form ~s is not ~s, but ~s." original-form (cmp-unnorm-tp type) (cmp-unnorm-tp (info-type (cadr form)))))) (defun c-structure-def-propagator (f t1) (declare (ignore f)) (when (symbolp t1) (let ((tem (get t1 's-data))) (when tem (object-type tem))))) (setf (get 'c-structure-def 'type-propagator) 'c-structure-def-propagator) (defun structure-name-propagator (f t1) (declare (ignore f)) (when (symbolp t1) (when (get t1 's-data) (object-type t1)))) (setf (get 'si::structure-name 'type-propagator) 'structure-name-propagator) (defun expand-type-propagator (f t1 &aux (a (atomic-tp t1))(b (car a)));FIXME organization (when a (when (constant-type-p b) (object-type (funcall f b))))) (dolist (l 'si::(expand-array-element-type expand-deftype sdata-includes lookup-simple-typep-fn lookup-typep-fn)) (setf (get l 'compiler::c1no-side-effects) t) (setf (get l 'compiler::type-propagator) 'compiler::expand-type-propagator)) (defun improper-consp-type-propagator (f t1 &optional t2) (declare (ignore f t2)) (cond ((not (type-and #tsi::improper-cons t1)) #tnull) ((type>= #tsi::improper-cons t1) #ttrue))) (dolist (l 'si::(improper-consp)) (setf (get l 'compiler::c1no-side-effects) t) (setf (get l 'compiler::type-propagator) 'compiler::improper-consp-type-propagator)) (defun symbol-gfdef-propagator (f t1 &aux (a (atomic-tp t1))) (declare (ignore f)) (if a (object-type (funid-to-fn (car a))) #tfunction));FIXME 0 (setf (get 'c-symbol-gfdef 'type-propagator) 'symbol-gfdef-propagator) gcl27-2.7.0/cmpnew/gcl_cmputil.lsp000077500000000000000000000201361454061450500167620ustar00rootroot00000000000000;;; 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 *warning-note-stack*) (defvar *suppress-compiler-warnings* nil) (defmacro maybe-to-wn-stack (&rest body) (let ((cf (sgen "MTWSCF"))(sri (sgen "MTWSSRI"))) `(if (and (boundp '*warning-note-stack*) (not *note-keys*)) (let ((,cf *current-form*)(,sri *src-inline-recursion*)) (push (lambda nil (let ((*current-form* ,cf) (*src-inline-recursion* ,sri)) ,@body)) *warning-note-stack*)) (progn ,@body)))) (defun output-warning-note-stack nil (when (boundp '*warning-note-stack*) (do ((*warning-note-stack* (nreverse *warning-note-stack*))) ((not *warning-note-stack*)) (funcall (pop *warning-note-stack*))))) (defun print-sri-stack nil (let ((*print-length* 2) (*print-level* 2) (f (cadr *current-form*))) (dolist (s *src-inline-recursion*) (unless (eq (caar s) f) (format t "; inlining ~s~%" (cons (name-sir (car s)) (cdr s))))))) (defun cmpwarn (string &rest args &aux (*print-case* :upcase)) (unless *suppress-compiler-warnings* (maybe-to-wn-stack (print-current-form) (print-sri-stack) (format t ";; Warning: ") (apply #'format t string args) (terpri))) nil) (defvar *suppress-compiler-notes* t) (defvar *note-keys* nil) (defun watch (key) (pushnew key *note-keys*)) (defun unwatch (&rest keys) (setq *note-keys* (when keys (nset-difference *note-keys* keys)))) (defun cmpnote (string &rest args &aux (*print-case* :upcase)) (maybe-to-wn-stack (print-current-form) (print-sri-stack) (format t ";; Note: ") (apply #'format t string args) (terpri)) nil) (defun do-keyed-cmpnote (k string &rest args &aux (*print-case* :upcase)) (do ((k k (when (consp k) (cdr k)))) ((not k)) (let ((k (if (consp k) (car k) k))) (when (member k *note-keys* :test (lambda (x y) (or (eq x y) (eq 'all y)))) (apply 'cmpnote string args) (return))))) (defmacro keyed-cmpnote (key string &rest args) `(when *note-keys* (do-keyed-cmpnote ,key ,string ,@args))) ;; (defun keyed-cmpnote (key string &rest args &aux (*print-case* :upcase)) ;; (when *note-keys* ;; (let ((keys (if (atom key) (list key) key))) ;; (when (intersection keys *note-keys* :test (lambda (x y) (or (eq x y) (eq 'all y)))) ;; (apply 'cmpnote string args))))) ;; (declaim (inline keyed-cmpnote)) (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)) (cmpwarn ";; The variable ~s is undefined.~%~ ;; The compiler will assume this variable is a global.~%" sym)) (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*) ) (defun cmp-eval (form) (multiple-value-bind (x y) (cmp-toplevel-eval `(eval ',form)) (if 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) y))) ;(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))))) (defmacro macroexpand-helper (pre meth form) (let ((c (sgen "MHC"))(x (sgen "MHX"))(e (sgen "MHE"))) `(let ((,c (when (consp ,form) (car ,form)))) ,@(when pre `(,pre)) (cond ((not ,c) ,form) ((not (symbolp ,c)) ,form) ((and (not (assoc ,c (cadr *macrolet-env*))) (not (macro-function ,c))) ,form) ((let* ((,x (multiple-value-list (cmp-toplevel-eval `,,meth))) (,e (car ,x))) (cond ((not ,e) (cadr ,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)))))))))) (defun cmp-macroexpand (form) (macroexpand-helper nil `(macroexpand ',form ',*macrolet-env*) form)) (defun cmp-macroexpand-1 (form) (macroexpand-helper nil `(macroexpand-1 ',form ',*macrolet-env*) form)) (defun cmp-expand-macro (fd fname args) (let ((x (cons fname args))) (macroexpand-helper (and *record-call-info* (add-macro-callee fname)) `(funcall *macroexpand-hook* ',fd ',x ',*macrolet-env*) x))) (defvar *compiler-break-enable* nil) (defun cmp-toplevel-eval (form) (let* ((si::*ihs-base* si::*ihs-top*) (si::*ihs-top* (1- (si::ihs-top))) (si::*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 inline-safe inline-unsafe inline-always c1conditional c2 c1 c1+ co1 si::structure-access co1special top-level-macro t3 t2 t1)) (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 gcl27-2.7.0/cmpnew/gcl_cmpvar.lsp000077500000000000000000000775601454061450500166120ustar00rootroot00000000000000;;; 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 'cvar 'set-cvar 'set-loc) (si:putprop 'var 'wt-var 'wt-loc) (defstruct (var (:print-function (lambda (x s i) (s-print 'var (var-name x) (si::address x) s)))) 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. (dt t) ;;; Declared Type of the variable. (type t) ;;; Current Type of the variable. (mt t) ;;; Maximum type of the life of this binding tag ;;; Inner tag (to binding) being analyzed if any (register 0 :type unsigned-char) ;;; If greater than specified am't this goes into register. (flags 0 :type unsigned-char) ;;; If variable is declared dynamic-extent (space 0 :type char) ;;; If variable is declared as an object array of this size (known-init -1 :type char) ;;; Number of above known to be implicitly initialized store ;;; keep kind in hashed c1forms aliases ) (si::freeze-defstruct 'var) (defun var-dynamic (v);FIXME (/= 0 (logand 1 (var-flags v)))) (defun var-reffed (v) (/= 0 (logand 2 (var-flags v)))) (defun var-noreplace (v) (/= 0 (logand 4 (var-flags v)))) (defun var-set (v) (/= 0 (logand 8 (var-flags v)))) (defun var-aliased (v) (/= 0 (logand 16 (var-flags v)))) (defun set-var-dynamic (v) (setf (var-flags v) (logior 1 (var-flags v)))) (defun set-var-reffed (v) (setf (var-flags v) (logior 2 (var-flags v)))) (defun set-var-noreplace (v) (setf (var-flags v) (logior 4 (var-flags v)))) (defun set-var-set (v) (setf (var-flags v) (logior 8 (var-flags v)))) (defun set-var-aliased (v) (setf (var-flags v) (logior 16 (var-flags v)))) (defun unset-var-set (v) (setf (var-flags v) (logandc2 (var-flags v) 8))) (defun unset-var-aliased (v) (setf (var-flags v) (logandc2 (var-flags v) 16))) ;;; 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 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 ens-k-tp (tp) (or (third tp) (member-if (lambda (x) (when (member (car x) '(proper-cons si::improper-cons)) (member-if (lambda (x) (when (listp x) (or (ens-k-tp (car x)) (ens-k-tp (cadr x))))) (cdr x)))) (car tp)))) (defun ensure-known-type (tp) (if (when (listp tp) (ens-k-tp (third tp))) (car tp) tp)) (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) (dolist (v types) (when (eq (car v) name) (case (cdr v) (object (setf (var-loc var) 'object)) (register (setf (var-register var) (+ (var-register var) 100))) (dynamic-extent #+dynamic-extent (set-var-dynamic var)) (t (unless (and (not (get (var-name var) 'tmp));FIXME *compiler-new-safety*) (setf (var-type var) (ensure-known-type (nil-to-t (type-and (var-type var) (cdr v)))))))))) (cond ((or (member name specials) (si:specialp name)) (setf (var-kind var) 'SPECIAL) (setf (var-loc var) (add-symbol name)) (when (and (not *compiler-new-safety*) (not (assoc name types)) (setq x (get name 'cmp-type))) (setf (var-type var) (ensure-known-type x))) (setq *special-binding* t)) (t (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)))) (setf (var-mt var) (var-type var)) (setf (var-dt var) (var-type var)) var)) (defun check-vref (var) (unless *in-inline* (when (and (eq (var-kind var) 'LEXICAL) (not (var-reffed var)) (not (var-ref var)));;; This field may be IGNORE or IGNORABLE here. (cmpwarn "The variable ~s is not used." (var-name var))))) (defun var-cb (v) (or (var-ref-ccb v) (eq 'clb (var-loc v)))) (defun add-vref (vref info &optional setq) (cond ((cadr vref) (push (car vref) (info-ref-ccb info))) ((caddr vref) (push (car vref) (info-ref-clb info))) ((not setq) (push (car vref) (info-ref info))))) (defun make-vs (info) (mapcan (lambda (x) (when (var-p x) (list (cons x (var-bind x))))) (info-ref info))) (defun check-vs (vs &aux (b (member-if-not 'var-p *vars*))) (not (member-if-not (lambda (x &aux (v (pop x))(vv (member v *vars*))) (when vv (when (tailp b vv) (bind-match x v)))) vs))) (defun c1var (name) (let* ((info (make-info)) (vref (c1vref name)) (tmp (get-var (local-var vref))) (tmp (unless (eq tmp (car vref)) tmp)) (vref (if tmp (c1vref tmp) vref)) (c1fv (when (cadr vref) (c1inner-fun-var)))) (setf (info-type info) (if (or (cadr vref) (caddr vref)) (var-dt (car vref)) (var-type (car vref))) (var-mt (car vref)) (type-or1 (info-type info) (var-mt (car vref)))) (add-vref vref info) (when c1fv (add-info info (cadr c1fv))) (mapc (lambda (x) (setf (info-ch-ccb info) (nunion (info-ch-ccb info) (info-ch-ccb (cadr x)))));FIXME nunion asym (binding-forms (var-store (car vref)))) (let ((fmla (exit-to-fmla-p))) (cond ((when fmla (type>= #tnull (info-type info))) (c1nil)) ((when fmla (type>= #t(not null) (info-type info))) (c1t)) ((let ((tmp (get-vbind-form (local-var vref)))) (when (and tmp );FIXME (type>= (var-mt (car vref)) (var-mt (caaddr tmp))) (when (check-vs (when (eq 'var (car tmp)) (car (last tmp)))) (let* ((f (pop tmp))(i (copy-info (pop tmp)))) ; (setf (info-type i) (if (eq f 'var) (var-type (caar tmp)) (type-and (info-type i) (info-type info))));FIXME (setf (info-type i) (type-and (info-type i) (info-type info))) (when (eq f 'var) (setf (info-type i) (type-and (info-type i) (var-type (caar tmp))))) (list* f i tmp)))))) ((list 'var info vref c1fv (make-vs info))))))) (defun ref-obs1 (form obs sccb sclb s &aux (i (cadr form))) (mapc (lambda (x) (when (member x (info-ref-ccb i)) (funcall sccb x)) (when (member x (info-ref-clb i)) (funcall sclb x)) (when (member x (info-ref i)) (funcall s x))) obs)) (declaim (inline ref-obs1)) (defvar *fast-ref* t) (defun ref-obs (form obs sccb sclb s n ns r &optional l &aux vref) (cond ((not l) (cond (*fast-ref* (ref-obs1 form obs sccb sclb s)) ((let* ((l (list (info-ref (cadr form)) (info-ref-ccb (cadr form)) (info-ref-clb (cadr form)))) (l (mapcar (lambda (x) (intersection x obs)) l)) (l (mapcar (lambda (y) (mapcar (lambda (x) (cons x nil)) y)) l))) (ref-obs form obs sccb sclb s n ns r l) (let* (y (x (member-if (lambda (x) (setq y (member nil x :key 'cdr))) l))) (when y (cmpwarn "~s ~s ~s referenced in info but not in form" (length (ldiff l x)) ns (funcall n (caar y))))))))) ((atom form)) ((setq vref (funcall r form)) (let* ((v (pop vref)) (ccb (pop vref)) (clb (car vref))) (when (member v obs) (cond (ccb (funcall sccb v)) (clb (funcall sclb v)) ((funcall s v))) (when l (let* ((y (cond (ccb (cadr l))(clb (caddr l))((car l))))(x (assoc v y))) (if x (rplacd x t) (cmpwarn "~s ~s ~s referenced in form but not in info" (if ccb 'cb (if clb 'lb)) ns (funcall n v))))) (keyed-cmpnote (list 'ref (funcall n v)) "~s ~s is referenced with barrier ~s" ns (funcall n v) (if ccb 'cb (if clb 'lb)))) (ref-obs (cdddr form) obs sccb sclb s n ns r l))) (t (ref-obs (car form) obs sccb sclb s n ns r l) (ref-obs (cdr form) obs sccb sclb s n ns r l)))) (declaim (inline ref-obs)) (defun ref-vars (form vars) (ref-obs form vars (lambda (x) (when (eq (var-kind x) 'lexical) (setf (var-ref-ccb x) t))) (lambda (x) (when (eq (var-kind x) 'lexical) (setf (var-loc x) 'clb)) (setf (var-ref x) t)) (lambda (x) (setf (var-ref x) t (var-register x) (1+ (var-register x)))) 'var-name "Var" (lambda (x &aux (y (pop x))) (when (member y '(var setq)) (let ((z (cadr x))) (unless (and (eq y 'setq) (not (cadr z)) (not (caddr z))) z)))))) (defun inner-fun-var (&optional (v *vars*) f &aux (y v) (x (pop v))) (cond ((atom v) nil) ((is-fun-var x) (inner-fun-var v y)) ((eq x 'cb) f) ((inner-fun-var v f)))) (defun c1inner-fun-var nil (let ((*vars* (inner-fun-var))) (c1var (var-name (car *vars*))))) (defun local-var (vref &aux (v (pop vref))) (unless (or (car vref) (cadr vref)) v)) (defun get-vbind-form (form &aux (binding (get-vbind form))) (when binding (when (binding-repeatable binding) (binding-form binding)))) (defun var-bind (var &aux (st (when (var-p var) (when (eq 'lexical (var-kind var)) (var-store var))))) (unless (cdr st) (car st))) (defun get-vbind (form) (var-bind (typecase form ((cons (eql var) t) (when (check-vs (car (last form))) (local-var (caddr form)))) (var form)))) (defun get-bind (x) (typecase x ((cons (eql var) t) (when (check-vs (car (last x))) (var-bind (local-var (caddr x))))) (var (var-bind x)) (binding x))) (defun repeatable-var-binding (form) (case (car form) (var form) (location form) ;; (lit (unless (member-if (lambda (x) (when (stringp x) (>= (si::string-match #v"[a-zA-Z0-9]+\\(" x) 0))) form) ;; form)) )) (defun repeatable-binding-p (form &aux (i (cadr (repeatable-var-binding form)))) (when i (when (info-type i) (unless (iflag-p (info-flags i) side-effects) (unless (or (info-ref-clb i) (info-ref-ccb i)) t))))) (defstruct (binding (:print-function (lambda (x s i) (s-print 'binding (binding-repeatable x) (si::address x) s)))) form repeatable) (defun new-bind (&optional form) (make-binding :form form :repeatable (repeatable-binding-p form))) (defun or-bind (b l &aux (bi (cadr (binding-form b)))) (cond ((when (cdr l) (when bi (not (info-ch-ccb bi))));FIXME coalesce anonymous too? (pushnew b l :test (lambda (x y) (or (eq x y) (when (binding-form y) (type<= (info-type bi) (info-type (cadr (binding-form y))))))))) ((pushnew b l)))) (defun or-binds (l1 l2) (reduce (lambda (y x) (or-bind x y)) l1 :initial-value l2)) (defun bind-block (name) (or (eq name +mv+); FIXME c1 *mv-var* ; (eq name +first+) ; (eq name +fun+) ; (get name 'tmp) ; (eq name +nargs+) ;FIXME invalidate on call )) (defun push-vbind (var form &optional or) (unless (bind-block (var-name var)) (setf (var-store var) (or-bind (or (get-bind form) (new-bind form)) (when or (var-store var)))))) (defun push-vbinds (var forms); &optional or (mapc (lambda (x) (push-vbind var x t)) forms)) (defun bind-match (f1 f2 &aux (b1 (get-bind f1))) (when b1 (eq b1 (get-bind f2)))) (defun get-top-var-binding (bind) (labels ((f (l) (member bind l :key 'var-bind)) (r (l) (let* ((var (car l)) (nl (f (cdr l))) (nl (when (eq nl (member (car nl) *vars*)) nl)));FIXME impossible? (if (tailp nl (member-if-not 'var-p l)) var (r nl))))) (when bind ;FIXME defvar (r (f *vars*))))) (defun get-var (o &aux (vp (var-p o))) (or (get-top-var-binding (if vp (get-vbind o) o)) (when vp o))) (defun c1vref (name &aux ccb clb) (dolist (var *vars* (let ((var (sch-global name))) (unless var (unless (symbolp name) (baboon)) (unless (or (si:specialp name) (constantp name)) (undefined-variable name)) (setq var (make-var :name name :kind 'GLOBAL :loc (add-symbol name) :type (or (get name 'cmp-type) t) :ref t));FIXME (push var *undefined-vars*)) (list var ccb))) (cond ((eq var 'cb) (setq ccb t)) ((eq var 'lb) (setq clb t)) ((or (when (eq (var-name var) name) (not (member var *lexical-env-mask*))) (eq var name)) (set-var-reffed var) (keyed-cmpnote (list 'var-ref (var-name var)) "Making variable ~s reference with barrier ~s" (var-name var) (if ccb 'cb (if clb 'lb))) (when (or ccb clb) (unless (eq (var-kind var) 'lexical) (cmpwarn "Cross closure reference to non-lexical variable ~s, which is likely not what you want" (var-name var)))) (return-from c1vref (list* var (if (eq (var-kind var) 'lexical) (list ccb clb) '(nil nil)))))))) ;; (defun c1vref (name &optional setq &aux ccb clb) ;; (dolist (var *vars* ;; (let ((var (sch-global name))) ;; (unless var ;; (unless (or (si:specialp name) (constantp name)) (undefined-variable name)) ;; (setq var (make-var :name name ;; :kind 'GLOBAL ;; :loc (add-symbol name) ;; :type (or (get name 'cmp-type) t) ;; :ref t));FIXME ;; (push var *undefined-vars*)) ;; (list var ccb))) ;; (cond ((eq var 'cb) (setq ccb t)) ;; ((eq var 'lb) (setq clb t)) ;; ((or (eq (var-name var) name) (eq var name)) ;; (set-var-reffed var) ;; (keyed-cmpnote (list 'var-ref (var-name var)) ;; "Making variable ~s reference with barrier ~s" (var-name var) (if ccb 'cb (if clb 'lb))) ;; (let ((nv (if setq var (get-var var)))) ;; (return-from c1vref (if (eq var nv) (list var ccb clb) (c1vref nv setq)))))))) ;; (defun c1vref (name &optional setq &aux ccb clb) ;; (dolist (var *vars* ;; (let ((var (sch-global name))) ;; (unless var ;; (unless (or (si:specialp name) (constantp name)) (undefined-variable name)) ;; (setq var (make-var :name name ;; :kind 'GLOBAL ;; :loc (add-symbol name) ;; :type (or (get name 'cmp-type) t) ;; :ref t));FIXME ;; (push var *undefined-vars*)) ;; (list var ccb))) ;; (cond ((eq var 'cb) (setq ccb t)) ;; ((eq var 'lb) (setq clb t)) ;; ((or (eq (var-name var) name) (eq var name)) ;; (set-var-reffed var) ;; (keyed-cmpnote (list 'var-ref (var-name var)) ;; "Making variable ~s reference with barrier ~s" (var-name var) (if ccb 'cb (if clb 'lb))) ;; (return-from c1vref (list (if setq var (get-var var)) ccb clb)))))) ;; (defun c1vref (name &aux ccb clb) ;; (dolist (var *vars* ;; (let ((var (sch-global name))) ;; (unless var ;; (unless (or (si:specialp name) (constantp name)) (undefined-variable name)) ;; (setq var (make-var :name name ;; :kind 'GLOBAL ;; :loc (add-symbol name) ;; :type (or (get name 'cmp-type) t) ;; :ref t));FIXME ;; (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) ;; (set-var-reffed var) ;; (keyed-cmpnote (list 'var-ref (var-name var)) ;; "Making variable ~s reference with barrier ~s" (var-name var) (if ccb 'cb (if clb 'lb))) ;; (let ((l (list var ccb clb))) ;; (push l (var-store var)) ;; (return-from c1vref l)))))) ;; (defun c1vref (name &aux ccb clb) ;; (dolist (var *vars* ;; (let ((var (sch-global name))) ;; (unless var ;; (unless (or (si:specialp name) (constantp name)) (undefined-variable name)) ;; (setq var (make-var :name name ;; :kind 'GLOBAL ;; :loc (add-symbol name) ;; :type (or (get name 'cmp-type) t) ;; :ref t));FIXME ;; (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) ;; (set-var-reffed var) ;; (keyed-cmpnote (list 'var-ref (var-name var)) ;; "Making variable ~s reference with barrier ~s" (var-name var) (if ccb 'cb (if clb 'lb))) ;; (return-from c1vref (list var ccb clb)))))) ;; (defun c1vref (name &optional noref &aux ccb clb inner) ;; (dolist (var *vars* ;; (let ((var (sch-global name))) ;; (unless var ;; (unless (or (si:specialp name) (constantp name)) (undefined-variable name)) ;; (setq var (make-var :name name ;; :kind 'GLOBAL ;; :loc (add-symbol name) ;; :type (or (get name 'cmp-type) t) ;; :ref t));FIXME ;; (push var *undefined-vars*)) ;; (list var ccb))) ;; (cond ((eq var 'cb) (setq ccb t inner (or inner 'cb))) ;; ((eq var 'lb) (setq clb t inner (or inner 'lb))) ;; ((eq (var-name var) name) ;; (when (eq (var-ref var) 'IGNORE) ;; (cmpwarn "The ignored variable ~s is used." name) ;; (unless noref (setf (var-ref var) t))) ;; (cond (ccb ;; (ref-inner inner) ;; (setf (var-ref-ccb var) t));FIXME think noref ;; (clb ;; (when (eq (var-kind var) 'lexical) (setf (var-loc var) 'clb)) ;; (setf (var-ref var) t));FIXME ;; (t (unless noref (setf (var-ref var) t)) ;; (setf (var-register var) (1+ (var-register var))))) ;; (return-from c1vref (list var ccb)))))) (defun c2var-kind (var) (when (and (eq (var-kind var) 'LEXICAL) (not (var-ref-ccb var)) (not (eq (var-loc var) 'clb))) (cond ((eq (var-loc var) 'object) (setf (var-type var) #tt) (var-loc var)) ;FIXME check ok; need *c-vars* and kind to agree ((car (member (var-type var) +c-local-var-types+ :test 'type<=))) ((and (boundp '*c-gc*) *c-gc* 'OBJECT))))) ;; (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))) ;; (cond ((car (member type +c-local-var-types+ :test 'type<=))) ;; ((and (boundp '*c-gc*) *c-gc* 'OBJECT)) ;; (t nil)))) ;; nil) ;; ) (defun c2var (vref c1fv stores) (declare (ignore c1fv stores)) (unwind-exit (cons 'var vref) nil 'single-value)) ;; (defun c2var (vref c1fv) (declare (ignore c1fv)) (unwind-exit (cons 'var vref) nil 'single-value)) ;; (defun c2var (vref) (unwind-exit (cons 'var vref) nil 'single-value)) (defun c2location (loc) (unwind-exit loc nil 'single-value)) (defun wt-var (var ccb &optional clb) (declare (ignorable clb));FIXME (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))) ; (REPLACED (cond ((and (consp (var-loc var)) (info-p (cadr (var-loc var))))FIXME ; (let* ((*inline-blocks* 0)(v (c2expr (var-loc var))))(print v)(break) ; (unwind-exit (get-inline-loc `((t) t #.(flags) "(#0)") (list v)) ; nil 'single-value) ; (close-inline-blocks))) ; ((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 (let ((z (cdr (assoc (var-kind var) +wt-c-var-alist+)))) (unless z (baboon)) (when (and (equal #tfixnum (var-kind var)) (zerop *space*)) (wt "CMP")) (wt z) (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 &optional clb) (declare (ignore clb)) (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 ";")) (t (wt-nl "V" (var-loc var) "= ") (funcall (or (cdr (assoc (var-kind var) +wt-loc-alist+)) (baboon)) loc) (wt ";"))))) (defun set-cvar (loc cvar) (wt-nl "V" cvar "= ") (let* ((fn (or (car (rassoc cvar *c-vars*)) (cdr (assoc cvar *c-vars*)) t)) (fn (or (car (member fn +c-local-var-types+ :test 'type<=)) 'object)) (fn (cdr (assoc fn +wt-loc-alist+)))) (unless fn (baboon)) (funcall fn loc)) (wt ";")) (defun sch-global (name) (dolist (var *undefined-vars* nil) (when (or (eq var name) (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 (or (get name 'cmp-type) 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))) ((do ((pairs args) forms) ((endp pairs) (c1expr (cons 'progn (nreverse forms)))) (cmpck (endp (cdr pairs)) "No form was given for the value of ~s." (car pairs)) (push (list 'setq (pop pairs) (pop pairs)) forms))))) (defun llvar-p (v) (when (eq (var-kind v) 'lexical) (let ((x (member v *vars*))) (when x (tailp (member-if-not 'var-p *vars*) x))))) (defun do-setq-tp (v form t1) (unless nil ; *compiler-new-safety* FIXME (when (llvar-p v) (setq t1 (ensure-known-type (coerce-to-one-value t1))) (let* ((tp (type-and (var-dt v) t1))) (unless (or tp (not (and (var-dt v) t1))) (cmpwarn "Type mismatches between ~s/~s and ~s/~s." (var-name v) (cmp-unnorm-tp (var-dt v)) (car form) (cmp-unnorm-tp t1))) (keyed-cmpnote (list (var-name v) 'type-propagation 'type) "Setting var-type on ~s from ~s to ~s, form ~s, max ~s" (var-name v) (cmp-unnorm-tp (var-type v)) (cmp-unnorm-tp tp) (car form) (cmp-unnorm-tp (var-mt v))) (when (member v *restore-vars-env*) (pushnew (list v (var-type v) (var-store v)) *restore-vars* :key 'car)) (setf (var-type v) tp) (unless (type>= (var-mt v) tp) (setf (var-mt v) (type-and (bbump-tp (type-or1 (var-mt v) tp)) (var-dt v)))))))) (defun set-form-type (form type) (sft form type)) ;; (defun set-form-type (form type) (setf (info-type (cadr form)) (type-and type (info-type (cadr form))))) ; (sft form type)) FIXME cannot handle nil return types such as tail recursive calls (defun sft-block (form block type) (cond ((atom form)) ((and (eq (car form) 'return-from) (eq (third form) block)) (sft (car (last form)) type)) (t (sft-block (car form) block type) (sft-block (cdr form) block type)))) (defun sft (form type) (let ((it (info-type (cadr form)))) (unless (type>= type it) (let ((nt (type-and type it))) (when nt;FIXME ; (when (eq form +c1nil+) (break)) (setf (info-type (cadr form)) nt) (case (car form) (block (sft-block (fourth form) (third form) type)) ((decl-body inline) (sft (car (last form)) type)) ((let let*) (sft (car (last form)) type) (mapc (lambda (x y) (sft y (var-type x))) (caddr form) (cadddr form))) (var (do-setq-tp (caaddr form) nil (type-and nt (var-type (caaddr form))))) (progn (sft (car (last (third form))) type)) ;; (if ;; (when (ignorable-form (third form));FIXME put third form into progn ;; (let ((tt (type-and type (nil-to-t (info-type (cadr (fourth form)))))) ;; (ft (type-and type (nil-to-t (info-type (cadr (fifth form))))))) ;; (unless tt ;; (sft (fifth form) type) ;; (setf (car form) 'progn (cadr form) (cadr (fifth form)) (caddr form) ;; (list (fifth form)) (cdddr form) nil)) ;; (unless ft ;; (sft (fourth form) type) ;; (setf (car form) 'progn (cadr form) (cadr (fourth form)) (caddr form) ;; (list (fourth form)) (cdddr form) nil))))) )))))) (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)) (when (member (var-kind (car name1)) '(special global));FIXME (setf (info-flags info) (logior (iflags side-effects) (info-flags info)))) ; (push-changed (car name1) info) (add-vref name1 info t) (setq form1 (c1arg form info)) (when (and (eq (car form1) 'var) (or (eq (car name1) (caaddr form1)) (bind-match form1 (car name1)))) (return-from c1setq1 form1)) (unless (and (eq (car form1) 'var) (eq (car name1) (caaddr form1))) (push-changed (car name1) info)) (when (eq (car form1) 'var) (unless (eq (caaddr form1) (car name1)) (pushnew (caaddr form1) (var-aliases (car name1))))) (let* ((v (car name1))(st (var-bind v))) (cond ((and (eq (var-kind v) 'lexical) (or (cadr name1) (caddr name1))) (setq type (info-type (cadr form1))) (push (cons (car name1) form1) (info-ch-ccb info))) (t (do-setq-tp v (list form form1) (info-type (cadr form1))) (setq type (var-type (car name1))) (push-vbind v form1) (keyed-cmpnote (list (var-name v) 'var-bind) "~s store set from ~s to ~s" v st (var-bind v))))) (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) (maybe-reverse-type-prop type form1) (let ((c1fv (when (cadr name1) (c1inner-fun-var)))) (when c1fv (add-info info (cadr c1fv))) (list 'setq info name1 form1 c1fv))) (defun untrimmed-var-p (v) (or (eq t (var-ref v)) (consp (var-ref v)) (var-cb v) (member (var-kind v) '(special global)))) (defun c2setq (vref form c1fv &aux (v (car vref))) (declare (ignore c1fv)) (cond ((untrimmed-var-p v) (let ((*value-to-go* (push 'var vref))) (cond ((member (var-kind v) '(special global));FIXME (let ((loc `(cvar ,(cs-push (var-type v))))) (let ((*value-to-go* loc)) (c2expr* form)) (set-loc loc))) ((c2expr* form)))) (case (car form) (LOCATION (c2location (caddr form))) (otherwise (unwind-exit vref)))) ((c2expr form)))) (defun c1progv (args &aux (info (make-info))) (when (or (endp args) (endp (cdr args))) (too-few-args 'progv 2 (length args))) (list 'progv info (c1arg (pop args) info) (c1arg (pop args) info) (c1progn* args info))) (defun c2progv (symbols values body &aux (cvar (cs-push t t)) (*unwind-exit* *unwind-exit*)) (wt-nl "{object symbols,values;") (wt-nl "bds_ptr V" cvar "=bds_top;") (wt-nl "V" cvar "=V" cvar ";");FIXME lintian unused var (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(symbols->c.c_car)!=t_symbol)") (wt-nl "not_a_symbol(symbols->c.c_car);")) (wt-nl "if(endp(values))bds_bind(symbols->c.c_car,OBJNULL);") (wt-nl "else{bds_bind(symbols->c.c_car,values->c.c_car);") (wt-nl "values=values->c.c_cdr;}") (wt-nl "symbols=symbols->c.c_cdr;}") (setq *bds-used* t)) (c2expr body) (wt "}")) (defun wt-var-decl (var) (cond ((var-p var) (let ((n (var-loc var))) (wt *volatile* (register var) (rep-type (var-kind var)) "V" n ) (wt ";"))) (t (wfs-error)))) gcl27-2.7.0/cmpnew/gcl_cmpvs.lsp000077500000000000000000000056451454061450500164450ustar00rootroot00000000000000;;; 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) "]")) ((= (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 ccb-vs-str (ccb-vs) (format nil "(base0[~a])->c.c_car" (- *initial-ccb-vs* ccb-vs))) (defun wt-ccb-vs (ccb-vs) (wt (ccb-vs-str ccb-vs))) (defun clink (vs &optional (loc nil locp)) (wt-nl) (wt-vs vs) (wt "=make_cons(") (if locp (wt loc) (wt-vs vs)) (wt ",") (wt-clink) (wt ");") (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 nil (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 ",")))) gcl27-2.7.0/cmpnew/gcl_cmpwt.lsp000077500000000000000000000220021454061450500164310ustar00rootroot00000000000000;;; 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) (defstruct (fasd (:type vector)) stream table eof direction package index filepos table_length evald_forms ; list of forms eval'd. (load-time-eval) ) (si::freeze-defstruct 'fasd) (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 ! */ )) ;(require 'FASDMACROS "../cmpnew/gcl_fasdmacros.lsp") (eval-when (compile eval) ; (require 'FASDMACROS "../cmpnew/gcl_fasdmacros.lsp") (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)) ;(defmacro data-inits () `(first *data*)) ;(defmacro data-dl () `(second *data*)) ) (defun wt-comment (message &optional (symbol nil)) (princ " /* " *compiler-output1*) (let* ((mlist (and symbol (list (string symbol)))) (mlist (cons message mlist))) (dolist (s mlist) (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)) ((or (typep form 'fcomplex) (typep form 'dcomplex)) (wt "(" (realpart form) " + I * " (imagpart 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* t) (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) (declare (ignore x));FIXME (incf *next-vv*)) (defun wt-data1 (expr) (terpri *compiler-output-data*) (prin1 expr *compiler-output-data*)) (defun add-init (x &optional endp &aux (tem (cons (memoized-hash-equal x -1000) x))) (if endp (nconc *data* (list tem)) (push tem *data*)) x) (defun add-dl (x &optional endp &aux (tem (cons (memoized-hash-equal x -1000) x))) (if endp (nconc (data-dl) (list tem)) (push tem (data-dl))) x) (defun verify-datum (v) (unless (eql (pop v) (memoized-hash-equal v -1000)) (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" v)) v) (defun wt-fasd-element (x) (si::find-sharing-top x (fasd-table (car *fasd-data*))) (si::write-fasd-top x (car *fasd-data*))) (defun wt-data2 (x) (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) (*print-readably* (not *compiler-compile*)) ;;This forces the printer to add the float type in the .data file. (*READ-DEFAULT-FLOAT-FORMAT* 'long-float) (si::*print-package* t) (si::*print-structure* t)) (if *fasd-data* (wt-fasd-element x) (wt-data1 x)))) (defun wt-data-file nil (when *prof-p* (add-init `(si::mark-memory-as-profiling))) (wt-data2 (1+ *next-vv*)) (cond (*compiler-compile*;FIXME, clean this up (setq *compiler-compile-data* (mapcar 'verify-datum (nreverse *data*))) (wt-data2 `(mapc 'eval *compiler-compile-data*))) (*fasd-data* (dolist (v (nreverse *data*)) (wt-data2 (verify-datum v)))) ((wt-data2 `(progn ,@(mapcar 'verify-datum (nreverse *data*)))))) (when *fasd-data* (si::close-fasd (car *fasd-data*)))) (defun wt-data-begin ()) (defun wt-data-end ()) (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)))))) gcl27-2.7.0/cmpnew/gcl_collectfn.lsp000077500000000000000000000306271454061450500172640ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;;;; ;;; 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 ) (si::freeze-defstruct 'fn) (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)) (let ((sym (si::funid-sym (second *current-form*)))) (symbol-package sym)));;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 (or (si::si-classp (var-type v)) (si::structurep (var-type v)) (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 '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 "sys-proclaim.lisp")) ;; (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 (truename *load-pathname*)));*load-truename* (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)))))))))) gcl27-2.7.0/cmpnew/gcl_fasdmacros.lsp000077500000000000000000000037021454061450500174270ustar00rootroot00000000000000 (in-package :compiler) (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) gcl27-2.7.0/cmpnew/gcl_init.lsp000077500000000000000000000002211454061450500162410ustar00rootroot00000000000000(defun lcs1 (file) (compile-file file :c-file t :h-file t :data-file t :ob-file t :system-p t)) gcl27-2.7.0/cmpnew/gcl_lfun_list.lsp000077500000000000000000000052441454061450500173070ustar00rootroot00000000000000 ;; Modified data base including return values types ;; and making the arglists correct if they have optional args. ;; (in-package :compiler) (dolist (l '((((stream) string) . get-output-stream-string) (((simple-vector seqind) t) . svref) (((si::function-identifier) boolean) . fboundp) (((structure) structure) . si::structure-def) (((t t t t t t t) pathname) . si::init-pathname) (((t t *) (or (integer -1 -1 ) seqind)) . si::string-match) ; (((t) t) . si::type-of-c) ; (((list) t) . si::cons-car) ; (((list) t) . si::cons-cdr) (((t t) cons) . cons) (((fixnum) t) . si::nani) (((t) fixnum) . si::address);FIXME ; (((integer) fixnum) . si::mpz_bitlength) ; (((integer fixnum) integer) . si::shft) (((number number) number) . si::number-plus) (((number number) number) . si::number-minus) (((number number) number) . si::number-times) (((number number) number) . si::number-divide) (((real *) (returns-exactly real real)) . floor) (((real *) (returns-exactly real real)) . ceiling) (((real *) (returns-exactly real real)) . truncate) (((real *) (returns-exactly real real)) . round) ; (((cons t) cons) . rplaca) ; (((cons t) cons) . rplacd) ; (((symbol) boolean) . boundp) ; (((symbol) (or null package)) . symbol-package) ; (((symbol) string) . symbol-name) ; (((symbol) t) . symbol-value) (((symbol t t) t) . si::sputprop) ; (((symbol) (or cons function)) . symbol-function);fixme ;; (((array rnkind) seqind) . array-dimension) ;; (((array) seqind) . array-total-size) ;; (((array) symbol) . array-element-type) ;; (((array) rnkind) . array-rank) ; (((vector) seqind) . si::fill-pointer-internal) (((string) symbol) . make-symbol) ; (((integer integer) integer) . ash) (((float) (returns-exactly (integer 0) fixnum (member 1 -1))) . integer-decode-float);fixme ; (((t *) nil) . error);fixme (((*) string) . si::string-concatenate))) (let ((x (si::call (cdr l) t))) (cond (x (setf (car x) (list (mapcar 'cmp-norm-tp (caar l)) (cmp-norm-tp (cadar l)))) (si::normalize-function-plist x)) ((print (cdr l)))))) (dolist (l '(ceiling truncate round floor));FIXME (c-set-function-vv (symbol-function l) 0) (c-set-function-neval (symbol-function l) 1) ) ; (si::add-hash (cdr l) (export-sig (car l)) nil nil nil)) (dolist (l '(eq eql equal equalp ldb-test logtest)) (setf (get l 'predicate) t)) (dolist (l '(ldb-test logtest)) (setf (get l 'predicate) t)) (declaim (notinline compile compile-file load open truename translate-pathname translate-logical-pathname probe-file)) gcl27-2.7.0/cmpnew/gcl_make-fn.lsp000077500000000000000000000001541454061450500166210ustar00rootroot00000000000000(load (concatenate 'string si::*system-directory* "../cmpnew/gcl_collectfn")) (compiler::emit-fn t) gcl27-2.7.0/cmpnew/gcl_make_ufun.lsp000077500000000000000000000062641454061450500172650ustar00rootroot00000000000000;;; 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 'character :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))))) ) gcl27-2.7.0/cmpnew/gcl_nocmpinc.lsp000077500000000000000000000007101454061450500171070ustar00rootroot00000000000000 (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)))) gcl27-2.7.0/cmpnew/makefile000066400000000000000000000035471454061450500154440ustar00rootroot00000000000000 .SUFFIXES: .SUFFIXES: .o .c .lsp .lisp .fn -include ../makedefs PORTDIR = ../unixport CAT=cat APPEND=../xbin/append PREFS:= cmpbind cmpblock cmpcall cmpcatch cmpenv cmpeval \ cmpflet cmpfun cmpif cmpinline cmplabel cmplam cmplet \ cmploc cmpmap cmpmulti cmpspecial cmptag cmptop \ cmptype cmputil cmpvar cmpvs cmpwt cmpmain FNS:= $(OBJS:.o=.fn) LISP:=$(shell ls -1rt ../unixport/saved_pre_gcl ../unixport/saved_gcl|tail -n 1) COMPILE_FILE=$(LISP) $(PORTDIR) $(LISPFLAGS) -system-p -c-file -data-file -h-file -compile #CFLAGS = -c -O -I../h all: $(OBJS) gprof_objs: $(addprefix ../gprof/gcl_,$(addsuffix .o,$(PREFS))) ../gprof/%.o: %.c #$(DECL) $(CC) -I../h -c $(filter-out -fomit-frame-pointer,$(CFLAGS)) $(DEFS) -pg $*.c $(AUX_INFO) -o $@ ${APPEND} ${NULLFILE} $*.data $@ %.o: %.lsp $(LISP) $(COMPILE_FILE) $< .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_gcl $(PORTDIR)/ $(LISPFLAGS) -compile $*.lsp .lisp.o: @ ../xbin/if-exists $(PORTDIR)/saved_pre_gcl \ "$(PORTDIR)/saved_pre_gcl $(PORTDIR)/ $(LISPFLAGS) -compile $*.lisp " sys-proclaim.lisp: $(FNS) echo '(in-package "COMPILER")' \ '(load "../cmpnew/gcl_collectfn")(load "../lsp/sys-proclaim.lisp")'\ '(compiler::make-all-proclaims "*.fn")' | ../unixport/saved_pre_gcl $(LISPFLAGS) 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 gcl27-2.7.0/cmpnew/so_locations000077500000000000000000000001751454061450500163600ustar00rootroot00000000000000collectfn.o \ :st = .text 0x000000005ffe0000, 0x0000000000010000:\ :st = .data 0x000000005fff0000, 0x0000000000010000:\ gcl27-2.7.0/cmpnew/sys-proclaim.lisp000066400000000000000000000000001454061450500172340ustar00rootroot00000000000000gcl27-2.7.0/comp/000077500000000000000000000000001454061450500134005ustar00rootroot00000000000000gcl27-2.7.0/comp/bo1.lsp000077500000000000000000000104461454061450500146110ustar00rootroot00000000000000(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: gcl27-2.7.0/comp/c-pass1.lsp000077500000000000000000000035261454061450500154000ustar00rootroot00000000000000(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)) gcl27-2.7.0/comp/cmpinit.lsp000077500000000000000000000011601454061450500155640ustar00rootroot00000000000000 (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")) gcl27-2.7.0/comp/comptype.lsp000077500000000000000000000142401454061450500157640ustar00rootroot00000000000000(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) gcl27-2.7.0/comp/data.lsp000077500000000000000000000057161454061450500150450ustar00rootroot00000000000000 (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 |# gcl27-2.7.0/comp/defmacro.lsp000077500000000000000000000174771454061450500157230ustar00rootroot00000000000000(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) ) gcl27-2.7.0/comp/defs.lsp000077500000000000000000000064201454061450500150460ustar00rootroot00000000000000 (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 ) gcl27-2.7.0/comp/exit.lsp000077500000000000000000000021251454061450500150740ustar00rootroot00000000000000(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)")) gcl27-2.7.0/comp/fasdmacros.lsp000077500000000000000000000041351454061450500162500ustar00rootroot00000000000000(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)) gcl27-2.7.0/comp/inline.lsp000077500000000000000000000472241454061450500154120ustar00rootroot00000000000000(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)) gcl27-2.7.0/comp/integer.doc000077500000000000000000000022511454061450500155270ustar00rootroot00000000000000 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; ..}. gcl27-2.7.0/comp/lambda.lsp000077500000000000000000000020311454061450500153370ustar00rootroot00000000000000(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. |# gcl27-2.7.0/comp/lisp-decls.doc000077500000000000000000001120731454061450500161350ustar00rootroot00000000000000(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)) gcl27-2.7.0/comp/macros.lsp000077500000000000000000000042551454061450500154150ustar00rootroot00000000000000(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)) gcl27-2.7.0/comp/makefile000066400000000000000000000015501454061450500151010ustar00rootroot00000000000000 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 gcl27-2.7.0/comp/mangle.lsp000077500000000000000000000074211454061450500153720ustar00rootroot00000000000000(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)))) gcl27-2.7.0/comp/opts-base.lsp000077500000000000000000000023601454061450500160210ustar00rootroot00000000000000(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)")) gcl27-2.7.0/comp/opts.lsp000077500000000000000000000525271454061450500151230ustar00rootroot00000000000000(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")) gcl27-2.7.0/comp/proclaim.lsp000077500000000000000000000000251454061450500157260ustar00rootroot00000000000000(in-package "BCOMP") gcl27-2.7.0/comp/smash-oldcmp.lsp000077500000000000000000000004111454061450500165060ustar00rootroot00000000000000 (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 ")) gcl27-2.7.0/comp/stmt.lsp000077500000000000000000000300451454061450500151140ustar00rootroot00000000000000(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))) gcl27-2.7.0/comp/sysdef.lsp000077500000000000000000000012521454061450500154200ustar00rootroot00000000000000(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") gcl27-2.7.0/comp/top.lsp000077500000000000000000000047111454061450500147300ustar00rootroot00000000000000(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*)) )))) gcl27-2.7.0/comp/top1.lsp000077500000000000000000000064511454061450500150140ustar00rootroot00000000000000(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)) gcl27-2.7.0/comp/top2.lsp000077500000000000000000000771321454061450500150210ustar00rootroot00000000000000(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*))) gcl27-2.7.0/comp/try.lsp000077500000000000000000000013501454061450500147400ustar00rootroot00000000000000(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") ) gcl27-2.7.0/comp/try1.lsp000077500000000000000000000002451454061450500150230ustar00rootroot00000000000000(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) gcl27-2.7.0/comp/utils.lsp000077500000000000000000000113431454061450500152650ustar00rootroot00000000000000 (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) gcl27-2.7.0/comp/var.lsp000077500000000000000000001060451454061450500147210ustar00rootroot00000000000000;;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: gcl27-2.7.0/comp/wr.lsp000077500000000000000000000323661454061450500145650ustar00rootroot00000000000000(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)))gcl27-2.7.0/config.guess000077500000000000000000001405121454061450500147650ustar00rootroot00000000000000#! /bin/sh # Attempt to guess a canonical system name. # Copyright 1992-2022 Free Software Foundation, Inc. # shellcheck disable=SC2006,SC2268 # see below for rationale timestamp='2022-01-09' # 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; maintained since 2000 by Ben Elliston. # # You can get the latest version of this script from: # https://git.savannah.gnu.org/cgit/config.git/plain/config.guess # # Please send patches to . # The "shellcheck disable" line above the timestamp inhibits complaints # about features and limitations of the classic Bourne shell that were # superseded or lifted in POSIX. However, this script identifies a wide # variety of pre-POSIX systems that do not have POSIX shells at all, and # even some reasonably current systems (Solaris 10 as case-in-point) still # have a pre-POSIX /bin/sh. me=`echo "$0" | sed -e 's,.*/,,'` usage="\ Usage: $0 [OPTION] Output the configuration name of the system \`$me' is run on. Options: -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-2022 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 # Just in case it came from the environment. GUESS= # 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. tmp= # shellcheck disable=SC2172 trap 'test -z "$tmp" || rm -fr "$tmp"' 0 1 2 13 15 set_cc_for_build() { # prevent multiple calls if $tmp is already set test "$tmp" && return 0 : "${TMPDIR=/tmp}" # shellcheck disable=SC2039,SC3028 { 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" 2>/dev/null) ; } || { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir "$tmp" 2>/dev/null) && echo "Warning: creating insecure temp directory" >&2 ; } || { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } dummy=$tmp/dummy case ${CC_FOR_BUILD-},${HOST_CC-},${CC-} in ,,) echo "int x;" > "$dummy.c" for driver in cc gcc c89 c99 ; do if ($driver -c -o "$dummy.o" "$dummy.c") >/dev/null 2>&1 ; then CC_FOR_BUILD=$driver 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 } # 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 ; 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/*) LIBC=unknown set_cc_for_build cat <<-EOF > "$dummy.c" #include #if defined(__UCLIBC__) LIBC=uclibc #elif defined(__dietlibc__) LIBC=dietlibc #elif defined(__GLIBC__) LIBC=gnu #else #include /* First heuristic to detect musl libc. */ #ifdef __DEFINED_va_list LIBC=musl #endif #endif EOF cc_set_libc=`$CC_FOR_BUILD -E "$dummy.c" 2>/dev/null | grep '^LIBC' | sed 's, ,,g'` eval "$cc_set_libc" # Second heuristic to detect musl libc. if [ "$LIBC" = unknown ] && command -v ldd >/dev/null && ldd --version 2>&1 | grep -q ^musl; then LIBC=musl fi # If the system lacks a compiler, then just pick glibc. # We could probably try harder. if [ "$LIBC" = unknown ]; then LIBC=gnu fi ;; 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". UNAME_MACHINE_ARCH=`(uname -p 2>/dev/null || \ /sbin/sysctl -n hw.machine_arch 2>/dev/null || \ /usr/sbin/sysctl -n hw.machine_arch 2>/dev/null || \ echo unknown)` case $UNAME_MACHINE_ARCH in aarch64eb) machine=aarch64_be-unknown ;; armeb) machine=armeb-unknown ;; arm*) machine=arm-unknown ;; sh3el) machine=shl-unknown ;; sh3eb) machine=sh-unknown ;; sh5el) machine=sh5le-unknown ;; earmv*) arch=`echo "$UNAME_MACHINE_ARCH" | sed -e 's,^e\(armv[0-9]\).*$,\1,'` endian=`echo "$UNAME_MACHINE_ARCH" | sed -ne 's,^.*\(eb\)$,\1,p'` machine=${arch}${endian}-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) and ABI. case $UNAME_MACHINE_ARCH in earm*) os=netbsdelf ;; arm*|i386|m68k|ns32k|sh3*|sparc|vax) 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 # Determine ABI tags. case $UNAME_MACHINE_ARCH in earm*) expr='s/^earmv[0-9]/-eabi/;s/eb$//' abi=`echo "$UNAME_MACHINE_ARCH" | sed -e "$expr"` ;; 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/[-_].*//' | cut -d. -f1,2` ;; esac # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: # contains redundant information, the shorter form: # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. GUESS=$machine-${os}${release}${abi-} ;; *:Bitrig:*:*) UNAME_MACHINE_ARCH=`arch | sed 's/Bitrig.//'` GUESS=$UNAME_MACHINE_ARCH-unknown-bitrig$UNAME_RELEASE ;; *:OpenBSD:*:*) UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'` GUESS=$UNAME_MACHINE_ARCH-unknown-openbsd$UNAME_RELEASE ;; *:SecBSD:*:*) UNAME_MACHINE_ARCH=`arch | sed 's/SecBSD.//'` GUESS=$UNAME_MACHINE_ARCH-unknown-secbsd$UNAME_RELEASE ;; *:LibertyBSD:*:*) UNAME_MACHINE_ARCH=`arch | sed 's/^.*BSD\.//'` GUESS=$UNAME_MACHINE_ARCH-unknown-libertybsd$UNAME_RELEASE ;; *:MidnightBSD:*:*) GUESS=$UNAME_MACHINE-unknown-midnightbsd$UNAME_RELEASE ;; *:ekkoBSD:*:*) GUESS=$UNAME_MACHINE-unknown-ekkobsd$UNAME_RELEASE ;; *:SolidBSD:*:*) GUESS=$UNAME_MACHINE-unknown-solidbsd$UNAME_RELEASE ;; *:OS108:*:*) GUESS=$UNAME_MACHINE-unknown-os108_$UNAME_RELEASE ;; macppc:MirBSD:*:*) GUESS=powerpc-unknown-mirbsd$UNAME_RELEASE ;; *:MirBSD:*:*) GUESS=$UNAME_MACHINE-unknown-mirbsd$UNAME_RELEASE ;; *:Sortix:*:*) GUESS=$UNAME_MACHINE-unknown-sortix ;; *:Twizzler:*:*) GUESS=$UNAME_MACHINE-unknown-twizzler ;; *:Redox:*:*) GUESS=$UNAME_MACHINE-unknown-redox ;; mips:OSF1:*.*) GUESS=mips-dec-osf1 ;; alpha:OSF1:*:*) # Reset EXIT trap before exiting to avoid spurious non-zero exit code. trap '' 0 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. OSF_REL=`echo "$UNAME_RELEASE" | sed -e 's/^[PVTX]//' | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz` GUESS=$UNAME_MACHINE-dec-osf$OSF_REL ;; Amiga*:UNIX_System_V:4.0:*) GUESS=m68k-unknown-sysv4 ;; *:[Aa]miga[Oo][Ss]:*:*) GUESS=$UNAME_MACHINE-unknown-amigaos ;; *:[Mm]orph[Oo][Ss]:*:*) GUESS=$UNAME_MACHINE-unknown-morphos ;; *:OS/390:*:*) GUESS=i370-ibm-openedition ;; *:z/VM:*:*) GUESS=s390-ibm-zvmoe ;; *:OS400:*:*) GUESS=powerpc-ibm-os400 ;; arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) GUESS=arm-acorn-riscix$UNAME_RELEASE ;; arm*:riscos:*:*|arm*:RISCOS:*:*) GUESS=arm-unknown-riscos ;; SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) GUESS=hppa1.1-hitachi-hiuxmpp ;; Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. case `(/bin/universe) 2>/dev/null` in att) GUESS=pyramid-pyramid-sysv3 ;; *) GUESS=pyramid-pyramid-bsd ;; esac ;; NILE*:*:*:dcosx) GUESS=pyramid-pyramid-svr4 ;; DRS?6000:unix:4.0:6*) GUESS=sparc-icl-nx6 ;; DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*) case `/usr/bin/uname -p` in sparc) GUESS=sparc-icl-nx7 ;; esac ;; s390x:SunOS:*:*) SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'` GUESS=$UNAME_MACHINE-ibm-solaris2$SUN_REL ;; sun4H:SunOS:5.*:*) SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'` GUESS=sparc-hal-solaris2$SUN_REL ;; sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'` GUESS=sparc-sun-solaris2$SUN_REL ;; i86pc:AuroraUX:5.*:* | i86xen:AuroraUX:5.*:*) GUESS=i386-pc-auroraux$UNAME_RELEASE ;; i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*) 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 test "$CC_FOR_BUILD" != no_compiler_found; then if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \ (CCOPTS="" $CC_FOR_BUILD -m64 -E - 2>/dev/null) | \ grep IS_64BIT_ARCH >/dev/null then SUN_ARCH=x86_64 fi fi SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'` GUESS=$SUN_ARCH-pc-solaris2$SUN_REL ;; 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. SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'` GUESS=sparc-sun-solaris3$SUN_REL ;; 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'. SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/-/_/'` GUESS=sparc-sun-sunos$SUN_REL ;; sun3*:SunOS:*:*) GUESS=m68k-sun-sunos$UNAME_RELEASE ;; 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) GUESS=m68k-sun-sunos$UNAME_RELEASE ;; sun4) GUESS=sparc-sun-sunos$UNAME_RELEASE ;; esac ;; aushp:SunOS:*:*) GUESS=sparc-auspex-sunos$UNAME_RELEASE ;; # 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:*:*) GUESS=m68k-atari-mint$UNAME_RELEASE ;; atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) GUESS=m68k-atari-mint$UNAME_RELEASE ;; *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) GUESS=m68k-atari-mint$UNAME_RELEASE ;; milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) GUESS=m68k-milan-mint$UNAME_RELEASE ;; hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) GUESS=m68k-hades-mint$UNAME_RELEASE ;; *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) GUESS=m68k-unknown-mint$UNAME_RELEASE ;; m68k:machten:*:*) GUESS=m68k-apple-machten$UNAME_RELEASE ;; powerpc:machten:*:*) GUESS=powerpc-apple-machten$UNAME_RELEASE ;; RISC*:Mach:*:*) GUESS=mips-dec-mach_bsd4.3 ;; RISC*:ULTRIX:*:*) GUESS=mips-dec-ultrix$UNAME_RELEASE ;; VAX*:ULTRIX*:*:*) GUESS=vax-dec-ultrix$UNAME_RELEASE ;; 2020:CLIX:*:* | 2430:CLIX:*:*) GUESS=clipper-intergraph-clix$UNAME_RELEASE ;; mips:*:*:UMIPS | mips:*:*:RISCos) 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; } GUESS=mips-mips-riscos$UNAME_RELEASE ;; Motorola:PowerMAX_OS:*:*) GUESS=powerpc-motorola-powermax ;; Motorola:*:4.3:PL8-*) GUESS=powerpc-harris-powermax ;; Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*) GUESS=powerpc-harris-powermax ;; Night_Hawk:Power_UNIX:*:*) GUESS=powerpc-harris-powerunix ;; m88k:CX/UX:7*:*) GUESS=m88k-harris-cxux7 ;; m88k:*:4*:R4*) GUESS=m88k-motorola-sysv4 ;; m88k:*:3*:R3*) GUESS=m88k-motorola-sysv3 ;; AViiON:dgux:*:*) # DG/UX returns AViiON for all architectures UNAME_PROCESSOR=`/usr/bin/uname -p` if test "$UNAME_PROCESSOR" = mc88100 || test "$UNAME_PROCESSOR" = mc88110 then if test "$TARGET_BINARY_INTERFACE"x = m88kdguxelfx || \ test "$TARGET_BINARY_INTERFACE"x = x then GUESS=m88k-dg-dgux$UNAME_RELEASE else GUESS=m88k-dg-dguxbcs$UNAME_RELEASE fi else GUESS=i586-dg-dgux$UNAME_RELEASE fi ;; M88*:DolphinOS:*:*) # DolphinOS (SVR3) GUESS=m88k-dolphin-sysv3 ;; M88*:*:R3*:*) # Delta 88k system running SVR3 GUESS=m88k-motorola-sysv3 ;; XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) GUESS=m88k-tektronix-sysv3 ;; Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) GUESS=m68k-tektronix-bsd ;; *:IRIX*:*:*) IRIX_REL=`echo "$UNAME_RELEASE" | sed -e 's/-/_/g'` GUESS=mips-sgi-irix$IRIX_REL ;; ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. GUESS=romp-ibm-aix # uname -m gives an 8 hex-code CPU id ;; # Note that: echo "'`uname -s`'" gives 'AIX ' i*86:AIX:*:*) GUESS=i386-ibm-aix ;; ia64:AIX:*:*) if test -x /usr/bin/oslevel ; then IBM_REV=`/usr/bin/oslevel` else IBM_REV=$UNAME_VERSION.$UNAME_RELEASE fi GUESS=$UNAME_MACHINE-ibm-aix$IBM_REV ;; *:AIX:2:3) if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then 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 GUESS=$SYSTEM_NAME else GUESS=rs6000-ibm-aix3.2.5 fi elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then GUESS=rs6000-ibm-aix3.2.4 else GUESS=rs6000-ibm-aix3.2 fi ;; *: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 test -x /usr/bin/lslpp ; then IBM_REV=`/usr/bin/lslpp -Lqc bos.rte.libc | \ awk -F: '{ print $3 }' | sed s/[0-9]*$/0/` else IBM_REV=$UNAME_VERSION.$UNAME_RELEASE fi GUESS=$IBM_ARCH-ibm-aix$IBM_REV ;; *:AIX:*:*) GUESS=rs6000-ibm-aix ;; ibmrt:4.4BSD:*|romp-ibm:4.4BSD:*) GUESS=romp-ibm-bsd4.4 ;; ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and GUESS=romp-ibm-bsd$UNAME_RELEASE # 4.3 with uname added to ;; # report: romp-ibm BSD 4.3 *:BOSX:*:*) GUESS=rs6000-bull-bosx ;; DPX/2?00:B.O.S.:*:*) GUESS=m68k-bull-sysv3 ;; 9000/[34]??:4.3bsd:1.*:*) GUESS=m68k-hp-bsd ;; hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) GUESS=m68k-hp-bsd4.4 ;; 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 test -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 test "$HP_ARCH" = ""; then 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 test "$HP_ARCH" = hppa2.0w then 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 GUESS=$HP_ARCH-hp-hpux$HPUX_REV ;; ia64:HP-UX:*:*) HPUX_REV=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*.[0B]*//'` GUESS=ia64-hp-hpux$HPUX_REV ;; 3050*:HI-UX:*:*) 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; } GUESS=unknown-hitachi-hiuxwe2 ;; 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:*) GUESS=hppa1.1-hp-bsd ;; 9000/8??:4.3bsd:*:*) GUESS=hppa1.0-hp-bsd ;; *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) GUESS=hppa1.0-hp-mpeix ;; hp7??:OSF1:*:* | hp8?[79]:OSF1:*:*) GUESS=hppa1.1-hp-osf ;; hp8??:OSF1:*:*) GUESS=hppa1.0-hp-osf ;; i*86:OSF1:*:*) if test -x /usr/sbin/sysversion ; then GUESS=$UNAME_MACHINE-unknown-osf1mk else GUESS=$UNAME_MACHINE-unknown-osf1 fi ;; parisc*:Lites*:*:*) GUESS=hppa1.1-hp-lites ;; C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) GUESS=c1-convex-bsd ;; 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*:*) GUESS=c34-convex-bsd ;; C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) GUESS=c38-convex-bsd ;; C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) GUESS=c4-convex-bsd ;; CRAY*Y-MP:*:*:*) CRAY_REL=`echo "$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/'` GUESS=ymp-cray-unicos$CRAY_REL ;; 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:*:*:*) CRAY_REL=`echo "$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/'` GUESS=t90-cray-unicos$CRAY_REL ;; CRAY*T3E:*:*:*) CRAY_REL=`echo "$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/'` GUESS=alphaev5-cray-unicosmk$CRAY_REL ;; CRAY*SV1:*:*:*) CRAY_REL=`echo "$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/'` GUESS=sv1-cray-unicos$CRAY_REL ;; *:UNICOS/mp:*:*) CRAY_REL=`echo "$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/'` GUESS=craynv-cray-unicosmp$CRAY_REL ;; 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/ /_/'` GUESS=${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL} ;; 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/ /_/'` GUESS=sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL} ;; i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) GUESS=$UNAME_MACHINE-pc-bsdi$UNAME_RELEASE ;; sparc*:BSD/OS:*:*) GUESS=sparc-unknown-bsdi$UNAME_RELEASE ;; *:BSD/OS:*:*) GUESS=$UNAME_MACHINE-unknown-bsdi$UNAME_RELEASE ;; arm:FreeBSD:*:*) UNAME_PROCESSOR=`uname -p` set_cc_for_build if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ARM_PCS_VFP then FREEBSD_REL=`echo "$UNAME_RELEASE" | sed -e 's/[-(].*//'` GUESS=$UNAME_PROCESSOR-unknown-freebsd$FREEBSD_REL-gnueabi else FREEBSD_REL=`echo "$UNAME_RELEASE" | sed -e 's/[-(].*//'` GUESS=$UNAME_PROCESSOR-unknown-freebsd$FREEBSD_REL-gnueabihf fi ;; *:FreeBSD:*:*) UNAME_PROCESSOR=`/usr/bin/uname -p` case $UNAME_PROCESSOR in amd64) UNAME_PROCESSOR=x86_64 ;; i386) UNAME_PROCESSOR=i586 ;; esac FREEBSD_REL=`echo "$UNAME_RELEASE" | sed -e 's/[-(].*//'` GUESS=$UNAME_PROCESSOR-unknown-freebsd$FREEBSD_REL ;; i*:CYGWIN*:*) GUESS=$UNAME_MACHINE-pc-cygwin ;; *:MINGW64*:*) GUESS=$UNAME_MACHINE-pc-mingw64 ;; *:MINGW*:*) GUESS=$UNAME_MACHINE-pc-mingw32 ;; *:MSYS*:*) GUESS=$UNAME_MACHINE-pc-msys ;; i*:PW*:*) GUESS=$UNAME_MACHINE-pc-pw32 ;; *:SerenityOS:*:*) GUESS=$UNAME_MACHINE-pc-serenity ;; *:Interix*:*) case $UNAME_MACHINE in x86) GUESS=i586-pc-interix$UNAME_RELEASE ;; authenticamd | genuineintel | EM64T) GUESS=x86_64-unknown-interix$UNAME_RELEASE ;; IA64) GUESS=ia64-unknown-interix$UNAME_RELEASE ;; esac ;; i*:UWIN*:*) GUESS=$UNAME_MACHINE-pc-uwin ;; amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*) GUESS=x86_64-pc-cygwin ;; prep*:SunOS:5.*:*) SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'` GUESS=powerpcle-unknown-solaris2$SUN_REL ;; *:GNU:*:*) # the GNU system GNU_ARCH=`echo "$UNAME_MACHINE" | sed -e 's,[-/].*$,,'` GNU_REL=`echo "$UNAME_RELEASE" | sed -e 's,/.*$,,'` GUESS=$GNU_ARCH-unknown-$LIBC$GNU_REL ;; *:GNU/*:*:*) # other systems with GNU libc and userland GNU_SYS=`echo "$UNAME_SYSTEM" | sed 's,^[^/]*/,,' | tr "[:upper:]" "[:lower:]"` GNU_REL=`echo "$UNAME_RELEASE" | sed -e 's/[-(].*//'` GUESS=$UNAME_MACHINE-unknown-$GNU_SYS$GNU_REL-$LIBC ;; *:Minix:*:*) GUESS=$UNAME_MACHINE-unknown-minix ;; aarch64:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; aarch64_be:Linux:*:*) UNAME_MACHINE=aarch64_be GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; alpha:Linux:*:*) case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' /proc/cpuinfo 2>/dev/null` 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 GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; arc:Linux:*:* | arceb:Linux:*:* | arc32:Linux:*:* | arc64:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; arm*:Linux:*:*) set_cc_for_build if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ARM_EABI__ then GUESS=$UNAME_MACHINE-unknown-linux-$LIBC else if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ARM_PCS_VFP then GUESS=$UNAME_MACHINE-unknown-linux-${LIBC}eabi else GUESS=$UNAME_MACHINE-unknown-linux-${LIBC}eabihf fi fi ;; avr32*:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; cris:Linux:*:*) GUESS=$UNAME_MACHINE-axis-linux-$LIBC ;; crisv32:Linux:*:*) GUESS=$UNAME_MACHINE-axis-linux-$LIBC ;; e2k:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; frv:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; hexagon:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; i*86:Linux:*:*) GUESS=$UNAME_MACHINE-pc-linux-$LIBC ;; ia64:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; k1om:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; loongarch32:Linux:*:* | loongarch64:Linux:*:* | loongarchx32:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; m32r*:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; m68*:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; mips:Linux:*:* | mips64:Linux:*:*) set_cc_for_build IS_GLIBC=0 test x"${LIBC}" = xgnu && IS_GLIBC=1 sed 's/^ //' << EOF > "$dummy.c" #undef CPU #undef mips #undef mipsel #undef mips64 #undef mips64el #if ${IS_GLIBC} && defined(_ABI64) LIBCABI=gnuabi64 #else #if ${IS_GLIBC} && defined(_ABIN32) LIBCABI=gnuabin32 #else LIBCABI=${LIBC} #endif #endif #if ${IS_GLIBC} && defined(__mips64) && defined(__mips_isa_rev) && __mips_isa_rev>=6 CPU=mipsisa64r6 #else #if ${IS_GLIBC} && !defined(__mips64) && defined(__mips_isa_rev) && __mips_isa_rev>=6 CPU=mipsisa32r6 #else #if defined(__mips64) CPU=mips64 #else CPU=mips #endif #endif #endif #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) MIPS_ENDIAN=el #else #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) MIPS_ENDIAN= #else MIPS_ENDIAN= #endif #endif EOF cc_set_vars=`$CC_FOR_BUILD -E "$dummy.c" 2>/dev/null | grep '^CPU\|^MIPS_ENDIAN\|^LIBCABI'` eval "$cc_set_vars" test "x$CPU" != x && { echo "$CPU${MIPS_ENDIAN}-unknown-linux-$LIBCABI"; exit; } ;; mips64el:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; openrisc*:Linux:*:*) GUESS=or1k-unknown-linux-$LIBC ;; or32:Linux:*:* | or1k*:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; padre:Linux:*:*) GUESS=sparc-unknown-linux-$LIBC ;; parisc64:Linux:*:* | hppa64:Linux:*:*) GUESS=hppa64-unknown-linux-$LIBC ;; parisc:Linux:*:* | hppa:Linux:*:*) # Look for CPU level case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in PA7*) GUESS=hppa1.1-unknown-linux-$LIBC ;; PA8*) GUESS=hppa2.0-unknown-linux-$LIBC ;; *) GUESS=hppa-unknown-linux-$LIBC ;; esac ;; ppc64:Linux:*:*) GUESS=powerpc64-unknown-linux-$LIBC ;; ppc:Linux:*:*) GUESS=powerpc-unknown-linux-$LIBC ;; ppc64le:Linux:*:*) GUESS=powerpc64le-unknown-linux-$LIBC ;; ppcle:Linux:*:*) GUESS=powerpcle-unknown-linux-$LIBC ;; riscv32:Linux:*:* | riscv32be:Linux:*:* | riscv64:Linux:*:* | riscv64be:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; s390:Linux:*:* | s390x:Linux:*:*) GUESS=$UNAME_MACHINE-ibm-linux-$LIBC ;; sh64*:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; sh*:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; sparc:Linux:*:* | sparc64:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; tile*:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; vax:Linux:*:*) GUESS=$UNAME_MACHINE-dec-linux-$LIBC ;; x86_64:Linux:*:*) set_cc_for_build LIBCABI=$LIBC if test "$CC_FOR_BUILD" != no_compiler_found; then if (echo '#ifdef __ILP32__'; echo IS_X32; echo '#endif') | \ (CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \ grep IS_X32 >/dev/null then LIBCABI=${LIBC}x32 fi fi GUESS=$UNAME_MACHINE-pc-linux-$LIBCABI ;; xtensa*:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; 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. GUESS=i386-sequent-sysv4 ;; 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. GUESS=$UNAME_MACHINE-pc-sysv4.2uw$UNAME_VERSION ;; i*86:OS/2:*:*) # If we were able to find `uname', then EMX Unix compatibility # is probably installed. GUESS=$UNAME_MACHINE-pc-os2-emx ;; i*86:XTS-300:*:STOP) GUESS=$UNAME_MACHINE-unknown-stop ;; i*86:atheos:*:*) GUESS=$UNAME_MACHINE-unknown-atheos ;; i*86:syllable:*:*) GUESS=$UNAME_MACHINE-pc-syllable ;; i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.[02]*:*) GUESS=i386-unknown-lynxos$UNAME_RELEASE ;; i*86:*DOS:*:*) GUESS=$UNAME_MACHINE-pc-msdosdjgpp ;; i*86:*:4.*:*) UNAME_REL=`echo "$UNAME_RELEASE" | sed 's/\/MP$//'` if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then GUESS=$UNAME_MACHINE-univel-sysv$UNAME_REL else GUESS=$UNAME_MACHINE-pc-sysv$UNAME_REL fi ;; 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 GUESS=$UNAME_MACHINE-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} ;; 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 GUESS=$UNAME_MACHINE-pc-sco$UNAME_REL else GUESS=$UNAME_MACHINE-pc-sysv32 fi ;; 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 configure will decide that # this is a cross-build. GUESS=i586-pc-msdosdjgpp ;; Intel:Mach:3*:*) GUESS=i386-pc-mach3 ;; paragon:*:*:*) GUESS=i860-intel-osf1 ;; i860:*:4.*:*) # i860-SVR4 if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then GUESS=i860-stardent-sysv$UNAME_RELEASE # Stardent Vistra i860-SVR4 else # Add other i860-SVR4 vendors below as they are discovered. GUESS=i860-unknown-sysv$UNAME_RELEASE # Unknown i860-SVR4 fi ;; mini*:CTIX:SYS*5:*) # "miniframe" GUESS=m68010-convergent-sysv ;; mc68k:UNIX:SYSTEM5:3.51m) GUESS=m68k-convergent-sysv ;; M680?0:D-NIX:5.3:*) GUESS=m68k-diab-dnix ;; 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*:*) GUESS=m68k-unknown-lynxos$UNAME_RELEASE ;; mc68030:UNIX_System_V:4.*:*) GUESS=m68k-atari-sysv4 ;; TSUNAMI:LynxOS:2.*:*) GUESS=sparc-unknown-lynxos$UNAME_RELEASE ;; rs6000:LynxOS:2.*:*) GUESS=rs6000-unknown-lynxos$UNAME_RELEASE ;; PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.[02]*:*) GUESS=powerpc-unknown-lynxos$UNAME_RELEASE ;; SM[BE]S:UNIX_SV:*:*) GUESS=mips-dde-sysv$UNAME_RELEASE ;; RM*:ReliantUNIX-*:*:*) GUESS=mips-sni-sysv4 ;; RM*:SINIX-*:*:*) GUESS=mips-sni-sysv4 ;; *:SINIX-*:*:*) if uname -p 2>/dev/null >/dev/null ; then UNAME_MACHINE=`(uname -p) 2>/dev/null` GUESS=$UNAME_MACHINE-sni-sysv4 else GUESS=ns32k-sni-sysv fi ;; PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort # says GUESS=i586-unisys-sysv4 ;; *:UNIX_System_V:4*:FTX*) # From Gerald Hewes . # How about differentiating between stratus architectures? -djm GUESS=hppa1.1-stratus-sysv4 ;; *:*:*:FTX*) # From seanf@swdc.stratus.com. GUESS=i860-stratus-sysv4 ;; i*86:VOS:*:*) # From Paul.Green@stratus.com. GUESS=$UNAME_MACHINE-stratus-vos ;; *:VOS:*:*) # From Paul.Green@stratus.com. GUESS=hppa1.1-stratus-vos ;; mc68*:A/UX:*:*) GUESS=m68k-apple-aux$UNAME_RELEASE ;; news*:NEWS-OS:6*:*) GUESS=mips-sony-newsos6 ;; R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) if test -d /usr/nec; then GUESS=mips-nec-sysv$UNAME_RELEASE else GUESS=mips-unknown-sysv$UNAME_RELEASE fi ;; BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. GUESS=powerpc-be-beos ;; BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. GUESS=powerpc-apple-beos ;; BePC:BeOS:*:*) # BeOS running on Intel PC compatible. GUESS=i586-pc-beos ;; BePC:Haiku:*:*) # Haiku running on Intel PC compatible. GUESS=i586-pc-haiku ;; x86_64:Haiku:*:*) GUESS=x86_64-unknown-haiku ;; SX-4:SUPER-UX:*:*) GUESS=sx4-nec-superux$UNAME_RELEASE ;; SX-5:SUPER-UX:*:*) GUESS=sx5-nec-superux$UNAME_RELEASE ;; SX-6:SUPER-UX:*:*) GUESS=sx6-nec-superux$UNAME_RELEASE ;; SX-7:SUPER-UX:*:*) GUESS=sx7-nec-superux$UNAME_RELEASE ;; SX-8:SUPER-UX:*:*) GUESS=sx8-nec-superux$UNAME_RELEASE ;; SX-8R:SUPER-UX:*:*) GUESS=sx8r-nec-superux$UNAME_RELEASE ;; SX-ACE:SUPER-UX:*:*) GUESS=sxace-nec-superux$UNAME_RELEASE ;; Power*:Rhapsody:*:*) GUESS=powerpc-apple-rhapsody$UNAME_RELEASE ;; *:Rhapsody:*:*) GUESS=$UNAME_MACHINE-apple-rhapsody$UNAME_RELEASE ;; arm64:Darwin:*:*) GUESS=aarch64-apple-darwin$UNAME_RELEASE ;; *:Darwin:*:*) UNAME_PROCESSOR=`uname -p` case $UNAME_PROCESSOR in unknown) UNAME_PROCESSOR=powerpc ;; esac if command -v xcode-select > /dev/null 2> /dev/null && \ ! xcode-select --print-path > /dev/null 2> /dev/null ; then # Avoid executing cc if there is no toolchain installed as # cc will be a stub that puts up a graphical alert # prompting the user to install developer tools. CC_FOR_BUILD=no_compiler_found else set_cc_for_build fi if test "$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 # On 10.4-10.6 one might compile for PowerPC via gcc -arch ppc if (echo '#ifdef __POWERPC__'; echo IS_PPC; echo '#endif') | \ (CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \ grep IS_PPC >/dev/null then UNAME_PROCESSOR=powerpc fi elif test "$UNAME_PROCESSOR" = i386 ; then # uname -m returns i386 or x86_64 UNAME_PROCESSOR=$UNAME_MACHINE fi GUESS=$UNAME_PROCESSOR-apple-darwin$UNAME_RELEASE ;; *:procnto*:*:* | *:QNX:[0123456789]*:*) UNAME_PROCESSOR=`uname -p` if test "$UNAME_PROCESSOR" = x86; then UNAME_PROCESSOR=i386 UNAME_MACHINE=pc fi GUESS=$UNAME_PROCESSOR-$UNAME_MACHINE-nto-qnx$UNAME_RELEASE ;; *:QNX:*:4*) GUESS=i386-pc-qnx ;; NEO-*:NONSTOP_KERNEL:*:*) GUESS=neo-tandem-nsk$UNAME_RELEASE ;; NSE-*:NONSTOP_KERNEL:*:*) GUESS=nse-tandem-nsk$UNAME_RELEASE ;; NSR-*:NONSTOP_KERNEL:*:*) GUESS=nsr-tandem-nsk$UNAME_RELEASE ;; NSV-*:NONSTOP_KERNEL:*:*) GUESS=nsv-tandem-nsk$UNAME_RELEASE ;; NSX-*:NONSTOP_KERNEL:*:*) GUESS=nsx-tandem-nsk$UNAME_RELEASE ;; *:NonStop-UX:*:*) GUESS=mips-compaq-nonstopux ;; BS2000:POSIX*:*:*) GUESS=bs2000-siemens-sysv ;; DS/*:UNIX_System_V:*:*) GUESS=$UNAME_MACHINE-$UNAME_SYSTEM-$UNAME_RELEASE ;; *: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 elif test "x${cputype-}" != x; then UNAME_MACHINE=$cputype fi GUESS=$UNAME_MACHINE-unknown-plan9 ;; *:TOPS-10:*:*) GUESS=pdp10-unknown-tops10 ;; *:TENEX:*:*) GUESS=pdp10-unknown-tenex ;; KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) GUESS=pdp10-dec-tops20 ;; XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) GUESS=pdp10-xkl-tops20 ;; *:TOPS-20:*:*) GUESS=pdp10-unknown-tops20 ;; *:ITS:*:*) GUESS=pdp10-unknown-its ;; SEI:*:*:SEIUX) GUESS=mips-sei-seiux$UNAME_RELEASE ;; *:DragonFly:*:*) DRAGONFLY_REL=`echo "$UNAME_RELEASE" | sed -e 's/[-(].*//'` GUESS=$UNAME_MACHINE-unknown-dragonfly$DRAGONFLY_REL ;; *:*VMS:*:*) UNAME_MACHINE=`(uname -p) 2>/dev/null` case $UNAME_MACHINE in A*) GUESS=alpha-dec-vms ;; I*) GUESS=ia64-dec-vms ;; V*) GUESS=vax-dec-vms ;; esac ;; *:XENIX:*:SysV) GUESS=i386-pc-xenix ;; i*86:skyos:*:*) SKYOS_REL=`echo "$UNAME_RELEASE" | sed -e 's/ .*$//'` GUESS=$UNAME_MACHINE-pc-skyos$SKYOS_REL ;; i*86:rdos:*:*) GUESS=$UNAME_MACHINE-pc-rdos ;; i*86:Fiwix:*:*) GUESS=$UNAME_MACHINE-pc-fiwix ;; *:AROS:*:*) GUESS=$UNAME_MACHINE-unknown-aros ;; x86_64:VMkernel:*:*) GUESS=$UNAME_MACHINE-unknown-esx ;; amd64:Isilon\ OneFS:*:*) GUESS=x86_64-unknown-onefs ;; *:Unleashed:*:*) GUESS=$UNAME_MACHINE-unknown-unleashed$UNAME_RELEASE ;; esac # Do we have a guess based on uname results? if test "x$GUESS" != x; then echo "$GUESS" exit fi # No uname command or uname output not recognized. set_cc_for_build cat > "$dummy.c" < #include #endif #if defined(ultrix) || defined(_ultrix) || defined(__ultrix) || defined(__ultrix__) #if defined (vax) || defined (__vax) || defined (__vax__) || defined(mips) || defined(__mips) || defined(__mips__) || defined(MIPS) || defined(__MIPS__) #include #if defined(_SIZE_T_) || defined(SIGLOST) #include #endif #endif #endif main () { #if defined (sony) #if defined (MIPSEB) /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed, I don't know.... */ printf ("mips-sony-bsd\n"); exit (0); #else #include printf ("m68k-sony-newsos%s\n", #ifdef NEWSOS4 "4" #else "" #endif ); exit (0); #endif #endif #if defined (NeXT) #if !defined (__ARCHITECTURE__) #define __ARCHITECTURE__ "m68k" #endif int version; version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; if (version < 4) printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version); else printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version); exit (0); #endif #if defined (MULTIMAX) || defined (n16) #if defined (UMAXV) printf ("ns32k-encore-sysv\n"); exit (0); #else #if defined (CMU) printf ("ns32k-encore-mach\n"); exit (0); #else printf ("ns32k-encore-bsd\n"); exit (0); #endif #endif #endif #if defined (__386BSD__) printf ("i386-pc-bsd\n"); exit (0); #endif #if defined (sequent) #if defined (i386) printf ("i386-sequent-dynix\n"); exit (0); #endif #if defined (ns32000) printf ("ns32k-sequent-dynix\n"); exit (0); #endif #endif #if defined (_SEQUENT_) struct utsname un; uname(&un); if (strncmp(un.version, "V2", 2) == 0) { printf ("i386-sequent-ptx2\n"); exit (0); } if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */ printf ("i386-sequent-ptx1\n"); exit (0); } printf ("i386-sequent-ptx\n"); exit (0); #endif #if defined (vax) #if !defined (ultrix) #include #if defined (BSD) #if BSD == 43 printf ("vax-dec-bsd4.3\n"); exit (0); #else #if BSD == 199006 printf ("vax-dec-bsd4.3reno\n"); exit (0); #else printf ("vax-dec-bsd\n"); exit (0); #endif #endif #else printf ("vax-dec-bsd\n"); exit (0); #endif #else #if defined(_SIZE_T_) || defined(SIGLOST) struct utsname un; uname (&un); printf ("vax-dec-ultrix%s\n", un.release); exit (0); #else printf ("vax-dec-ultrix\n"); exit (0); #endif #endif #endif #if defined(ultrix) || defined(_ultrix) || defined(__ultrix) || defined(__ultrix__) #if defined(mips) || defined(__mips) || defined(__mips__) || defined(MIPS) || defined(__MIPS__) #if defined(_SIZE_T_) || defined(SIGLOST) struct utsname *un; uname (&un); printf ("mips-dec-ultrix%s\n", un.release); exit (0); #else printf ("mips-dec-ultrix\n"); exit (0); #endif #endif #endif #if defined (alliant) && defined (i860) printf ("i860-alliant-bsd\n"); exit (0); #endif exit (1); } EOF $CC_FOR_BUILD -o "$dummy" "$dummy.c" 2>/dev/null && SYSTEM_NAME=`"$dummy"` && { echo "$SYSTEM_NAME"; exit; } # Apollos put the system type in the environment. test -d /usr/apollo && { echo "$ISP-apollo-$SYSTYPE"; exit; } echo "$0: unable to guess system type" >&2 case $UNAME_MACHINE:$UNAME_SYSTEM in mips:Linux | mips64:Linux) # If we got here on MIPS GNU/Linux, output extra information. cat >&2 <&2 <&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 fi exit 1 # Local variables: # eval: (add-hook 'before-save-hook 'time-stamp) # time-stamp-start: "timestamp='" # time-stamp-format: "%:y-%02m-%02d" # time-stamp-end: "'" # End: gcl27-2.7.0/config.sub000077500000000000000000001051161454061450500144310ustar00rootroot00000000000000#! /bin/sh # Configuration validation subroutine script. # Copyright 1992-2022 Free Software Foundation, Inc. # shellcheck disable=SC2006,SC2268 # see below for rationale timestamp='2022-01-03' # 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 to . # # 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: # https://git.savannah.gnu.org/cgit/config.git/plain/config.sub # 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. # The "shellcheck disable" line above the timestamp inhibits complaints # about features and limitations of the classic Bourne shell that were # superseded or lifted in POSIX. However, this script identifies a wide # variety of pre-POSIX systems that do not have POSIX shells at all, and # even some reasonably current systems (Solaris 10 as case-in-point) still # have a pre-POSIX /bin/sh. me=`echo "$0" | sed -e 's,.*/,,'` usage="\ Usage: $0 [OPTION] CPU-MFR-OPSYS or ALIAS Canonicalize a configuration name. Options: -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-2022 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 ;; *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 # Split fields of configuration type # shellcheck disable=SC2162 saved_IFS=$IFS IFS="-" read field1 field2 field3 field4 <&2 exit 1 ;; *-*-*-*) basic_machine=$field1-$field2 basic_os=$field3-$field4 ;; *-*-*) # Ambiguous whether COMPANY is present, or skipped and KERNEL-OS is two # parts maybe_os=$field2-$field3 case $maybe_os in nto-qnx* | linux-* | uclinux-uclibc* \ | uclinux-gnu* | kfreebsd*-gnu* | knetbsd*-gnu* | netbsd*-gnu* \ | netbsd*-eabi* | kopensolaris*-gnu* | cloudabi*-eabi* \ | storm-chaos* | os2-emx* | rtmk-nova*) basic_machine=$field1 basic_os=$maybe_os ;; android-linux) basic_machine=$field1-unknown basic_os=linux-android ;; *) basic_machine=$field1-$field2 basic_os=$field3 ;; esac ;; *-*) # A lone config we happen to match not fitting any pattern case $field1-$field2 in decstation-3100) basic_machine=mips-dec basic_os= ;; *-*) # Second component is usually, but not always the OS case $field2 in # Prevent following clause from handling this valid os sun*os*) basic_machine=$field1 basic_os=$field2 ;; zephyr*) basic_machine=$field1-unknown basic_os=$field2 ;; # Manufacturers dec* | mips* | sequent* | encore* | pc533* | 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* | sim | cisco \ | oki | wec | wrs | winbond) basic_machine=$field1-$field2 basic_os= ;; *) basic_machine=$field1 basic_os=$field2 ;; esac ;; esac ;; *) # Convert single-component short-hands not valid as part of # multi-component configurations. case $field1 in 386bsd) basic_machine=i386-pc basic_os=bsd ;; a29khif) basic_machine=a29k-amd basic_os=udi ;; adobe68k) basic_machine=m68010-adobe basic_os=scout ;; alliant) basic_machine=fx80-alliant basic_os= ;; altos | altos3068) basic_machine=m68k-altos basic_os= ;; am29k) basic_machine=a29k-none basic_os=bsd ;; amdahl) basic_machine=580-amdahl basic_os=sysv ;; amiga) basic_machine=m68k-unknown basic_os= ;; amigaos | amigados) basic_machine=m68k-unknown basic_os=amigaos ;; amigaunix | amix) basic_machine=m68k-unknown basic_os=sysv4 ;; apollo68) basic_machine=m68k-apollo basic_os=sysv ;; apollo68bsd) basic_machine=m68k-apollo basic_os=bsd ;; aros) basic_machine=i386-pc basic_os=aros ;; aux) basic_machine=m68k-apple basic_os=aux ;; balance) basic_machine=ns32k-sequent basic_os=dynix ;; blackfin) basic_machine=bfin-unknown basic_os=linux ;; cegcc) basic_machine=arm-unknown basic_os=cegcc ;; convex-c1) basic_machine=c1-convex basic_os=bsd ;; convex-c2) basic_machine=c2-convex basic_os=bsd ;; convex-c32) basic_machine=c32-convex basic_os=bsd ;; convex-c34) basic_machine=c34-convex basic_os=bsd ;; convex-c38) basic_machine=c38-convex basic_os=bsd ;; cray) basic_machine=j90-cray basic_os=unicos ;; crds | unos) basic_machine=m68k-crds basic_os= ;; da30) basic_machine=m68k-da30 basic_os= ;; decstation | pmax | pmin | dec3100 | decstatn) basic_machine=mips-dec basic_os= ;; delta88) basic_machine=m88k-motorola basic_os=sysv3 ;; dicos) basic_machine=i686-pc basic_os=dicos ;; djgpp) basic_machine=i586-pc basic_os=msdosdjgpp ;; ebmon29k) basic_machine=a29k-amd basic_os=ebmon ;; es1800 | OSE68k | ose68k | ose | OSE) basic_machine=m68k-ericsson basic_os=ose ;; gmicro) basic_machine=tron-gmicro basic_os=sysv ;; go32) basic_machine=i386-pc basic_os=go32 ;; h8300hms) basic_machine=h8300-hitachi basic_os=hms ;; h8300xray) basic_machine=h8300-hitachi basic_os=xray ;; h8500hms) basic_machine=h8500-hitachi basic_os=hms ;; harris) basic_machine=m88k-harris basic_os=sysv3 ;; hp300 | hp300hpux) basic_machine=m68k-hp basic_os=hpux ;; hp300bsd) basic_machine=m68k-hp basic_os=bsd ;; hppaosf) basic_machine=hppa1.1-hp basic_os=osf ;; hppro) basic_machine=hppa1.1-hp basic_os=proelf ;; i386mach) basic_machine=i386-mach basic_os=mach ;; isi68 | isi) basic_machine=m68k-isi basic_os=sysv ;; m68knommu) basic_machine=m68k-unknown basic_os=linux ;; magnum | m3230) basic_machine=mips-mips basic_os=sysv ;; merlin) basic_machine=ns32k-utek basic_os=sysv ;; mingw64) basic_machine=x86_64-pc basic_os=mingw64 ;; mingw32) basic_machine=i686-pc basic_os=mingw32 ;; mingw32ce) basic_machine=arm-unknown basic_os=mingw32ce ;; monitor) basic_machine=m68k-rom68k basic_os=coff ;; morphos) basic_machine=powerpc-unknown basic_os=morphos ;; moxiebox) basic_machine=moxie-unknown basic_os=moxiebox ;; msdos) basic_machine=i386-pc basic_os=msdos ;; msys) basic_machine=i686-pc basic_os=msys ;; mvs) basic_machine=i370-ibm basic_os=mvs ;; nacl) basic_machine=le32-unknown basic_os=nacl ;; ncr3000) basic_machine=i486-ncr basic_os=sysv4 ;; netbsd386) basic_machine=i386-pc basic_os=netbsd ;; netwinder) basic_machine=armv4l-rebel basic_os=linux ;; news | news700 | news800 | news900) basic_machine=m68k-sony basic_os=newsos ;; news1000) basic_machine=m68030-sony basic_os=newsos ;; necv70) basic_machine=v70-nec basic_os=sysv ;; nh3000) basic_machine=m68k-harris basic_os=cxux ;; nh[45]000) basic_machine=m88k-harris basic_os=cxux ;; nindy960) basic_machine=i960-intel basic_os=nindy ;; mon960) basic_machine=i960-intel basic_os=mon960 ;; nonstopux) basic_machine=mips-compaq basic_os=nonstopux ;; os400) basic_machine=powerpc-ibm basic_os=os400 ;; OSE68000 | ose68000) basic_machine=m68000-ericsson basic_os=ose ;; os68k) basic_machine=m68k-none basic_os=os68k ;; paragon) basic_machine=i860-intel basic_os=osf ;; parisc) basic_machine=hppa-unknown basic_os=linux ;; psp) basic_machine=mipsallegrexel-sony basic_os=psp ;; pw32) basic_machine=i586-unknown basic_os=pw32 ;; rdos | rdos64) basic_machine=x86_64-pc basic_os=rdos ;; rdos32) basic_machine=i386-pc basic_os=rdos ;; rom68k) basic_machine=m68k-rom68k basic_os=coff ;; sa29200) basic_machine=a29k-amd basic_os=udi ;; sei) basic_machine=mips-sei basic_os=seiux ;; sequent) basic_machine=i386-sequent basic_os= ;; sps7) basic_machine=m68k-bull basic_os=sysv2 ;; st2000) basic_machine=m68k-tandem basic_os= ;; stratus) basic_machine=i860-stratus basic_os=sysv4 ;; sun2) basic_machine=m68000-sun basic_os= ;; sun2os3) basic_machine=m68000-sun basic_os=sunos3 ;; sun2os4) basic_machine=m68000-sun basic_os=sunos4 ;; sun3) basic_machine=m68k-sun basic_os= ;; sun3os3) basic_machine=m68k-sun basic_os=sunos3 ;; sun3os4) basic_machine=m68k-sun basic_os=sunos4 ;; sun4) basic_machine=sparc-sun basic_os= ;; sun4os3) basic_machine=sparc-sun basic_os=sunos3 ;; sun4os4) basic_machine=sparc-sun basic_os=sunos4 ;; sun4sol2) basic_machine=sparc-sun basic_os=solaris2 ;; sun386 | sun386i | roadrunner) basic_machine=i386-sun basic_os= ;; sv1) basic_machine=sv1-cray basic_os=unicos ;; symmetry) basic_machine=i386-sequent basic_os=dynix ;; t3e) basic_machine=alphaev5-cray basic_os=unicos ;; t90) basic_machine=t90-cray basic_os=unicos ;; toad1) basic_machine=pdp10-xkl basic_os=tops20 ;; tpf) basic_machine=s390x-ibm basic_os=tpf ;; udi29k) basic_machine=a29k-amd basic_os=udi ;; ultra3) basic_machine=a29k-nyu basic_os=sym1 ;; v810 | necv810) basic_machine=v810-nec basic_os=none ;; vaxv) basic_machine=vax-dec basic_os=sysv ;; vms) basic_machine=vax-dec basic_os=vms ;; vsta) basic_machine=i386-pc basic_os=vsta ;; vxworks960) basic_machine=i960-wrs basic_os=vxworks ;; vxworks68) basic_machine=m68k-wrs basic_os=vxworks ;; vxworks29k) basic_machine=a29k-wrs basic_os=vxworks ;; xbox) basic_machine=i686-pc basic_os=mingw32 ;; ymp) basic_machine=ymp-cray basic_os=unicos ;; *) basic_machine=$1 basic_os= ;; esac ;; esac # Decode 1-component or ad-hoc basic machines case $basic_machine in # 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) cpu=hppa1.1 vendor=winbond ;; op50n) cpu=hppa1.1 vendor=oki ;; op60c) cpu=hppa1.1 vendor=oki ;; ibm*) cpu=i370 vendor=ibm ;; orion105) cpu=clipper vendor=highlevel ;; mac | mpw | mac-mpw) cpu=m68k vendor=apple ;; pmac | pmac-mpw) cpu=powerpc vendor=apple ;; # Recognize the various machine names and aliases which stand # for a CPU type and a company and sometimes even an OS. 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) cpu=m68000 vendor=att ;; 3b*) cpu=we32k vendor=att ;; bluegene*) cpu=powerpc vendor=ibm basic_os=cnk ;; decsystem10* | dec10*) cpu=pdp10 vendor=dec basic_os=tops10 ;; decsystem20* | dec20*) cpu=pdp10 vendor=dec basic_os=tops20 ;; delta | 3300 | motorola-3300 | motorola-delta \ | 3300-motorola | delta-motorola) cpu=m68k vendor=motorola ;; dpx2*) cpu=m68k vendor=bull basic_os=sysv3 ;; encore | umax | mmax) cpu=ns32k vendor=encore ;; elxsi) cpu=elxsi vendor=elxsi basic_os=${basic_os:-bsd} ;; fx2800) cpu=i860 vendor=alliant ;; genix) cpu=ns32k vendor=ns ;; h3050r* | hiux*) cpu=hppa1.1 vendor=hitachi basic_os=hiuxwe2 ;; hp3k9[0-9][0-9] | hp9[0-9][0-9]) cpu=hppa1.0 vendor=hp ;; hp9k2[0-9][0-9] | hp9k31[0-9]) cpu=m68000 vendor=hp ;; hp9k3[2-9][0-9]) cpu=m68k vendor=hp ;; hp9k6[0-9][0-9] | hp6[0-9][0-9]) cpu=hppa1.0 vendor=hp ;; hp9k7[0-79][0-9] | hp7[0-79][0-9]) cpu=hppa1.1 vendor=hp ;; hp9k78[0-9] | hp78[0-9]) # FIXME: really hppa2.0-hp cpu=hppa1.1 vendor=hp ;; hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) # FIXME: really hppa2.0-hp cpu=hppa1.1 vendor=hp ;; hp9k8[0-9][13679] | hp8[0-9][13679]) cpu=hppa1.1 vendor=hp ;; hp9k8[0-9][0-9] | hp8[0-9][0-9]) cpu=hppa1.0 vendor=hp ;; i*86v32) cpu=`echo "$1" | sed -e 's/86.*/86/'` vendor=pc basic_os=sysv32 ;; i*86v4*) cpu=`echo "$1" | sed -e 's/86.*/86/'` vendor=pc basic_os=sysv4 ;; i*86v) cpu=`echo "$1" | sed -e 's/86.*/86/'` vendor=pc basic_os=sysv ;; i*86sol2) cpu=`echo "$1" | sed -e 's/86.*/86/'` vendor=pc basic_os=solaris2 ;; j90 | j90-cray) cpu=j90 vendor=cray basic_os=${basic_os:-unicos} ;; iris | iris4d) cpu=mips vendor=sgi case $basic_os in irix*) ;; *) basic_os=irix4 ;; esac ;; miniframe) cpu=m68000 vendor=convergent ;; *mint | mint[0-9]* | *MiNT | *MiNT[0-9]*) cpu=m68k vendor=atari basic_os=mint ;; news-3600 | risc-news) cpu=mips vendor=sony basic_os=newsos ;; next | m*-next) cpu=m68k vendor=next case $basic_os in openstep*) ;; nextstep*) ;; ns2*) basic_os=nextstep2 ;; *) basic_os=nextstep3 ;; esac ;; np1) cpu=np1 vendor=gould ;; op50n-* | op60c-*) cpu=hppa1.1 vendor=oki basic_os=proelf ;; pa-hitachi) cpu=hppa1.1 vendor=hitachi basic_os=hiuxwe2 ;; pbd) cpu=sparc vendor=tti ;; pbb) cpu=m68k vendor=tti ;; pc532) cpu=ns32k vendor=pc532 ;; pn) cpu=pn vendor=gould ;; power) cpu=power vendor=ibm ;; ps2) cpu=i386 vendor=ibm ;; rm[46]00) cpu=mips vendor=siemens ;; rtpc | rtpc-*) cpu=romp vendor=ibm ;; sde) cpu=mipsisa32 vendor=sde basic_os=${basic_os:-elf} ;; simso-wrs) cpu=sparclite vendor=wrs basic_os=vxworks ;; tower | tower-32) cpu=m68k vendor=ncr ;; vpp*|vx|vx-*) cpu=f301 vendor=fujitsu ;; w65) cpu=w65 vendor=wdc ;; w89k-*) cpu=hppa1.1 vendor=winbond basic_os=proelf ;; none) cpu=none vendor=none ;; leon|leon[3-9]) cpu=sparc vendor=$basic_machine ;; leon-*|leon[3-9]-*) cpu=sparc vendor=`echo "$basic_machine" | sed 's/-.*//'` ;; *-*) # shellcheck disable=SC2162 saved_IFS=$IFS IFS="-" read cpu vendor <&2 exit 1 ;; esac ;; esac # Here we canonicalize certain aliases for manufacturers. case $vendor in digital*) vendor=dec ;; commodore*) vendor=cbm ;; *) ;; esac # Decode manufacturer-specific aliases for certain operating systems. if test x$basic_os != x then # First recognize some ad-hoc cases, or perhaps split kernel-os, or else just # set os. case $basic_os in gnu/linux*) kernel=linux os=`echo "$basic_os" | sed -e 's|gnu/linux|gnu|'` ;; os2-emx) kernel=os2 os=`echo "$basic_os" | sed -e 's|os2-emx|emx|'` ;; nto-qnx*) kernel=nto os=`echo "$basic_os" | sed -e 's|nto-qnx|qnx|'` ;; *-*) # shellcheck disable=SC2162 saved_IFS=$IFS IFS="-" read kernel os <&2 exit 1 ;; esac # As a final step for OS-related things, validate the OS-kernel combination # (given a valid OS), if there is a kernel. case $kernel-$os in linux-gnu* | linux-dietlibc* | linux-android* | linux-newlib* \ | linux-musl* | linux-relibc* | linux-uclibc* ) ;; uclinux-uclibc* ) ;; -dietlibc* | -newlib* | -musl* | -relibc* | -uclibc* ) # These are just libc implementations, not actual OSes, and thus # require a kernel. echo "Invalid configuration \`$1': libc \`$os' needs explicit kernel." 1>&2 exit 1 ;; kfreebsd*-gnu* | kopensolaris*-gnu*) ;; vxworks-simlinux | vxworks-simwindows | vxworks-spe) ;; nto-qnx*) ;; os2-emx) ;; *-eabi* | *-gnueabi*) ;; -*) # Blank kernel with real OS is always fine. ;; *-*) echo "Invalid configuration \`$1': Kernel \`$kernel' not known to work with OS \`$os'." 1>&2 exit 1 ;; esac # Here we handle the case where we know the os, and the CPU type, but not the # manufacturer. We pick the logical manufacturer. case $vendor in unknown) case $cpu-$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 ;; *-clix*) vendor=intergraph ;; *-mvs* | *-opened*) vendor=ibm ;; *-os400*) vendor=ibm ;; s390-* | s390x-*) 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 ;; esac echo "$cpu-$vendor-${kernel:+$kernel-}$os" exit # Local variables: # eval: (add-hook 'before-save-hook 'time-stamp) # time-stamp-start: "timestamp='" # time-stamp-format: "%:y-%02m-%02d" # time-stamp-end: "'" # End: gcl27-2.7.0/configure000077500000000000000000012203061454061450500143550ustar00rootroot00000000000000#! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.71. # # # Copyright (C) 1992-1996, 1998-2017, 2020-2021 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 as_nop=: if test ${ZSH_VERSION+y} && (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 $as_nop case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi # Reset variables that may have inherited troublesome values from # the environment. # IFS needs to be set, to space, tab, and newline, in precisely that order. # (If _AS_PATH_WALK were called with IFS unset, it would have the # side effect of setting IFS to empty, thus disabling word splitting.) # Quoting is to prevent editors from complaining about space-tab. as_nl=' ' export as_nl IFS=" "" $as_nl" PS1='$ ' PS2='> ' PS4='+ ' # Ensure predictable behavior from utilities with locale-dependent output. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # We cannot yet rely on "unset" to work, but we need these variables # to be unset--not just set to an empty or harmless value--now, to # avoid bugs in old shells (e.g. pre-3.0 UWIN ksh). This construct # also avoids known problems related to "unset" and subshell syntax # in other old shells (e.g. bash 2.01 and pdksh 5.2.14). for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH do eval test \${$as_var+y} \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done # Ensure that fds 0, 1, and 2 are open. if (exec 3>&0) 2>/dev/null; then :; else exec 0&1) 2>/dev/null; then :; else exec 1>/dev/null; fi if (exec 3>&2) ; then :; else exec 2>/dev/null; fi # The user is always right. if ${PATH_SEPARATOR+false} :; 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 # 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 case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac 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 printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # 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'. printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2 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="as_nop=: if test \${ZSH_VERSION+y} && (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 \$as_nop 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 \$as_nop exitcode=1; echo positional parameters were not saved. fi test x\$exitcode = x0 || exit 1 blah=\$(echo \$(echo blah)) test x\"\$blah\" = xblah || 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_nop as_have_required=no fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null then : else $as_nop 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 case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac 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_run=a "$as_shell" -c "$as_bourne_compatible""$as_required" 2>/dev/null then : CONFIG_SHELL=$as_shell as_have_required=yes if as_run=a "$as_shell" -c "$as_bourne_compatible""$as_suggested" 2>/dev/null then : break 2 fi fi done;; esac as_found=false done IFS=$as_save_IFS if $as_found then : else $as_nop if { test -f "$SHELL" || test -f "$SHELL.exe"; } && as_run=a "$SHELL" -c "$as_bourne_compatible""$as_required" 2>/dev/null then : CONFIG_SHELL=$SHELL as_have_required=yes fi fi 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'. printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi if test x$as_have_required = xno then : printf "%s\n" "$0: This script requires a shell more modern than all" printf "%s\n" "$0: the shells that I found on your system." if test ${ZSH_VERSION+y} ; then printf "%s\n" "$0: In particular, zsh $ZSH_VERSION has bugs and should" printf "%s\n" "$0: be upgraded to zsh 4.3.4 or later." else printf "%s\n" "$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_nop # --------- # Do nothing but, unlike ":", preserve the value of $?. as_fn_nop () { return $? } as_nop=as_fn_nop # 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=`printf "%s\n" "$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 || printf "%s\n" 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_nop 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_nop as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith # as_fn_nop # --------- # Do nothing but, unlike ":", preserve the value of $?. as_fn_nop () { return $? } as_nop=as_fn_nop # 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 printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi printf "%s\n" "$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 || printf "%s\n" 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" || { printf "%s\n" "$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 } # Determine whether it's possible to make 'echo' print without a newline. # These variables are no longer used directly by Autoconf, but are AC_SUBSTed # for compatibility with existing Makefiles. 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 # For backward compatibility with old third-party macros, we provide # the shell variables $as_echo and $as_echo_n. New code should use # AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively. as_echo='printf %s\n' as_echo_n='printf %s' 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_STDIO_H # include #endif #ifdef HAVE_STDLIB_H # include #endif #ifdef HAVE_STRING_H # include #endif #ifdef HAVE_INTTYPES_H # include #endif #ifdef HAVE_STDINT_H # include #endif #ifdef HAVE_STRINGS_H # include #endif #ifdef HAVE_SYS_TYPES_H # include #endif #ifdef HAVE_SYS_STAT_H # include #endif #ifdef HAVE_UNISTD_H # include #endif" ac_header_c_list= ac_subst_vars='LTLIBOBJS LIBOBJS use GNU_LD LEADING_UNDERSCORE EXTRA_LOBJS 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 EGREP GREP CLSTANDARD SYSTEM FLISP PARGCLDIR 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 MAKEINFO GPROF GCL_CC CPP OBJEXT EXEEXT ac_ct_CC CPPFLAGS LDFLAGS CFLAGS CC PRELINK_CHECK host_os host_vendor host_cpu host build_os build_vendor build_cpu build AWK 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 runstatedir 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_xgcl enable_machine enable_widecons enable_safecdr enable_safecdrdbg enable_prelink enable_vssize enable_bdssize enable_ihssize enable_frssize enable_infodir enable_emacsdir enable_dlopen enable_statsysbfd enable_dynsysbfd enable_custreloc enable_debug enable_static enable_pic enable_gprof enable_dynsysgmp with_x enable_xdr enable_immfix enable_fastimmfix enable_cstackmax enable_pargcl with_mpicc enable_ansi enable_japi enable_readline enable_tcltk enable_tkconfig enable_tclconfig enable_notify ' 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' runstatedir='${localstatedir}/run' 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 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=`printf "%s\n" "$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=`printf "%s\n" "$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 ;; -runstatedir | --runstatedir | --runstatedi | --runstated \ | --runstate | --runstat | --runsta | --runst | --runs \ | --run | --ru | --r) ac_prev=runstatedir ;; -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \ | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \ | --run=* | --ru=* | --r=*) runstatedir=$ac_optarg ;; -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=`printf "%s\n" "$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=`printf "%s\n" "$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. printf "%s\n" "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && printf "%s\n" "$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" ;; *) printf "%s\n" "$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 runstatedir 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 || printf "%s\n" 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] --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run] --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] --enable-xgcl=yes will compile in support for XGCL --enable-machine=XXXX will force the use of one of the definitions in h/XXXX.defs --enable-widecons will use a three word cons with simplified typing --enable-safecdr will protect cdr from immfix and speed up type processing --enable-safecdrdbg will debug safecdr code --enable-prelink will insist that the produced images may be prelinked --enable-vssize=XXXX will compile in a value stack of size XXX --enable-bdssize=XXXX will compile in a binding stack of size XXX --enable-ihssize=XXXX will compile in a invocation history stack of size XXX --enable-frssize=XXXX will compile in a frame stack of size XXX --enable-infodir=XXXX will force the use of a INFO_DIR=XXXXX as place to look for info --enable-emacsdir=XXXX will manually specify the location for elisp files --enable-xgcl=yes will compile in support for XGCL --enable-dlopen uses dlopen for loading objects, which can then not be retained in saved images --enable-statsysbfd uses a static system bfd library for loading and relocating object files --enable-dynsysbfd uses a dynamic shared system bfd library for loading and relocating object files --enable-custreloc uses custom gcl code if available for loading and relocationing object files --enable-debug builds gcl with -g in CFLAGS to enable running under gdb --enable-static will link your GCL against static as opposed to shared system libraries --enable-pic builds gcl with -fPIC in CFLAGS --enable-gprof builds gcl with -pg in CFLAGS to enable profiling with gprof --enable-dynsysgmp will link against the system libgmp3 overriding certain functions with patched versions from the local source --enable-xdr=yes will compile in support for XDR --enable-immfix will enable an immediate fixnum table above the C stack --enable-fastimmfix=XXXX will reject low immediate fixnums unless 2^XXX can be attained --enable-cstackmax=xxxx will ensure that the cstack begins below xxxx or fail --enable-pargcl enables ParGCL (for parallel computing), including subset of MPI (see pargcl/doc/) --enable-ansi builds a large gcl aiming for ansi compliance --enable-japi=yes will compile in support for the JAPI graphical interface if present on your system --enable-readline enables command line completion via the readline library --enable-tcltk will try to build gcl-tk --enable-tkconfig=XXXX will force the use of a TK_CONFIG_PREFIX=XXXXX as place to look for tkConfig.sh and tclConfig.sh --enable-tclconfig=XXXX will force the use of a TCL_CONFIG_PREFIX=XXXXX as place to look for tclConfig.sh and tclConfig.sh --enable-notify=no will disable the automatic notification of gcl maintainers of successful builds/problems Optional Packages: --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) --with-x use the X Window System --with-mpicc=PATH define path to mpicc (default is built-in MPI subset) Some influential environment variables: CC C compiler command CFLAGS C compiler flags LDFLAGS linker flags, e.g. -L 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=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`printf "%s\n" "$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 configure.gnu first; this name is used for a wrapper for # Metaconfig's "Configure" on case-insensitive file systems. 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 printf "%s\n" "$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.71 Copyright (C) 2021 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 conftest.beam 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\"" printf "%s\n" "$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 printf "%s\n" "$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_nop printf "%s\n" "$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_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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 printf %s "checking for $2... " >&6; } if eval test \${$3+y} then : printf %s "(cached) " >&6 else $as_nop 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 $as_nop eval "$3=no" fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi eval ac_res=\$$3 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 printf "%s\n" "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_header_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\"" printf "%s\n" "$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 printf "%s\n" "$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_nop printf "%s\n" "$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 run 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\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? printf "%s\n" "$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\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_try") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; } then : ac_retval=0 else $as_nop printf "%s\n" "$as_me: program exited with status $ac_status" >&5 printf "%s\n" "$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_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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2.$3" >&5 printf %s "checking for $2.$3... " >&6; } if eval test \${$4+y} then : printf %s "(cached) " >&6 else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $5 int main (void) { 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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $5 int main (void) { 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 $as_nop eval "$4=no" fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi eval ac_res=\$$4 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 printf "%s\n" "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_member # 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.beam 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\"" printf "%s\n" "$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 printf "%s\n" "$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_nop printf "%s\n" "$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 # 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 printf %s "checking for $2... " >&6; } if eval test \${$3+y} then : printf %s "(cached) " >&6 else $as_nop 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. */ #include #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 (void) { return $2 (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : eval "$3=yes" else $as_nop eval "$3=no" fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext fi eval ac_res=\$$3 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 printf "%s\n" "$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 (void) { 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 (void) { 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_nop 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.beam conftest.$ac_ext done else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main (void) { 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 (void) { 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_nop 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.beam conftest.$ac_ext done else $as_nop ac_lo= ac_hi= fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam 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 (void) { 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_nop as_fn_arith '(' $ac_mid ')' + 1 && ac_lo=$as_val fi rm -f core conftest.err conftest.$ac_objext conftest.beam 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 (void) { return $2; } static unsigned long int ulongval (void) { return $2; } #include #include int main (void) { 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 printf %s "checking for $2... " >&6; } if eval test \${$3+y} then : printf %s "(cached) " >&6 else $as_nop eval "$3=no" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main (void) { 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 (void) { if (sizeof (($2))) return 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : else $as_nop eval "$3=yes" fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi eval ac_res=\$$3 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 printf "%s\n" "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_type ac_configure_args_raw= for ac_arg do case $ac_arg in *\'*) ac_arg=`printf "%s\n" "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac as_fn_append ac_configure_args_raw " '$ac_arg'" done case $ac_configure_args_raw in *$as_nl*) ac_safe_unquote= ;; *) ac_unsafe_z='|&;<>()$`\\"*?[ '' ' # This string ends in space, tab. ac_unsafe_a="$ac_unsafe_z#~" ac_safe_unquote="s/ '\\([^$ac_unsafe_a][^$ac_unsafe_z]*\\)'/ \\1/g" ac_configure_args_raw=` printf "%s\n" "$ac_configure_args_raw" | sed "$ac_safe_unquote"`;; esac 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.71. Invocation command line was $ $0$ac_configure_args_raw _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 case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac printf "%s\n" "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=`printf "%s\n" "$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=$? # Sanitize IFS. IFS=" "" $as_nl" # Save into config.log some information that might help in debugging. { echo printf "%s\n" "## ---------------- ## ## 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_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 printf "%s\n" "$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 printf "%s\n" "## ----------------- ## ## Output variables. ## ## ----------------- ##" echo for ac_var in $ac_subst_vars do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac printf "%s\n" "$ac_var='\''$ac_val'\''" done | sort echo if test -n "$ac_subst_files"; then printf "%s\n" "## ------------------- ## ## File substitutions. ## ## ------------------- ##" echo for ac_var in $ac_subst_files do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac printf "%s\n" "$ac_var='\''$ac_val'\''" done | sort echo fi if test -s confdefs.h; then printf "%s\n" "## ----------- ## ## confdefs.h. ## ## ----------- ##" echo cat confdefs.h echo fi test "$ac_signal" != 0 && printf "%s\n" "$as_me: caught signal $ac_signal" printf "%s\n" "$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 printf "%s\n" "/* confdefs.h */" > confdefs.h # Predefined preprocessor variables. printf "%s\n" "#define PACKAGE_NAME \"$PACKAGE_NAME\"" >>confdefs.h printf "%s\n" "#define PACKAGE_TARNAME \"$PACKAGE_TARNAME\"" >>confdefs.h printf "%s\n" "#define PACKAGE_VERSION \"$PACKAGE_VERSION\"" >>confdefs.h printf "%s\n" "#define PACKAGE_STRING \"$PACKAGE_STRING\"" >>confdefs.h printf "%s\n" "#define PACKAGE_BUGREPORT \"$PACKAGE_BUGREPORT\"" >>confdefs.h printf "%s\n" "#define PACKAGE_URL \"$PACKAGE_URL\"" >>confdefs.h # Let the site file select an alternate cache file if it wants to. # Prefer an explicitly selected file to automatically selected ones. if test -n "$CONFIG_SITE"; then ac_site_files="$CONFIG_SITE" elif test "x$prefix" != xNONE; then ac_site_files="$prefix/share/config.site $prefix/etc/config.site" else ac_site_files="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" fi for ac_site_file in $ac_site_files do case $ac_site_file in #( */*) : ;; #( *) : ac_site_file=./$ac_site_file ;; esac if test -f "$ac_site_file" && test -r "$ac_site_file"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 printf "%s\n" "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" \ || { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 printf "%s\n" "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . "$cache_file";; *) . "./$cache_file";; esac fi else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 printf "%s\n" "$as_me: creating cache $cache_file" >&6;} >$cache_file fi as_fn_append ac_header_c_list " stdio.h stdio_h HAVE_STDIO_H" # Test code for whether the C compiler supports C89 (global declarations) ac_c_conftest_c89_globals=' /* Does the compiler advertise C89 conformance? Do not test the value of __STDC__, because some compilers set it to 0 while being otherwise adequately conformant. */ #if !defined __STDC__ # error "Compiler does not advertise C89 conformance" #endif #include #include struct stat; /* Most of the following tests are stolen from RCS 5.7 src/conf.sh. */ struct buf { int x; }; struct buf * (*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 do not provoke an error unfortunately, instead are silently treated as an "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 is necessary to write \x00 == 0 to get something that is 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 **, int *(*)(struct buf *, struct stat *, int), int, int);' # Test code for whether the C compiler supports C89 (body of main). ac_c_conftest_c89_main=' ok |= (argc == 0 || f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]); ' # Test code for whether the C compiler supports C99 (global declarations) ac_c_conftest_c99_globals=' // Does the compiler advertise C99 conformance? #if !defined __STDC_VERSION__ || __STDC_VERSION__ < 199901L # error "Compiler does not advertise C99 conformance" #endif #include extern int puts (const char *); extern int printf (const char *, ...); extern int dprintf (int, const char *, ...); extern void *malloc (size_t); // Check varargs macros. These examples are taken from C99 6.10.3.5. // dprintf is used instead of fprintf to avoid needing to declare // FILE and stderr. #define debug(...) dprintf (2, __VA_ARGS__) #define showlist(...) puts (#__VA_ARGS__) #define report(test,...) ((test) ? puts (#test) : printf (__VA_ARGS__)) static void test_varargs_macros (void) { int x = 1234; int y = 5678; debug ("Flag"); debug ("X = %d\n", x); showlist (The first, second, and third items.); report (x>y, "x is %d but y is %d", x, y); } // Check long long types. #define BIG64 18446744073709551615ull #define BIG32 4294967295ul #define BIG_OK (BIG64 / BIG32 == 4294967297ull && BIG64 % BIG32 == 0) #if !BIG_OK #error "your preprocessor is broken" #endif #if BIG_OK #else #error "your preprocessor is broken" #endif static long long int bignum = -9223372036854775807LL; static unsigned long long int ubignum = BIG64; struct incomplete_array { int datasize; double data[]; }; struct named_init { int number; const wchar_t *name; double average; }; typedef const char *ccp; static inline int test_restrict (ccp restrict text) { // See if C++-style comments work. // Iterate through items via the restricted pointer. // Also check for declarations in for loops. for (unsigned int i = 0; *(text+i) != '\''\0'\''; ++i) continue; return 0; } // Check varargs and va_copy. static bool test_varargs (const char *format, ...) { va_list args; va_start (args, format); va_list args_copy; va_copy (args_copy, args); const char *str = ""; int number = 0; float fnumber = 0; while (*format) { switch (*format++) { case '\''s'\'': // string str = va_arg (args_copy, const char *); break; case '\''d'\'': // int number = va_arg (args_copy, int); break; case '\''f'\'': // float fnumber = va_arg (args_copy, double); break; default: break; } } va_end (args_copy); va_end (args); return *str && number && fnumber; } ' # Test code for whether the C compiler supports C99 (body of main). ac_c_conftest_c99_main=' // Check bool. _Bool success = false; success |= (argc != 0); // Check restrict. if (test_restrict ("String literal") == 0) success = true; char *restrict newvar = "Another string"; // Check varargs. success &= test_varargs ("s, d'\'' f .", "string", 65, 34.234); test_varargs_macros (); // Check flexible array members. struct incomplete_array *ia = malloc (sizeof (struct incomplete_array) + (sizeof (double) * 10)); ia->datasize = 10; for (int i = 0; i < ia->datasize; ++i) ia->data[i] = i * 1.234; // Check named initializers. struct named_init ni = { .number = 34, .name = L"Test wide string", .average = 543.34343, }; ni.number = 58; int dynamic_array[ni.number]; dynamic_array[0] = argv[0][0]; dynamic_array[ni.number - 1] = 543; // work around unused variable warnings ok |= (!success || bignum == 0LL || ubignum == 0uLL || newvar[0] == '\''x'\'' || dynamic_array[ni.number - 1] != 543); ' # Test code for whether the C compiler supports C11 (global declarations) ac_c_conftest_c11_globals=' // Does the compiler advertise C11 conformance? #if !defined __STDC_VERSION__ || __STDC_VERSION__ < 201112L # error "Compiler does not advertise C11 conformance" #endif // Check _Alignas. char _Alignas (double) aligned_as_double; char _Alignas (0) no_special_alignment; extern char aligned_as_int; char _Alignas (0) _Alignas (int) aligned_as_int; // Check _Alignof. enum { int_alignment = _Alignof (int), int_array_alignment = _Alignof (int[100]), char_alignment = _Alignof (char) }; _Static_assert (0 < -_Alignof (int), "_Alignof is signed"); // Check _Noreturn. int _Noreturn does_not_return (void) { for (;;) continue; } // Check _Static_assert. struct test_static_assert { int x; _Static_assert (sizeof (int) <= sizeof (long int), "_Static_assert does not work in struct"); long int y; }; // Check UTF-8 literals. #define u8 syntax error! char const utf8_literal[] = u8"happens to be ASCII" "another string"; // Check duplicate typedefs. typedef long *long_ptr; typedef long int *long_ptr; typedef long_ptr long_ptr; // Anonymous structures and unions -- taken from C11 6.7.2.1 Example 1. struct anonymous { union { struct { int i; int j; }; struct { int k; long int l; } w; }; int m; } v1; ' # Test code for whether the C compiler supports C11 (body of main). ac_c_conftest_c11_main=' _Static_assert ((offsetof (struct anonymous, i) == offsetof (struct anonymous, w.k)), "Anonymous union alignment botch"); v1.i = 2; v1.w.k = 5; ok |= v1.i != 5; ' # Test code for whether the C compiler supports C11 (complete). ac_c_conftest_c11_program="${ac_c_conftest_c89_globals} ${ac_c_conftest_c99_globals} ${ac_c_conftest_c11_globals} int main (int argc, char **argv) { int ok = 0; ${ac_c_conftest_c89_main} ${ac_c_conftest_c99_main} ${ac_c_conftest_c11_main} return ok; } " # Test code for whether the C compiler supports C99 (complete). ac_c_conftest_c99_program="${ac_c_conftest_c89_globals} ${ac_c_conftest_c99_globals} int main (int argc, char **argv) { int ok = 0; ${ac_c_conftest_c89_main} ${ac_c_conftest_c99_main} return ok; } " # Test code for whether the C compiler supports C89 (complete). ac_c_conftest_c89_program="${ac_c_conftest_c89_globals} int main (int argc, char **argv) { int ok = 0; ${ac_c_conftest_c89_main} return ok; } " as_fn_append ac_header_c_list " stdlib.h stdlib_h HAVE_STDLIB_H" as_fn_append ac_header_c_list " string.h string_h HAVE_STRING_H" as_fn_append ac_header_c_list " inttypes.h inttypes_h HAVE_INTTYPES_H" as_fn_append ac_header_c_list " stdint.h stdint_h HAVE_STDINT_H" as_fn_append ac_header_c_list " strings.h strings_h HAVE_STRINGS_H" as_fn_append ac_header_c_list " sys/stat.h sys_stat_h HAVE_SYS_STAT_H" as_fn_append ac_header_c_list " sys/types.h sys_types_h HAVE_SYS_TYPES_H" as_fn_append ac_header_c_list " unistd.h unistd_h HAVE_UNISTD_H" as_fn_append ac_header_c_list " wchar.h wchar_h HAVE_WCHAR_H" as_fn_append ac_header_c_list " minix/config.h minix_config_h HAVE_MINIX_CONFIG_H" # Auxiliary files required by this configure script. ac_aux_files="config.guess config.sub" # Locations in which to look for auxiliary files. ac_aux_dir_candidates="${srcdir}${PATH_SEPARATOR}${srcdir}/..${PATH_SEPARATOR}${srcdir}/../.." # Search for a directory containing all of the required auxiliary files, # $ac_aux_files, from the $PATH-style list $ac_aux_dir_candidates. # If we don't find one directory that contains all the files we need, # we report the set of missing files from the *first* directory in # $ac_aux_dir_candidates and give up. ac_missing_aux_files="" ac_first_candidate=: printf "%s\n" "$as_me:${as_lineno-$LINENO}: looking for aux files: $ac_aux_files" >&5 as_save_IFS=$IFS; IFS=$PATH_SEPARATOR as_found=false for as_dir in $ac_aux_dir_candidates do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac as_found=: printf "%s\n" "$as_me:${as_lineno-$LINENO}: trying $as_dir" >&5 ac_aux_dir_found=yes ac_install_sh= for ac_aux in $ac_aux_files do # As a special case, if "install-sh" is required, that requirement # can be satisfied by any of "install-sh", "install.sh", or "shtool", # and $ac_install_sh is set appropriately for whichever one is found. if test x"$ac_aux" = x"install-sh" then if test -f "${as_dir}install-sh"; then printf "%s\n" "$as_me:${as_lineno-$LINENO}: ${as_dir}install-sh found" >&5 ac_install_sh="${as_dir}install-sh -c" elif test -f "${as_dir}install.sh"; then printf "%s\n" "$as_me:${as_lineno-$LINENO}: ${as_dir}install.sh found" >&5 ac_install_sh="${as_dir}install.sh -c" elif test -f "${as_dir}shtool"; then printf "%s\n" "$as_me:${as_lineno-$LINENO}: ${as_dir}shtool found" >&5 ac_install_sh="${as_dir}shtool install -c" else ac_aux_dir_found=no if $ac_first_candidate; then ac_missing_aux_files="${ac_missing_aux_files} install-sh" else break fi fi else if test -f "${as_dir}${ac_aux}"; then printf "%s\n" "$as_me:${as_lineno-$LINENO}: ${as_dir}${ac_aux} found" >&5 else ac_aux_dir_found=no if $ac_first_candidate; then ac_missing_aux_files="${ac_missing_aux_files} ${ac_aux}" else break fi fi fi done if test "$ac_aux_dir_found" = yes; then ac_aux_dir="$as_dir" break fi ac_first_candidate=false as_found=false done IFS=$as_save_IFS if $as_found then : else $as_nop as_fn_error $? "cannot find required auxiliary files:$ac_missing_aux_files" "$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. if test -f "${ac_aux_dir}config.guess"; then ac_config_guess="$SHELL ${ac_aux_dir}config.guess" fi if test -f "${ac_aux_dir}config.sub"; then ac_config_sub="$SHELL ${ac_aux_dir}config.sub" fi if test -f "$ac_aux_dir/configure"; then ac_configure="$SHELL ${ac_aux_dir}configure" 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,) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 printf "%s\n" "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 printf "%s\n" "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 printf "%s\n" "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 printf "%s\n" "$as_me: former value: \`$ac_old_val'" >&2;} { printf "%s\n" "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 printf "%s\n" "$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=`printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 printf "%s\n" "$as_me: error: changes in the environment can compromise the build" >&2;} as_fn_error $? "run \`${MAKE-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` # Check whether --enable-xgcl was given. if test ${enable_xgcl+y} then : enableval=$enable_xgcl; enable_xgcl=$enableval else $as_nop enable_xgcl="yes" fi # # Host information # 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_AWK+y} then : printf %s "(cached) " >&6 else $as_nop 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 case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac 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" printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $AWK" >&5 printf "%s\n" "$AWK" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi test -n "$AWK" && break done # 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking build system type" >&5 printf %s "checking build system type... " >&6; } if test ${ac_cv_build+y} then : printf %s "(cached) " >&6 else $as_nop 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_build" >&5 printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking host system type" >&5 printf %s "checking host system type... " >&6; } if test ${ac_cv_host+y} then : printf %s "(cached) " >&6 else $as_nop 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_host" >&5 printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: host=$host" >&5 printf "%s\n" "host=$host" >&6; } use=unknown case $canonical in sh4*linux*) use=sh4-linux;; *x86_64*linux*) use=amd64-linux;; *x86_64*kfreebsd*) use=amd64-kfreebsd;; *86*linux*) use=386-linux;; *riscv64*linux*) use=riscv64-linux;; *86*kfreebsd*) use=386-kfreebsd;; *86*gnu*) use=386-gnu;; m68k*linux*) 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*hf) use=armhf-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;; i*mingw*|i*msys*) use=mingw;; *cygwin*) if $CC -v 2>&1 | fgrep ming > /dev/null ; then use=mingw else use=gnuwin95 fi;; *openbsd*) use=FreeBSD;; sparc-sun-solaris*) use=solaris;; i?86-pc-solaris*) use=solaris-i386;; esac # Check whether --enable-machine was given. if test ${enable_machine+y} then : enableval=$enable_machine; echo enable_machine=$enableval ; use=$enableval fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: use=$use" >&5 printf "%s\n" "use=$use" >&6; } def_dlopen="no" def_statsysbfd="no" def_custreloc="yes" 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 ia64*) def_dlopen="yes" ; def_custreloc="no" ;; hppa*) def_pic="yes" ;; esac;; esac # Check whether --enable-widecons was given. if test ${enable_widecons+y} then : enableval=$enable_widecons; if test "$enableval" = "yes" ; then printf "%s\n" "#define WIDE_CONS 1" >>confdefs.h fi fi # Check whether --enable-safecdr was given. if test ${enable_safecdr+y} then : enableval=$enable_safecdr; if test "$enableval" = "yes" ; then printf "%s\n" "#define USE_SAFE_CDR 1" >>confdefs.h # Check whether --enable-safecdrdbg was given. if test ${enable_safecdrdbg+y} then : enableval=$enable_safecdrdbg; if test "$enableval" = "yes" ; then printf "%s\n" "#define DEBUG_SAFE_CDR 1" >>confdefs.h fi fi fi fi # Check whether --enable-prelink was given. if test ${enable_prelink+y} then : enableval=$enable_prelink; if test "$enable_prelink" = "yes" ; then PRELINK_CHECK=t; fi fi # Check whether --enable-vssize was given. if test ${enable_vssize+y} then : enableval=$enable_vssize; printf "%s\n" "#define VSSIZE $enableval" >>confdefs.h fi # Check whether --enable-bdssize was given. if test ${enable_bdssize+y} then : enableval=$enable_bdssize; printf "%s\n" "#define BDSSIZE $enableval" >>confdefs.h fi # Check whether --enable-ihssize was given. if test ${enable_ihssize+y} then : enableval=$enable_ihssize; printf "%s\n" "#define IHSSIZE $enableval" >>confdefs.h fi # Check whether --enable-frssize was given. if test ${enable_frssize+y} then : enableval=$enable_frssize; printf "%s\n" "#define FRSSIZE $enableval" >>confdefs.h fi # Check whether --enable-infodir was given. if test ${enable_infodir+y} then : enableval=$enable_infodir; INFO_DIR=$enableval else $as_nop INFO_DIR=$prefix/share/info fi INFO_DIR=`eval echo $INFO_DIR/` # Check whether --enable-emacsdir was given. if test ${enable_emacsdir+y} then : enableval=$enable_emacsdir; EMACS_SITE_LISP=$enableval else $as_nop EMACS_SITE_LISP=$prefix/share/emacs/site-lisp fi EMACS_SITE_LISP=`eval echo $EMACS_SITE_LISP/` # Check whether --enable-xgcl was given. if test ${enable_xgcl+y} then : enableval=$enable_xgcl; else $as_nop enable_xgcl=yes fi # Check whether --enable-dlopen was given. if test ${enable_dlopen+y} then : enableval=$enable_dlopen; else $as_nop enable_dlopen=$def_dlopen fi # Check whether --enable-statsysbfd was given. if test ${enable_statsysbfd+y} then : enableval=$enable_statsysbfd; else $as_nop enable_statsysbfd=$def_statsysbfd fi # Check whether --enable-dynsysbfd was given. if test ${enable_dynsysbfd+y} then : enableval=$enable_dynsysbfd; else $as_nop enable_dynsysbfd=no fi # Check whether --enable-custreloc was given. if test ${enable_custreloc+y} then : enableval=$enable_custreloc; else $as_nop enable_custreloc=$def_custreloc fi # Check whether --enable-debug was given. if test ${enable_debug+y} then : enableval=$enable_debug; else $as_nop enable_debug=$def_debug fi # Check whether --enable-static was given. if test ${enable_static+y} then : enableval=$enable_static; else $as_nop enable_static=$def_static fi # Check whether --enable-pic was given. if test ${enable_pic+y} then : enableval=$enable_pic; else $as_nop enable_pic=$def_pic 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_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 custreloc=$enable_custreloc" as_fn_error $? "loader option failure" "$LINENO" 5 fi # # 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else $as_nop 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 case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac 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" printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 else $as_nop 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 case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac 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" printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 printf "%s\n" "$ac_ct_CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else $as_nop 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 case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac 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" printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else $as_nop 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 case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac 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" printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else $as_nop 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 case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac 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" printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 else $as_nop 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 case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac 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" printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 printf "%s\n" "$ac_ct_CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "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:) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi fi fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}clang", so it can be a program name with args. set dummy ${ac_tool_prefix}clang; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else $as_nop 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 case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac 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}clang" printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi fi if test -z "$ac_cv_prog_CC"; then ac_ct_CC=$CC # Extract the first word of "clang", so it can be a program name with args. set dummy clang; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 else $as_nop 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 case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac 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="clang" printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 printf "%s\n" "$ac_ct_CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 printf "%s\n" "$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 fi test -z "$CC" && { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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. printf "%s\n" "$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 -version; 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\"" printf "%s\n" "$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 printf "%s\n" "$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 (void) { ; 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. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5 printf %s "checking whether the C compiler works... " >&6; } ac_link_default=`printf "%s\n" "$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\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_link_default") 2>&5 ac_status=$? printf "%s\n" "$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+y} && 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 $as_nop ac_file='' fi if test -z "$ac_file" then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5 printf %s "checking for C compiler default output file name... " >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 printf %s "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\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? printf "%s\n" "$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_nop { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 printf "%s\n" "$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 (void) { 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. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 printf %s "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\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? printf "%s\n" "$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\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_try") 2>&5 ac_status=$? printf "%s\n" "$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 { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "cannot run C compiled programs. If you meant to cross compile, use \`--host'. See \`config.log' for more details" "$LINENO" 5; } fi fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 printf "%s\n" "$cross_compiling" >&6; } rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out ac_clean_files=$ac_clean_files_save { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 printf %s "checking for suffix of object files... " >&6; } if test ${ac_cv_objext+y} then : printf %s "(cached) " >&6 else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; 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\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>&5 ac_status=$? printf "%s\n" "$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_nop printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 printf "%s\n" "$ac_cv_objext" >&6; } OBJEXT=$ac_cv_objext ac_objext=$OBJEXT { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the compiler supports GNU C" >&5 printf %s "checking whether the compiler supports GNU C... " >&6; } if test ${ac_cv_c_compiler_gnu+y} then : printf %s "(cached) " >&6 else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { #ifndef __GNUC__ choke me #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_compiler_gnu=yes else $as_nop ac_compiler_gnu=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 printf "%s\n" "$ac_cv_c_compiler_gnu" >&6; } ac_compiler_gnu=$ac_cv_c_compiler_gnu if test $ac_compiler_gnu = yes; then GCC=yes else GCC= fi ac_test_CFLAGS=${CFLAGS+y} ac_save_CFLAGS=$CFLAGS { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 printf %s "checking whether $CC accepts -g... " >&6; } if test ${ac_cv_prog_cc_g+y} then : printf %s "(cached) " >&6 else $as_nop 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 (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_g=yes else $as_nop CFLAGS="" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : else $as_nop ac_c_werror_flag=$ac_save_c_werror_flag CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; 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.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_c_werror_flag=$ac_save_c_werror_flag fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 printf "%s\n" "$ac_cv_prog_cc_g" >&6; } if test $ac_test_CFLAGS; 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 ac_prog_cc_stdc=no if test x$ac_prog_cc_stdc = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C11 features" >&5 printf %s "checking for $CC option to enable C11 features... " >&6; } if test ${ac_cv_prog_cc_c11+y} then : printf %s "(cached) " >&6 else $as_nop ac_cv_prog_cc_c11=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_c_conftest_c11_program _ACEOF for ac_arg in '' -std=gnu11 do CC="$ac_save_CC $ac_arg" if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_c11=$ac_arg fi rm -f core conftest.err conftest.$ac_objext conftest.beam test "x$ac_cv_prog_cc_c11" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC fi if test "x$ac_cv_prog_cc_c11" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } else $as_nop if test "x$ac_cv_prog_cc_c11" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c11" >&5 printf "%s\n" "$ac_cv_prog_cc_c11" >&6; } CC="$CC $ac_cv_prog_cc_c11" fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c11 ac_prog_cc_stdc=c11 fi fi if test x$ac_prog_cc_stdc = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C99 features" >&5 printf %s "checking for $CC option to enable C99 features... " >&6; } if test ${ac_cv_prog_cc_c99+y} then : printf %s "(cached) " >&6 else $as_nop ac_cv_prog_cc_c99=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_c_conftest_c99_program _ACEOF for ac_arg in '' -std=gnu99 -std=c99 -c99 -qlanglvl=extc1x -qlanglvl=extc99 -AC99 -D_STDC_C99= do CC="$ac_save_CC $ac_arg" if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_c99=$ac_arg fi rm -f core conftest.err conftest.$ac_objext conftest.beam test "x$ac_cv_prog_cc_c99" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC fi if test "x$ac_cv_prog_cc_c99" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } else $as_nop if test "x$ac_cv_prog_cc_c99" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c99" >&5 printf "%s\n" "$ac_cv_prog_cc_c99" >&6; } CC="$CC $ac_cv_prog_cc_c99" fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c99 ac_prog_cc_stdc=c99 fi fi if test x$ac_prog_cc_stdc = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C89 features" >&5 printf %s "checking for $CC option to enable C89 features... " >&6; } if test ${ac_cv_prog_cc_c89+y} then : printf %s "(cached) " >&6 else $as_nop ac_cv_prog_cc_c89=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_c_conftest_c89_program _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 conftest.beam test "x$ac_cv_prog_cc_c89" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC fi if test "x$ac_cv_prog_cc_c89" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } else $as_nop if test "x$ac_cv_prog_cc_c89" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 printf "%s\n" "$ac_cv_prog_cc_c89" >&6; } CC="$CC $ac_cv_prog_cc_c89" fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c89 ac_prog_cc_stdc=c89 fi 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_header= ac_cache= for ac_item in $ac_header_c_list do if test $ac_cache; then ac_fn_c_check_header_compile "$LINENO" $ac_header ac_cv_header_$ac_cache "$ac_includes_default" if eval test \"x\$ac_cv_header_$ac_cache\" = xyes; then printf "%s\n" "#define $ac_item 1" >> confdefs.h fi ac_header= ac_cache= elif test $ac_header; then ac_cache=$ac_item else ac_header=$ac_item fi done if test $ac_cv_header_stdlib_h = yes && test $ac_cv_header_string_h = yes then : printf "%s\n" "#define STDC_HEADERS 1" >>confdefs.h fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether it is safe to define __EXTENSIONS__" >&5 printf %s "checking whether it is safe to define __EXTENSIONS__... " >&6; } if test ${ac_cv_safe_to_define___extensions__+y} then : printf %s "(cached) " >&6 else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ # define __EXTENSIONS__ 1 $ac_includes_default int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_cv_safe_to_define___extensions__=yes else $as_nop ac_cv_safe_to_define___extensions__=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_safe_to_define___extensions__" >&5 printf "%s\n" "$ac_cv_safe_to_define___extensions__" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether _XOPEN_SOURCE should be defined" >&5 printf %s "checking whether _XOPEN_SOURCE should be defined... " >&6; } if test ${ac_cv_should_define__xopen_source+y} then : printf %s "(cached) " >&6 else $as_nop ac_cv_should_define__xopen_source=no if test $ac_cv_header_wchar_h = yes then : cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include mbstate_t x; int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #define _XOPEN_SOURCE 500 #include mbstate_t x; int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_cv_should_define__xopen_source=yes fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_should_define__xopen_source" >&5 printf "%s\n" "$ac_cv_should_define__xopen_source" >&6; } printf "%s\n" "#define _ALL_SOURCE 1" >>confdefs.h printf "%s\n" "#define _DARWIN_C_SOURCE 1" >>confdefs.h printf "%s\n" "#define _GNU_SOURCE 1" >>confdefs.h printf "%s\n" "#define _HPUX_ALT_XOPEN_SOCKET_API 1" >>confdefs.h printf "%s\n" "#define _NETBSD_SOURCE 1" >>confdefs.h printf "%s\n" "#define _OPENBSD_SOURCE 1" >>confdefs.h printf "%s\n" "#define _POSIX_PTHREAD_SEMANTICS 1" >>confdefs.h printf "%s\n" "#define __STDC_WANT_IEC_60559_ATTRIBS_EXT__ 1" >>confdefs.h printf "%s\n" "#define __STDC_WANT_IEC_60559_BFP_EXT__ 1" >>confdefs.h printf "%s\n" "#define __STDC_WANT_IEC_60559_DFP_EXT__ 1" >>confdefs.h printf "%s\n" "#define __STDC_WANT_IEC_60559_FUNCS_EXT__ 1" >>confdefs.h printf "%s\n" "#define __STDC_WANT_IEC_60559_TYPES_EXT__ 1" >>confdefs.h printf "%s\n" "#define __STDC_WANT_LIB_EXT2__ 1" >>confdefs.h printf "%s\n" "#define __STDC_WANT_MATH_SPEC_FUNCS__ 1" >>confdefs.h printf "%s\n" "#define _TANDEM_SOURCE 1" >>confdefs.h if test $ac_cv_header_minix_config_h = yes then : MINIX=yes printf "%s\n" "#define _MINIX 1" >>confdefs.h printf "%s\n" "#define _POSIX_SOURCE 1" >>confdefs.h printf "%s\n" "#define _POSIX_1_SOURCE 2" >>confdefs.h else $as_nop MINIX= fi if test $ac_cv_safe_to_define___extensions__ = yes then : printf "%s\n" "#define __EXTENSIONS__ 1" >>confdefs.h fi if test $ac_cv_should_define__xopen_source = yes then : printf "%s\n" "#define _XOPEN_SOURCE 500" >>confdefs.h 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else $as_nop 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 case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac 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" printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 else $as_nop 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 case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac 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" printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 printf "%s\n" "$ac_ct_CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else $as_nop 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 case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac 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" printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else $as_nop 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 case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac 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" printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else $as_nop 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 case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac 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" printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 else $as_nop 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 case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac 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" printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 printf "%s\n" "$ac_ct_CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "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:) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi fi fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}clang", so it can be a program name with args. set dummy ${ac_tool_prefix}clang; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else $as_nop 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 case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac 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}clang" printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi fi if test -z "$ac_cv_prog_CC"; then ac_ct_CC=$CC # Extract the first word of "clang", so it can be a program name with args. set dummy clang; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 else $as_nop 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 case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac 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="clang" printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 printf "%s\n" "$ac_ct_CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 printf "%s\n" "$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 fi test -z "$CC" && { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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. printf "%s\n" "$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 -version; 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\"" printf "%s\n" "$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 printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } done { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the compiler supports GNU C" >&5 printf %s "checking whether the compiler supports GNU C... " >&6; } if test ${ac_cv_c_compiler_gnu+y} then : printf %s "(cached) " >&6 else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { #ifndef __GNUC__ choke me #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_compiler_gnu=yes else $as_nop ac_compiler_gnu=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 printf "%s\n" "$ac_cv_c_compiler_gnu" >&6; } ac_compiler_gnu=$ac_cv_c_compiler_gnu if test $ac_compiler_gnu = yes; then GCC=yes else GCC= fi ac_test_CFLAGS=${CFLAGS+y} ac_save_CFLAGS=$CFLAGS { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 printf %s "checking whether $CC accepts -g... " >&6; } if test ${ac_cv_prog_cc_g+y} then : printf %s "(cached) " >&6 else $as_nop 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 (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_g=yes else $as_nop CFLAGS="" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : else $as_nop ac_c_werror_flag=$ac_save_c_werror_flag CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; 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.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_c_werror_flag=$ac_save_c_werror_flag fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 printf "%s\n" "$ac_cv_prog_cc_g" >&6; } if test $ac_test_CFLAGS; 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 ac_prog_cc_stdc=no if test x$ac_prog_cc_stdc = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C11 features" >&5 printf %s "checking for $CC option to enable C11 features... " >&6; } if test ${ac_cv_prog_cc_c11+y} then : printf %s "(cached) " >&6 else $as_nop ac_cv_prog_cc_c11=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_c_conftest_c11_program _ACEOF for ac_arg in '' -std=gnu11 do CC="$ac_save_CC $ac_arg" if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_c11=$ac_arg fi rm -f core conftest.err conftest.$ac_objext conftest.beam test "x$ac_cv_prog_cc_c11" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC fi if test "x$ac_cv_prog_cc_c11" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } else $as_nop if test "x$ac_cv_prog_cc_c11" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c11" >&5 printf "%s\n" "$ac_cv_prog_cc_c11" >&6; } CC="$CC $ac_cv_prog_cc_c11" fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c11 ac_prog_cc_stdc=c11 fi fi if test x$ac_prog_cc_stdc = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C99 features" >&5 printf %s "checking for $CC option to enable C99 features... " >&6; } if test ${ac_cv_prog_cc_c99+y} then : printf %s "(cached) " >&6 else $as_nop ac_cv_prog_cc_c99=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_c_conftest_c99_program _ACEOF for ac_arg in '' -std=gnu99 -std=c99 -c99 -qlanglvl=extc1x -qlanglvl=extc99 -AC99 -D_STDC_C99= do CC="$ac_save_CC $ac_arg" if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_c99=$ac_arg fi rm -f core conftest.err conftest.$ac_objext conftest.beam test "x$ac_cv_prog_cc_c99" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC fi if test "x$ac_cv_prog_cc_c99" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } else $as_nop if test "x$ac_cv_prog_cc_c99" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c99" >&5 printf "%s\n" "$ac_cv_prog_cc_c99" >&6; } CC="$CC $ac_cv_prog_cc_c99" fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c99 ac_prog_cc_stdc=c99 fi fi if test x$ac_prog_cc_stdc = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C89 features" >&5 printf %s "checking for $CC option to enable C89 features... " >&6; } if test ${ac_cv_prog_cc_c89+y} then : printf %s "(cached) " >&6 else $as_nop ac_cv_prog_cc_c89=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_c_conftest_c89_program _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 conftest.beam test "x$ac_cv_prog_cc_c89" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC fi if test "x$ac_cv_prog_cc_c89" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } else $as_nop if test "x$ac_cv_prog_cc_c89" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 printf "%s\n" "$ac_cv_prog_cc_c89" >&6; } CC="$CC $ac_cv_prog_cc_c89" fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c89 ac_prog_cc_stdc=c89 fi 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5 printf %s "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 test ${ac_cv_prog_CPP+y} then : printf %s "(cached) " >&6 else $as_nop # Double quotes because $CC needs to be expanded for CPP in "$CC -E" "$CC -E -traditional-cpp" 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. # 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. */ #include Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO" then : else $as_nop # 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 $as_nop # 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5 printf "%s\n" "$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. # 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. */ #include Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO" then : else $as_nop # 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 $as_nop # 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_nop { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 GCL_CC=`basename $CC` if echo $GCL_CC |grep gcc |grep -q win; then GCL_CC=gcc fi add_arg_to_cflags() { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for CFLAG $1" >&5 printf %s "checking for CFLAG $1... " >&6; } CFLAGS_ORI=$CFLAGS CFLAGS="$CFLAGS -Werror $1 `echo $1|sed 's,-Wno-,-W,1'`" if test "$cross_compiling" = yes then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : CFLAGS="$CFLAGS_ORI $1";{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; };return 0 else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "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 return 1 } assert_arg_to_cflags() { if ! add_arg_to_cflags $1 ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: cannot add $1 to CFLAGS" >&5 printf "%s\n" "cannot add $1 to CFLAGS" >&6; }; exit 1 ; fi return 0 } add_args_to_cflags() { while test "$#" -ge 1 ; do add_arg_to_cflags $1 shift done } add_arg_to_ldflags() { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for LDFLAG $1" >&5 printf %s "checking for LDFLAG $1... " >&6; } LDFLAGS_ORI=$LDFLAGS LDFLAGS="$LDFLAGS -Werror $1" if test "$cross_compiling" = yes then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : LDFLAGS="$LDFLAGS_ORI $1";{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; };return 0 else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "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 LDFLAGS=$LDFLAGS_ORI return 1 } assert_arg_to_ldflags() { if ! add_arg_to_ldflags $1 ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: cannot add $1 to LDFLAGS" >&5 printf "%s\n" "cannot add $1 to LDFLAGS" >&6; }; exit 1 ; fi return 0 } add_args_to_ldflags() { while test "$#" -ge 1 ; do add_arg_to_ldflags $1 shift done } remove_arg_from_ldflags() { NEW_LDFLAGS="" for i in $LDFLAGS; do if ! test "$i" = "$1" ; then NEW_LDFLAGS="$NEW_LDFLAGS $i" else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: removing $1 from LDFLAGS" >&5 printf "%s\n" "removing $1 from LDFLAGS" >&6; } fi done LDFLAGS=$NEW_LDFLAGS return 0 } add_args_to_cflags -fsigned-char -pipe -fcommon \ -fno-builtin-malloc -fno-builtin-free \ -fno-PIE -fno-pie -fno-PIC -fno-pic \ -Wall \ -Wno-builtin-requires-header -Wno-empty-body -Wno-self-assign \ -Wno-unused-but-set-variable add_args_to_ldflags -no-pie # -Wl,-z,lazy { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for inline semantics" >&5 printf %s "checking for inline semantics... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ inline int foo(int i) {return i;} int bar(int i) {return foo(i);} _ACEOF if ac_fn_c_try_compile "$LINENO" then : if `nm conftest.o |grep foo |awk '{if (NF==3) exit(-1)}'` ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: new" >&5 printf "%s\n" "new" >&6; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ extern inline int foo(int i) {return i;} int bar(int i) {return foo(i);} _ACEOF if ac_fn_c_try_compile "$LINENO" then : if `nm conftest.o |grep foo |awk '{if (NF==3) exit(-1)}'` ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: old" >&5 printf "%s\n" "old" >&6; } printf "%s\n" "#define OLD_INLINE 1" >>confdefs.h else as_fn_error $? "need working inline semantics" "$LINENO" 5 fi else $as_nop as_fn_error $? "need to probe inline semantics" "$LINENO" 5 fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi else $as_nop as_fn_error $? "need to probe inline semantics" "$LINENO" 5 fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for clang" >&5 printf %s "checking for clang... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef __clang__ #define RET 0 #else #define RET 1 #endif int main (void) { return RET; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } clang="yes" remove_arg_from_ldflags -pie printf "%s\n" "#define CLANG 1" >>confdefs.h else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "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 *mingw*) assert_arg_to_cflags -fno-zero-initialized-in-bss assert_arg_to_cflags -mms-bitfields for i in makedefc windows/gcl.iss windows/sysdir.bat windows/install.lsp h/gclincl.h; do cat $i.in | sed 's,^\r\n$,\r\n,g' >tmp && mv tmp $i.in; done OLD_LDFLAGS=$LDFLAGS assert_arg_to_ldflags -pg GPL_FLAG="-pg" LDFLAGS=$OLD_LDFLAGS;; *gnuwin*) assert_arg_to_cflags -fno-zero-initialized-in-bss assert_arg_to_cflags -mms-bitfields assert_arg_to_ldflags -Wl,--stack,8000000 OLD_LDFLAGS=$LDFLAGS assert_arg_to_ldflags -pg GPL_FLAG="-pg" LDFLAGS=$OLD_LDFLAGS;; 386-macosx) # assert_arg_to_cflags -Wno-error=implicit-function-declaration add_arg_to_cflags -Wno-incomplete-setjmp-declaration assert_arg_to_ldflags -Wl,-no_pie if test "$build_cpu" = "x86_64" ; then assert_arg_to_cflags -m64 assert_arg_to_ldflags -m64 assert_arg_to_ldflags -Wl,-headerpad,72 else assert_arg_to_cflags -m32 assert_arg_to_ldflags -m32 assert_arg_to_ldflags -Wl,-headerpad,56 fi;; FreeBSD) assert_arg_to_ldflags -Z;; esac if test "$enable_static" = "yes" ; then assert_arg_to_ldflags -static assert_arg_to_ldflags -Wl,-zmuldefs printf "%s\n" "#define STATIC_LINKING 1" >>confdefs.h fi TO3FLAGS="" TO2FLAGS="" TOSFLAGS="" 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_AWK+y} then : printf %s "(cached) " >&6 else $as_nop 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 case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac 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" printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $AWK" >&5 printf "%s\n" "$AWK" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi test -n "$AWK" && break done GCL_CC_ARGS=`echo $CC | ${AWK} '{$1="";print}'` GCL_CC="`basename $CC` $GCL_CC_ARGS" if echo $GCL_CC |grep gcc |grep -q win; then GCL_CC=gcc fi GPROF="gprof_objs" # Check whether --enable-gprof was given. if test ${enable_gprof+y} then : enableval=$enable_gprof; if test "$enableval" != "yes" ; then GPROF=""; fi fi if test "$GPROF" != "" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking working gprof" >&5 printf %s "checking working gprof... " >&6; } case $use in powerpc*) if test "$host_cpu" = "powerpc64le" ; then GPROF=""; fi;; s390*) GPROF="";;#mcount smashes float args in make_shortfloat 20180313 sh4*) GPROF="";; m68k*) GPROF="";; ia64*) GPROF="";; hppa*) GPROF="";; arm*) if echo $canonical |grep -q hf$; then GPROF=""; fi;;#FIXME CALL and JUMP24 veneers needed for thumb 20190201 #FIXME mcount compiled as a 24/22 bit reloc even with -mlong-calls, marginally accessible aarch64*) GPROF="";;#unreproducible buildd bug 20170824 *gnu) GPROF="";; esac if test "$GPROF" = "" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: disabled" >&5 printf "%s\n" "disabled" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: ok" >&5 printf "%s\n" "ok" >&6; } OLD_CFLAGS=$CFLAGS # Do not run configure tests with -pg assert_arg_to_cflags -pg CFLAGS=$OLD_CFLAGS fi fi if test "$enable_debug" = "yes" ; then assert_arg_to_cflags -g # for subconfigurations CFLAGS="$CFLAGS -g" else TOSFLAGS="-O2" # "-Os $TFPFLAG" 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) assert_arg_to_cflags -mlongcall;; *linux) case $use in alpha*) assert_arg_to_cflags -mieee # if test "$enable_debug" != "yes" ; then TO3FLAGS="-O0" ; fi #FIXME needed asof gcc 4.8.1 ;; aarch64*) TLIBS="$TLIBS -lgcc_s";; hppa*) assert_arg_to_cflags -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 ;; mips*) case $canonical in mips64*linux*) # assert_arg_to_cflags -mxgot assert_arg_to_ldflags -Wl,-z,now;; esac ;; ia64*) if test "$enable_debug" != "yes" ; then TO3FLAGS="-O" ; fi #FIXME needed asof gcc 4.8.1 ;; arm*) printf "%s\n" "#define SET_STACK_POINTER \"mov %%sp,%0\\n\\t\"" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to set stack pointer" >&5 printf %s "checking how to set stack pointer... " >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: done" >&5 printf "%s\n" "done" >&6; } assert_arg_to_cflags -fdollars-in-identifiers assert_arg_to_cflags -g #? ;; powerpc*) assert_arg_to_cflags -mlongcall if test "$host_cpu" != "powerpc64le" ; then assert_arg_to_cflags -mno-pltseq; fi ;; esac;; esac if test "$enable_pic" = "yes" ; then assert_arg_to_cflags -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'` TOSFLAGS=`echo $TOSFLAGS | 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'` TOSFLAGS=`echo $TOSFLAGS | 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'` TOSFLAGS=`echo "$TOSFLAGS" | 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'` TOSFLAGS=`echo $TOSFLAGS | sed 's,\-fomit-frame-pointer,,g'` fi if test "$FOMITF" != "" ; then TO3FLAGS="$TO3FLAGS $FOMITF" 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. 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_MAKEINFO+y} then : printf %s "(cached) " >&6 else $as_nop 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 case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac 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" printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $MAKEINFO" >&5 printf "%s\n" "$MAKEINFO" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi test -n "$MAKEINFO" && break done test -n "$MAKEINFO" || MAKEINFO=""false"" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking system version (for dynamic loading)" >&5 printf %s "checking system version (for dynamic loading)... " >&6; } if machine=`uname -m` ; then true; else machine=unknown ; fi 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unknown (cannot find uname command)" >&5 printf "%s\n" "unknown (cannot 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $system" >&5 printf "%s\n" "$system" >&6; } fi fi case $use in *macosx) for ac_header in malloc/malloc.h do : ac_fn_c_check_header_compile "$LINENO" "malloc/malloc.h" "ac_cv_header_malloc_malloc_h" "$ac_includes_default" if test "x$ac_cv_header_malloc_malloc_h" = xyes then : printf "%s\n" "#define HAVE_MALLOC_MALLOC_H 1" >>confdefs.h else $as_nop 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 : printf "%s\n" "#define HAVE_MALLOC_ZONE_MEMALIGN 1" >>confdefs.h fi ;; esac for ac_header in setjmp.h do : ac_fn_c_check_header_compile "$LINENO" "setjmp.h" "ac_cv_header_setjmp_h" "$ac_includes_default" if test "x$ac_cv_header_setjmp_h" = xyes then : printf "%s\n" "#define HAVE_SETJMP_H 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking sizeof jmp_buf" >&5 printf %s "checking sizeof jmp_buf... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main (void) { 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` { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $sizeof_jmp_buf" >&5 printf "%s\n" "$sizeof_jmp_buf" >&6; } printf "%s\n" "#define SIZEOF_JMP_BUF $sizeof_jmp_buf" >>confdefs.h else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "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_compile "$LINENO" "unistd.h" "ac_cv_header_unistd_h" "$ac_includes_default" if test "x$ac_cv_header_unistd_h" = xyes then : printf "%s\n" "#define HAVE_UNISTD_H 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for sysconf in -lc" >&5 printf %s "checking for sysconf in -lc... " >&6; } if test ${ac_cv_lib_c_sysconf+y} then : printf %s "(cached) " >&6 else $as_nop ac_check_lib_save_LIBS=$LIBS LIBS="-lc $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. */ char sysconf (); int main (void) { return sysconf (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_c_sysconf=yes else $as_nop ac_cv_lib_c_sysconf=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_c_sysconf" >&5 printf "%s\n" "$ac_cv_lib_c_sysconf" >&6; } if test "x$ac_cv_lib_c_sysconf" = xyes then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking _SC_CLK_TCK" >&5 printf %s "checking _SC_CLK_TCK... " >&6; } hz=0 if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main (void) { 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 : fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $hz" >&5 printf "%s\n" "$hz" >&6; } fi fi done rm -f makedefsafter # Check whether --enable-dynsysgmp was given. if test ${enable_dynsysgmp+y} then : enableval=$enable_dynsysgmp; fi if test "$enable_dynsysgmp" != "no" ; then for ac_header in gmp.h do : ac_fn_c_check_header_compile "$LINENO" "gmp.h" "ac_cv_header_gmp_h" "$ac_includes_default" if test "x$ac_cv_header_gmp_h" = xyes then : printf "%s\n" "#define HAVE_GMP_H 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for __gmpz_init in -lgmp" >&5 printf %s "checking for __gmpz_init in -lgmp... " >&6; } if test ${ac_cv_lib_gmp___gmpz_init+y} then : printf %s "(cached) " >&6 else $as_nop 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. */ char __gmpz_init (); int main (void) { return __gmpz_init (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_gmp___gmpz_init=yes else $as_nop ac_cv_lib_gmp___gmpz_init=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_gmp___gmpz_init" >&5 printf "%s\n" "$ac_cv_lib_gmp___gmpz_init" >&6; } if test "x$ac_cv_lib_gmp___gmpz_init" = xyes then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for external gmp version" >&5 printf %s "checking for external gmp version... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { #if __GNU_MP_VERSION > 3 return 0; #else return -1; #endif ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: good" >&5 printf "%s\n" "good" >&6; } 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 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 if test "$MP_INCLUDE" = "" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Cannot use dynamic gmp lib" >&5 printf "%s\n" "Cannot use dynamic gmp lib" >&6; } fi fi if test "$MP_INCLUDE" = "" ; then GMPDIR=gmp4 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking doing configure in gmp directory" >&5 printf %s "checking 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 --host=$host --build=$build && 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for leading underscore in object symbols" >&5 printf %s "checking for leading underscore in object symbols... " >&6; } cat>foo.c < #include int main() {FILE *f;double d=0.0;getc(f);d=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 printf "%s\n" "#define LEADING_UNDERSCORE 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: \"yes\"" >&5 printf "%s\n" "\"yes\"" >&6; } else LEADING_UNDERSCORE="" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: \"no\"" >&5 printf "%s\n" "\"no\"" >&6; } fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for size of gmp limbs" >&5 printf %s "checking for size of gmp limbs... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include "$MP_INCLUDE" int main (void) { FILE *fp=fopen("conftest1","w"); fprintf(fp,"%u",sizeof(mp_limb_t)); fclose(fp); ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : mpsize=`cat conftest1` else $as_nop 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 printf "%s\n" "#define MP_LIMB_BYTES $mpsize" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $mpsize" >&5 printf "%s\n" "$mpsize" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking _SHORT_LIMB" >&5 printf %s "checking _SHORT_LIMB... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include "$MP_INCLUDE" int main (void) { #ifdef _SHORT_LIMB return 0; #else return 1; #endif ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : printf "%s\n" "#define __SHORT_LIMB 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking _LONG_LONG_LIMB" >&5 printf %s "checking _LONG_LONG_LIMB... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include "$MP_INCLUDE" int main (void) { #ifdef _LONG_LONG_LIMB return 0; #else return 1; #endif ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : printf "%s\n" "#define __LONG_LONG_LIMB 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "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 printf "%s\n" "#define GMP 1" >>confdefs.h echo > makedefsafter echo "MPFILES=$MPFILES" >> makedefsafter echo "PATCHED_SYMBOLS=$PATCHED_SYMBOLS" >> makedefsafter echo >> makedefsafter { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for GNU ld option -Map" >&5 printf %s "checking for GNU ld option -Map... " >&6; } touch map foo.c $CC -o foo -Wl,-Map map foo.c >/dev/null 2>&1 if test `cat map | wc -l` != "0" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } printf "%s\n" "#define HAVE_GNU_LD 1" >>confdefs.h GNU_LD=1 else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } GNU_LD= fi rm -f foo.c foo.o foo map # # X windows # if test "$enable_xgcl" = "yes" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for X" >&5 printf %s "checking for X... " >&6; } # Check whether --with-x was given. if test ${with_x+y} 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 test ${ac_cv_have_x+y} then : printf %s "(cached) " >&6 else $as_nop # One or both of the vars are not set, and there is no cached value. ac_x_includes=no ac_x_libraries=no # Do we need to do anything special at all? ac_save_LIBS=$LIBS LIBS="-lX11 $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { XrmInitialize () ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : # We can compile and link X programs with no special options. ac_x_includes= ac_x_libraries= fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS="$ac_save_LIBS" # If that didn't work, only try xmkmf and file system searches # for native compilation. if test x"$ac_x_includes" = xno && test "$cross_compiling" = no then : 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 /opt/X11/include /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 $as_nop 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 (void) { 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 $as_nop LIBS=$ac_save_LIBS for ac_dir in `printf "%s\n" "$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.beam \ conftest$ac_exeext conftest.$ac_ext fi # $ac_x_libraries = no fi # Record the results. 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $have_x" >&5 printf "%s\n" "$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'" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: libraries $x_libraries, headers $x_includes" >&5 printf "%s\n" "libraries $x_libraries, headers $x_includes" >&6; } fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for main in -lX11" >&5 printf %s "checking for main in -lX11... " >&6; } if test ${ac_cv_lib_X11_main+y} then : printf %s "(cached) " >&6 else $as_nop ac_check_lib_save_LIBS=$LIBS LIBS="-lX11 $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { return main (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_X11_main=yes else $as_nop ac_cv_lib_X11_main=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_X11_main" >&5 printf "%s\n" "$ac_cv_lib_X11_main" >&6; } if test "x$ac_cv_lib_X11_main" = xyes then : X_LIBS="$X_LIBS -lX11" printf "%s\n" "#define HAVE_XGCL 1" >>confdefs.h else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: missing x libraries -- cannot compile xgcl" >&5 printf "%s\n" "missing x libraries -- cannot compile xgcl" >&6; } fi fi # # Dynamic loading # if test "$enable_dlopen" = "yes" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5 printf %s "checking for dlopen in -ldl... " >&6; } if test ${ac_cv_lib_dl_dlopen+y} then : printf %s "(cached) " >&6 else $as_nop 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. */ char dlopen (); int main (void) { return dlopen (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_dl_dlopen=yes else $as_nop ac_cv_lib_dl_dlopen=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5 printf "%s\n" "$ac_cv_lib_dl_dlopen" >&6; } if test "x$ac_cv_lib_dl_dlopen" = xyes then : printf "%s\n" "#define HAVE_LIBDL 1" >>confdefs.h LIBS="-ldl $LIBS" else $as_nop as_fn_error $? "Cannot find dlopen" "$LINENO" 5 fi TLIBS="$TLIBS -ldl -rdynamic" assert_arg_to_cflags -fPIC printf "%s\n" "#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_compile "$LINENO" "bfd.h" "ac_cv_header_bfd_h" "$ac_includes_default" if test "x$ac_cv_header_bfd_h" = xyes then : printf "%s\n" "#define HAVE_BFD_H 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for bfd_init in -lbfd" >&5 printf %s "checking for bfd_init in -lbfd... " >&6; } if test ${ac_cv_lib_bfd_bfd_init+y} then : printf %s "(cached) " >&6 else $as_nop 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. */ char bfd_init (); int main (void) { return bfd_init (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_bfd_bfd_init=yes else $as_nop ac_cv_lib_bfd_bfd_init=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_bfd_bfd_init" >&5 printf "%s\n" "$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 # { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking need to define CONST for bfd" >&5 printf %s "checking need to define CONST for bfd... " >&6; } if test "$cross_compiling" = yes then : as_fn_error $? "cannot use bfd" "$LINENO" 5 else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #define IN_GCC #include int main (void) { symbol_info t; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } else $as_nop if test "$cross_compiling" = yes then : as_fn_error $? "cannot use bfd" "$LINENO" 5 else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #define CONST const #define IN_GCC #include int main (void) { symbol_info t; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } printf "%s\n" "#define NEED_CONST 1" >>confdefs.h else $as_nop 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 printf "%s\n" "#define HAVE_LIBBFD 1" >>confdefs.h # # BFD boolean syntax # { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for useable bfd_boolean" >&5 printf %s "checking for useable bfd_boolean... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #define IN_GCC #include bfd_boolean foo() {return FALSE;} int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } printf "%s\n" "#define HAVE_BFD_BOOLEAN 1" >>confdefs.h else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "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 : printf "%s\n" "#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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for inflate in -lz" >&5 printf %s "checking for inflate in -lz... " >&6; } if test ${ac_cv_lib_z_inflate+y} then : printf %s "(cached) " >&6 else $as_nop 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. */ char inflate (); int main (void) { return inflate (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_z_inflate=yes else $as_nop ac_cv_lib_z_inflate=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_z_inflate" >&5 printf "%s\n" "$ac_cv_lib_z_inflate" >&6; } if test "x$ac_cv_lib_z_inflate" = xyes then : TLIBS="$TLIBS -lz" else $as_nop as_fn_error $? "Need zlib for bfd linking" "$LINENO" 5 fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for dlsym in -ldl" >&5 printf %s "checking for dlsym in -ldl... " >&6; } if test ${ac_cv_lib_dl_dlsym+y} then : printf %s "(cached) " >&6 else $as_nop 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. */ char dlsym (); int main (void) { return dlsym (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_dl_dlsym=yes else $as_nop ac_cv_lib_dl_dlsym=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlsym" >&5 printf "%s\n" "$ac_cv_lib_dl_dlsym" >&6; } if test "x$ac_cv_lib_dl_dlsym" = xyes then : TLIBS="$TLIBS -ldl" else $as_nop as_fn_error $? "Need libdl for bfd linking" "$LINENO" 5 fi else TLIBS="$TLIBS -lbfd -liberty -ldl" fi fi # Check whether --enable-xdr was given. if test ${enable_xdr+y} then : enableval=$enable_xdr; fi if test "$enable_xdr" != "no" ; then XDR_LIB="" ac_fn_c_check_func "$LINENO" "xdr_double" "ac_cv_func_xdr_double" if test "x$ac_cv_func_xdr_double" = xyes then : XDR_LIB=" " else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for xdr_double in -ltirpc" >&5 printf %s "checking for xdr_double in -ltirpc... " >&6; } if test ${ac_cv_lib_tirpc_xdr_double+y} then : printf %s "(cached) " >&6 else $as_nop 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. */ char xdr_double (); int main (void) { return xdr_double (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_tirpc_xdr_double=yes else $as_nop ac_cv_lib_tirpc_xdr_double=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_tirpc_xdr_double" >&5 printf "%s\n" "$ac_cv_lib_tirpc_xdr_double" >&6; } if test "x$ac_cv_lib_tirpc_xdr_double" = xyes then : XDR_LIB=tirpc else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for xdr_double in -lgssrpc" >&5 printf %s "checking for xdr_double in -lgssrpc... " >&6; } if test ${ac_cv_lib_gssrpc_xdr_double+y} then : printf %s "(cached) " >&6 else $as_nop ac_check_lib_save_LIBS=$LIBS LIBS="-lgssrpc $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. */ char xdr_double (); int main (void) { return xdr_double (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_gssrpc_xdr_double=yes else $as_nop ac_cv_lib_gssrpc_xdr_double=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_gssrpc_xdr_double" >&5 printf "%s\n" "$ac_cv_lib_gssrpc_xdr_double" >&6; } if test "x$ac_cv_lib_gssrpc_xdr_double" = xyes then : XDR_LIB=gssrpc else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for xdr_double in -lrpc" >&5 printf %s "checking for xdr_double in -lrpc... " >&6; } if test ${ac_cv_lib_rpc_xdr_double+y} then : printf %s "(cached) " >&6 else $as_nop 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. */ char xdr_double (); int main (void) { return xdr_double (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_rpc_xdr_double=yes else $as_nop ac_cv_lib_rpc_xdr_double=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_rpc_xdr_double" >&5 printf "%s\n" "$ac_cv_lib_rpc_xdr_double" >&6; } if test "x$ac_cv_lib_rpc_xdr_double" = xyes then : XDR_LIB=rpc else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for xdr_double in -loncrpc" >&5 printf %s "checking for xdr_double in -loncrpc... " >&6; } if test ${ac_cv_lib_oncrpc_xdr_double+y} then : printf %s "(cached) " >&6 else $as_nop 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. */ char xdr_double (); int main (void) { return xdr_double (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_oncrpc_xdr_double=yes else $as_nop ac_cv_lib_oncrpc_xdr_double=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_oncrpc_xdr_double" >&5 printf "%s\n" "$ac_cv_lib_oncrpc_xdr_double" >&6; } if test "x$ac_cv_lib_oncrpc_xdr_double" = xyes then : XDR_LIB=oncrpc fi fi fi fi fi if test "$XDR_LIB" != ""; then printf "%s\n" "#define HAVE_XDR 1" >>confdefs.h if test "$XDR_LIB" != " "; then TLIBS="$TLIBS -l$XDR_LIB" add_arg_to_cflags -I/usr/include/$XDR_LIB fi fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking __builtin_clzl" >&5 printf %s "checking __builtin_clzl... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main (void) { 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 : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } printf "%s\n" "#define HAVE_CLZL 1" >>confdefs.h else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking __builtin_ctzl" >&5 printf %s "checking __builtin_ctzl... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main (void) { unsigned long u; long j; if (__builtin_ctzl(0)!=sizeof(long)*8) return -1; for (u=1,j=0;j&5 printf "%s\n" "yes" >&6; } printf "%s\n" "#define HAVE_CTZL 1" >>confdefs.h else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "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 *) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking __builtin___clear_cache" >&5 printf %s "checking __builtin___clear_cache... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { void *v,*ve; __builtin___clear_cache(v,ve); ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : printf "%s\n" "#define HAVE_BUILTIN_CLEAR_CACHE 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "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. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking size of long" >&5 printf %s "checking size of long... " >&6; } if test ${ac_cv_sizeof_long+y} then : printf %s "(cached) " >&6 else $as_nop if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (long))" "ac_cv_sizeof_long" "$ac_includes_default" then : else $as_nop if test "$ac_cv_type_long" = yes; then { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_long" >&5 printf "%s\n" "$ac_cv_sizeof_long" >&6; } printf "%s\n" "#define SIZEOF_LONG $ac_cv_sizeof_long" >>confdefs.h # 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. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking size of short" >&5 printf %s "checking size of short... " >&6; } if test ${ac_cv_sizeof_short+y} then : printf %s "(cached) " >&6 else $as_nop if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (short))" "ac_cv_sizeof_short" "$ac_includes_default" then : else $as_nop if test "$ac_cv_type_short" = yes; then { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "cannot compute sizeof (short) See \`config.log' for more details" "$LINENO" 5; } else ac_cv_sizeof_short=0 fi fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_short" >&5 printf "%s\n" "$ac_cv_sizeof_short" >&6; } printf "%s\n" "#define SIZEOF_SHORT $ac_cv_sizeof_short" >>confdefs.h # 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. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking size of int" >&5 printf %s "checking size of int... " >&6; } if test ${ac_cv_sizeof_int+y} then : printf %s "(cached) " >&6 else $as_nop if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (int))" "ac_cv_sizeof_int" "$ac_includes_default" then : else $as_nop if test "$ac_cv_type_int" = yes; then { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "cannot compute sizeof (int) See \`config.log' for more details" "$LINENO" 5; } else ac_cv_sizeof_int=0 fi fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_int" >&5 printf "%s\n" "$ac_cv_sizeof_int" >&6; } printf "%s\n" "#define SIZEOF_INT $ac_cv_sizeof_int" >>confdefs.h # Check whether --enable-immfix was given. if test ${enable_immfix+y} then : enableval=$enable_immfix; fi # Check whether --enable-fastimmfix was given. if test ${enable_fastimmfix+y} then : enableval=$enable_fastimmfix; else $as_nop enable_fastimmfix=64 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_compile "$LINENO" "math.h" "ac_cv_header_math_h" "$ac_includes_default" if test "x$ac_cv_header_math_h" = xyes then : printf "%s\n" "#define HAVE_MATH_H 1" >>confdefs.h printf "%s\n" "#define HAVE_MATH_H 1" >>confdefs.h fi done for ac_header in complex.h do : ac_fn_c_check_header_compile "$LINENO" "complex.h" "ac_cv_header_complex_h" "$ac_includes_default" if test "x$ac_cv_header_complex_h" = xyes then : printf "%s\n" "#define HAVE_COMPLEX_H 1" >>confdefs.h printf "%s\n" "#define HAVE_COMPLEX_H 1" >>confdefs.h fi done #### Memory areas and alignment { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for byte order" >&5 printf %s "checking for byte order... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { /* 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 : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: little" >&5 printf "%s\n" "little" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: big" >&5 printf "%s\n" "big" >&6; } printf "%s\n" "#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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for word order" >&5 printf %s "checking for word order... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { /* 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 : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: little" >&5 printf "%s\n" "little" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: big" >&5 printf "%s\n" "big" >&6; } printf "%s\n" "#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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for pagewidth" >&5 printf %s "checking for pagewidth... " >&6; } case $use in mips*) min_pagewidth=14;; *) min_pagewidth=12;; esac if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #ifdef __CYGWIN__ #define getpagesize() 4096 #endif int main (void) { 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; } _ACEOF if ac_fn_c_try_run "$LINENO" then : PAGEWIDTH=`cat conftest1` else $as_nop 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PAGEWIDTH" >&5 printf "%s\n" "$PAGEWIDTH" >&6; } printf "%s\n" "#define PAGEWIDTH $PAGEWIDTH" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for required object alignment" >&5 printf %s "checking for required object alignment... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include #define EXTER #define INLINE #include "$MP_INCLUDE" #include "./h/enum.h" #define OBJ_ALIGN #include "./h/type.h" #include "./h/lu.h" #include "./h/object.h" int main (void) { 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` { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $obj_align" >&5 printf "%s\n" "$obj_align" >&6; } printf "%s\n" "#define OBJ_ALIGNMENT $obj_align" >>confdefs.h else $as_nop 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C extension variable alignment" >&5 printf %s "checking for C extension variable alignment... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { char *v __attribute__ ((aligned ($obj_align))); ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : obj_align="__attribute__ ((aligned ($obj_align)))" else $as_nop 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $obj_align" >&5 printf "%s\n" "$obj_align" >&6; } printf "%s\n" "#define OBJ_ALIGN $obj_align" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C extension noreturn function attribute" >&5 printf %s "checking for C extension noreturn function attribute... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { extern int v() __attribute__ ((noreturn)); ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : no_return="__attribute__ ((noreturn))" else $as_nop 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $no_return" >&5 printf "%s\n" "$no_return" >&6; } printf "%s\n" "#define NO_RETURN $no_return" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking sizeof struct contblock" >&5 printf %s "checking sizeof struct contblock... " >&6; } if test "$cross_compiling" = yes then : as_fn_error $? "Cannot find sizeof struct contblock" "$LINENO" 5 else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include #define EXTER #define INLINE #include "$MP_INCLUDE" #include "h/enum.h" #include "h/type.h" #include "h/lu.h" #include "h/object.h" int main (void) { 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 $as_nop as_fn_error $? "Cannot find sizeof struct contblock" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $sizeof_contblock" >&5 printf "%s\n" "$sizeof_contblock" >&6; } printf "%s\n" "#define SIZEOF_CONTBLOCK $sizeof_contblock" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for sbrk" >&5 printf %s "checking for sbrk... " >&6; } HAVE_SBRK="" if test "$cross_compiling" = yes then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no: WARNING you must be able to emulate sbrk: as on mingw or macosx" >&5 printf "%s\n" "no: WARNING you must be able to emulate sbrk: as on mingw or macosx" >&6; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main (void) { FILE *f; if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%p",sbrk(0)); ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : HAVE_SBRK=1;{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no: WARNING you must be able to emulate sbrk: as on mingw or macosx" >&5 printf "%s\n" "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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: emulating sbrk for mac" >&5 printf "%s\n" "emulating sbrk for mac" >&6; }; HAVE_SBRK=0 fi if test "$HAVE_SBRK" = "1" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ADDR_NO_RANDOMIZE constant" >&5 printf %s "checking for ADDR_NO_RANDOMIZE constant... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main (void) { FILE *f; if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%x",ADDR_NO_RANDOMIZE); ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : ADDR_NO_RANDOMIZE=`cat conftest1` { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes $ADDR_NO_RANDOMIZE" >&5 printf "%s\n" "yes $ADDR_NO_RANDOMIZE" >&6; } else $as_nop ADDR_NO_RANDOMIZE=0 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no assuming 0x40000" >&5 printf "%s\n" "no assuming 0x40000" >&6; } printf "%s\n" "#define ADDR_NO_RANDOMIZE 0x40000" >>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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ADDR_COMPAT_LAYOUT constant" >&5 printf %s "checking for ADDR_COMPAT_LAYOUT constant... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main (void) { FILE *f; if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%x",ADDR_COMPAT_LAYOUT); ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : ADDR_COMPAT_LAYOUT=`cat conftest1` { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes $ADDR_COMPAT_LAYOUT" >&5 printf "%s\n" "yes $ADDR_COMPAT_LAYOUT" >&6; } else $as_nop ADDR_COMPAT_LAYOUT=0 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } printf "%s\n" "#define ADDR_COMPAT_LAYOUT 0" >>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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ADDR_LIMIT_3GB constant" >&5 printf %s "checking for ADDR_LIMIT_3GB constant... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main (void) { FILE *f; if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%x",ADDR_LIMIT_3GB); ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : ADDR_LIMIT_3GB=`cat conftest1` { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes $ADDR_LIMIT_3GB" >&5 printf "%s\n" "yes $ADDR_LIMIT_3GB" >&6; } else $as_nop ADDR_LIMIT_3GB=0 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } printf "%s\n" "#define ADDR_LIMIT_3GB 0" >>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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for personality(ADDR_NO_RANDOMIZE) support" >&5 printf %s "checking for personality(ADDR_NO_RANDOMIZE) support... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main(int argc,char *argv[],char *envp[]) { #include "h/unrandomize.h" return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } printf "%s\n" "#define CAN_UNRANDOMIZE_SBRK 1" >>confdefs.h else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking that sbrk is (now) non-random" >&5 printf %s "checking that sbrk is (now) non-random... " >&6; } SBRK=0 if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include 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,"%p",sbrk(0)); return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : SBRK=`cat conftest1` 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_fn_error $? "cannot trap sbrk" "$LINENO" 5 fi SBRK1=0 if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include 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,"%p",sbrk(0)); return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : SBRK1=`cat conftest1` 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_fn_error $? "cannot trap sbrk" "$LINENO" 5 fi if test "$SBRK" = "$SBRK1" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "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" as_fn_error $? "exiting" "$LINENO" 5 fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking CSTACK_DIRECTION" >&5 printf %s "checking CSTACK_DIRECTION... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main(int argc,char **argv,char **envp) { FILE *fp = fopen("conftest1","w"); #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif fprintf(fp,"%d",(alloca(sizeof(void *))>alloca(sizeof(void *))) ? -1 : 1); fclose(fp); return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : cstack_direction=`cat conftest1` else $as_nop 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 printf "%s\n" "#define CSTACK_DIRECTION $cstack_direction" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cstack_direction" >&5 printf "%s\n" "$cstack_direction" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking finding CSTACK_ALIGNMENT" >&5 printf %s "checking finding CSTACK_ALIGNMENT... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include 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 $as_nop 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 printf "%s\n" "#define CSTACK_ALIGNMENT $cstack_alignment" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cstack_alignment" >&5 printf "%s\n" "$cstack_alignment" >&6; } # Check whether --enable-cstackmax was given. if test ${enable_cstackmax+y} then : enableval=$enable_cstackmax; if test "$enableval" != "" ; then printf "%s\n" "#define CSTACKMAX $enableval" >>confdefs.h fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking CSTACK_ADDRESS" >&5 printf %s "checking CSTACK_ADDRESS... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main(int argc,char **argv,char **envp) { 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)alloca(sizeof(void *)); if ($cstack_direction==1) 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 $as_nop 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 printf "%s\n" "#define CSTACK_ADDRESS $cstack_address" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cstack_address" >&5 printf "%s\n" "$cstack_address" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking cstack bits" >&5 printf %s "checking cstack bits... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main(int argc,char **argv,char **envp) { void *v ; FILE *fp = fopen("conftest1","w"); long i,j; #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif j=1; j<<=$PAGEWIDTH; j<<=16; i=(long)&v; if ($cstack_direction==1) i-=j; j--; i+=j; i&=~j; for (j=0;(i>>j)!=(i>>(sizeof(long)*8-1));j++); fprintf(fp,"%ld",j); fclose(fp); return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : cstack_bits=`cat conftest1` else $as_nop 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 printf "%s\n" "#define CSTACK_BITS $cstack_bits" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cstack_bits" >&5 printf "%s\n" "$cstack_bits" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking NEG_CSTACK_ADDRESS" >&5 printf %s "checking NEG_CSTACK_ADDRESS... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include 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 : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } neg_cstack_address=1 printf "%s\n" "#define NEG_CSTACK_ADDRESS 1" >>confdefs.h else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "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 # Check whether --enable-immfix was given. if test ${enable_immfix+y} then : enableval=$enable_immfix; fi # Check whether --enable-fastimmfix was given. if test ${enable_fastimmfix+y} then : enableval=$enable_fastimmfix; else $as_nop enable_fastimmfix=64 fi if test "$use" != "386-gnu" ; then #hurd can push .data below C stack, but sbrk(0) remains above, foiling unexec { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking finding default linker script" >&5 printf %s "checking finding default linker script... " >&6; } touch unixport/gcl.script echo "int main() {return 0;}" >foo.c $CC $LDFLAGS -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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: got it" >&5 printf "%s\n" "got it" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking output_arch" >&5 printf %s "checking output_arch... " >&6; } output_arch=`cat gcl.script |grep OUTPUT_ARCH|head -n 1|sed 's,.*(\(.*\)).*,\1,1'|cut -f1 -d:`; if test "$output_arch" != "" ; then printf "%s\n" "#define OUTPUT_ARCH bfd_arch_${output_arch}" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: bfd_arch_${output_arch}" >&5 printf "%s\n" "bfd_arch_${output_arch}" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not found" >&5 printf "%s\n" "not found" >&6; } fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: trying to adjust text start" >&5 printf "%s\n" "$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 $LDFLAGS -Wl,-T gcl.script foo.c -o foo >/dev/null 2>&1 && ./foo >/dev/null 2>&1 ) >/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 printf "%s\n" "$as_me: min log text start $min" >&6;} { printf "%s\n" "$as_me:${as_lineno-$LINENO}: max log text start $max" >&5 printf "%s\n" "$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; { printf "%s\n" "$as_me:${as_lineno-$LINENO}: max log text start reduced to $max considering c stack address" >&5 printf "%s\n" "$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" != "no" ; then j=`$AWK 'END {for (i=j=0;j<=n;j++) i=i ? i*2 : 1;printf("%x\n",3*i)}' n=$max &5 printf "%s\n" "$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 printf "%s\n" "$as_me: lowering log text to $j to maximize data area" >&6;} fi fi if test "$low_shft" != "" ; then printf "%s\n" "#define LOW_SHFT $low_shft" >>confdefs.h printf "%s\n" "#define OBJNULL (object)0x$j" >>confdefs.h else printf "%s\n" "#define OBJNULL NULL" >>confdefs.h fi # echo $j; { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking our linker script" >&5 printf %s "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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: done" >&5 printf "%s\n" "done" >&6; } rm -f gcl.script.def assert_arg_to_ldflags -Wl,-T,gcl.script cp gcl.script unixport else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none found or not needed" >&5 printf "%s\n" "none found or not needed" >&6; } rm -f gcl.script gcl.script.def fi rm -rf foo.c foo else printf "%s\n" "#define OBJNULL NULL" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not found" >&5 printf "%s\n" "not found" >&6; } fi else printf "%s\n" "#define OBJNULL NULL" >>confdefs.h fi printf "%s\n" "#define CSSIZE $enable_cssize" >>confdefs.h mem_top=0 mem_range=0 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking mem top" >&5 printf %s "checking mem top... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { unsigned long i,j,k,l; 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 $as_nop 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $mem_top" >&5 printf "%s\n" "$mem_top" >&6; } if test "$mem_top" != "0x0" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking finding upper mem half range" >&5 printf %s "checking finding upper mem half range... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { 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 $as_nop 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $mem_range" >&5 printf "%s\n" "$mem_range" >&6; } if test "$mem_range" != "0x0" ; then printf "%s\n" "#define MEM_TOP $mem_top" >>confdefs.h printf "%s\n" "#define MEM_RANGE $mem_range" >>confdefs.h fi fi if test "$enable_immfix" != "no" ; then if test "$mem_top" != "0x0" ; then if test "$mem_range" != "0x0" ; then printf "%s\n" "#define IM_FIX_BASE ${mem_top}UL" >>confdefs.h printf "%s\n" "#define IM_FIX_LIM ${mem_range}UL" >>confdefs.h fi fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking sizeof long long int" >&5 printf %s "checking sizeof long long int... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { if (sizeof(long long int) == 2*sizeof(long)) return 0; return 1; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : printf "%s\n" "#define HAVE_LONG_LONG 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "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_compile "$LINENO" "dirent.h" "ac_cv_header_dirent_h" "$ac_includes_default" if test "x$ac_cv_header_dirent_h" = xyes then : printf "%s\n" "#define HAVE_DIRENT_H 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for d_type" >&5 printf %s "checking for d_type... " >&6; } if test "$cross_compiling" = yes then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main (void) { struct dirent *d; DIR *r=opendir("./"); for (;(d=readdir(r)) && strcmp("configure",d->d_name);); return d && d->d_type==DT_REG ? 0 : -1; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } printf "%s\n" "#define HAVE_D_TYPE 1" >>confdefs.h else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "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 # # ParGCL # # ParGCL (includes MPINU) # Check whether --enable-pargcl was given. if test ${enable_pargcl+y} then : enableval=$enable_pargcl; else $as_nop enable_pargcl="no" fi # Check whether --with-mpicc was given. if test ${with_mpicc+y} then : withval=$with_mpicc; else $as_nop with_mpicc=no fi # ansi lisp SYSTEM=ansi_gcl CLSTANDARD=ANSI # Check whether --enable-ansi was given. if test ${enable_ansi+y} then : enableval=$enable_ansi; if test "$enable_ansi" = "no" ; then SYSTEM=gcl CLSTANDARD=CLtL1 fi fi if test "$enable_pargcl" != "no" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking enable_pargcl=yes, doing configure in pargcl directory" >&5 printf %s "checking enable_pargcl=yes, doing configure in pargcl directory... " >&6; } if test -d pargcl; then PARGCLDIR=pargcl fi echo echo "#" echo "#" echo "# -------------------" echo "# Subconfigure of ParGCL" echo "#" echo "#" #SYSTEM is either gcl or ansi_gcl. This must come after def of SYSTEM PARGCL_GCLDIR=`pwd` ( cd $PARGCLDIR && ./configure --with-gcl=$PARGCL_GCLDIR/bin/$SYSTEM \ --with-gcl-build-dir=$PARGCL_GCLDIR --with-mpicc=$with_mpicc ) #MY_SUBDIRS="$MY_SUBDIRS $PARGCLDIR" echo "#" echo "#" echo "#" echo "# Subconfigure of ParGCL done" echo "# ------------------------" echo "#" fi FLISP="saved_$SYSTEM" # Maximum number of pages # Check if Posix compliant getcwd exists, if not we'll use getwd. ac_fn_c_check_func "$LINENO" "getcwd" "ac_cv_func_getcwd" if test "x$ac_cv_func_getcwd" = xyes then : printf "%s\n" "#define HAVE_GETCWD 1" >>confdefs.h fi ac_fn_c_check_func "$LINENO" "getwd" "ac_cv_func_getwd" if test "x$ac_cv_func_getwd" = xyes then : printf "%s\n" "#define HAVE_GETWD 1" >>confdefs.h fi ac_fn_c_check_func "$LINENO" "rename" "ac_cv_func_rename" if test "x$ac_cv_func_rename" = xyes then : printf "%s\n" "#define HAVE_RENAME 1" >>confdefs.h fi ac_fn_c_check_func "$LINENO" "uname" "ac_cv_func_uname" if test "x$ac_cv_func_uname" = xyes then : else $as_nop printf "%s\n" "#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_nop printf "%s\n" "#define NO_GETTOD 1" >>confdefs.h fi ac_fn_c_check_header_compile "$LINENO" "sys/ioctl.h" "ac_cv_header_sys_ioctl_h" "$ac_includes_default" if test "x$ac_cv_header_sys_ioctl_h" = xyes then : printf "%s\n" "#define HAVE_SYS_IOCTL_H 1" >>confdefs.h fi # OpenBSD has elf_abi.h instead of elf.h ac_fn_c_check_header_compile "$LINENO" "elf.h" "ac_cv_header_elf_h" "$ac_includes_default" if test "x$ac_cv_header_elf_h" = xyes then : printf "%s\n" "#define HAVE_ELF_H 1" >>confdefs.h fi ac_fn_c_check_header_compile "$LINENO" "elf_abi.h" "ac_cv_header_elf_abi_h" "$ac_includes_default" if test "x$ac_cv_header_elf_abi_h" = xyes then : printf "%s\n" "#define HAVE_ELF_ABI_H 1" >>confdefs.h fi ac_fn_c_check_header_compile "$LINENO" "sys/sockio.h" "ac_cv_header_sys_sockio_h" "$ac_includes_default" if test "x$ac_cv_header_sys_sockio_h" = xyes then : printf "%s\n" "#define HAVE_SYS_SOCKIO_H 1" >>confdefs.h fi #-------------------------------------------------------------------- # 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 : printf "%s\n" "#define HAVE_BSDGETTIMEOFDAY 1" >>confdefs.h else $as_nop ac_fn_c_check_func "$LINENO" "gettimeofday" "ac_cv_func_gettimeofday" if test "x$ac_cv_func_gettimeofday" = xyes then : else $as_nop printf "%s\n" "#define NO_GETTOD 1" >>confdefs.h fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5 printf %s "checking for grep that handles long lines and -e... " >&6; } if test ${ac_cv_path_GREP+y} then : printf %s "(cached) " >&6 else $as_nop 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 case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac 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 printf %s 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" printf "%s\n" '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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5 printf "%s\n" "$ac_cv_path_GREP" >&6; } GREP="$ac_cv_path_GREP" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5 printf %s "checking for egrep... " >&6; } if test ${ac_cv_path_EGREP+y} then : printf %s "(cached) " >&6 else $as_nop 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 case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac 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 printf %s 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" printf "%s\n" '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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5 printf "%s\n" "$ac_cv_path_EGREP" >&6; } EGREP="$ac_cv_path_EGREP" 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 : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gettimeofday declaration" >&5 printf %s "checking for gettimeofday declaration... " >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: present" >&5 printf "%s\n" "present" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gettimeofday declaration" >&5 printf %s "checking for gettimeofday declaration... " >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: missing" >&5 printf "%s\n" "missing" >&6; } printf "%s\n" "#define GETTOD_NOT_DECLARED 1" >>confdefs.h fi rm -rf conftest* if test "$use" != "mingw" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for sin in -lm" >&5 printf %s "checking for sin in -lm... " >&6; } if test ${ac_cv_lib_m_sin+y} then : printf %s "(cached) " >&6 else $as_nop 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. */ char sin (); int main (void) { return sin (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_m_sin=yes else $as_nop ac_cv_lib_m_sin=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_m_sin" >&5 printf "%s\n" "$ac_cv_lib_m_sin" >&6; } if test "x$ac_cv_lib_m_sin" = xyes then : LIBS="${LIBS} -lm" else $as_nop true fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for main in -lmingwex" >&5 printf %s "checking for main in -lmingwex... " >&6; } if test ${ac_cv_lib_mingwex_main+y} then : printf %s "(cached) " >&6 else $as_nop ac_check_lib_save_LIBS=$LIBS LIBS="-lmingwex $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { return main (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_mingwex_main=yes else $as_nop ac_cv_lib_mingwex_main=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mingwex_main" >&5 printf "%s\n" "$ac_cv_lib_mingwex_main" >&6; } if test "x$ac_cv_lib_mingwex_main" = xyes then : LIBS="${LIBS} -lmingwex" else $as_nop true fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for buggy maximum sscanf length" >&5 printf %s "checking for buggy maximum sscanf length... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { 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 : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none" >&5 printf "%s\n" "none" >&6; } else $as_nop buggy_maximum_sscanf_length=`cat conftest1` { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $buggy_maximum_sscanf_length" >&5 printf "%s\n" "$buggy_maximum_sscanf_length" >&6; } printf "%s\n" "#define BUGGY_MAXIMUM_SSCANF_LENGTH $buggy_maximum_sscanf_length" >>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 EXTRA_LOBJS= # Check whether --enable-japi was given. if test ${enable_japi+y} then : enableval=$enable_japi; if test "$enable_japi" = "yes" ; then for ac_header in japi.h do : ac_fn_c_check_header_compile "$LINENO" "japi.h" "ac_cv_header_japi_h" "$ac_includes_default" if test "x$ac_cv_header_japi_h" = xyes then : printf "%s\n" "#define HAVE_JAPI_H 1" >>confdefs.h printf "%s\n" "#define HAVE_JAPI_H 1" >>confdefs.h EXTRA_LOBJS="${EXTRA_LOBJS} gcl_japi.o" LIBS="${LIBS} -ljapi -lwsock32" fi done fi 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 # for ac_header in values.h do : ac_fn_c_check_header_compile "$LINENO" "values.h" "ac_cv_header_values_h" "$ac_includes_default" if test "x$ac_cv_header_values_h" = xyes then : printf "%s\n" "#define HAVE_VALUES_H 1" >>confdefs.h printf "%s\n" "#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_compile "$LINENO" "float.h" "ac_cv_header_float_h" "$ac_includes_default" if test "x$ac_cv_header_float_h" = xyes then : printf "%s\n" "#define HAVE_FLOAT_H 1" >>confdefs.h printf "%s\n" "#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 # { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for isnormal" >&5 printf %s "checking for isnormal... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #define _GNU_SOURCE #include int main (void) { float f; return isnormal(f) || !isnormal(f) ? 0 : 1; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : printf "%s\n" "#define HAVE_ISNORMAL 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for fpclass of ieeefp.h" >&5 printf %s "checking for fpclass of ieeefp.h... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { float f; return fpclass(f)>=FP_NZERO || fpclass(f)>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for isfinite" >&5 printf %s "checking for isfinite... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #define _GNU_SOURCE #include int main (void) { float f; return isfinite(f) || !isfinite(f) ? 0 : 1; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : printf "%s\n" "#define HAVE_ISFINITE 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for finite()" >&5 printf %s "checking for finite()... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$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 $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main (void) { float f; return finite(f) || !finite(f) ? 0 : 1; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : printf "%s\n" "#define HAVE_FINITE 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop 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. #-------------------------------------------------------------------- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for sockets" >&5 printf %s "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 $as_nop tcl_checkSocket=1 fi if test "$tcl_checkSocket" = 1; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for main in -lsocket" >&5 printf %s "checking for main in -lsocket... " >&6; } if test ${ac_cv_lib_socket_main+y} then : printf %s "(cached) " >&6 else $as_nop ac_check_lib_save_LIBS=$LIBS LIBS="-lsocket $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { return main (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_socket_main=yes else $as_nop ac_cv_lib_socket_main=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_socket_main" >&5 printf "%s\n" "$ac_cv_lib_socket_main" >&6; } if test "x$ac_cv_lib_socket_main" = xyes then : TLIBS="$TLIBS -lsocket" else $as_nop 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 $as_nop 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_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for main in -lnsl" >&5 printf %s "checking for main in -lnsl... " >&6; } if test ${ac_cv_lib_nsl_main+y} then : printf %s "(cached) " >&6 else $as_nop ac_check_lib_save_LIBS=$LIBS LIBS="-lnsl $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { return main (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_nsl_main=yes else $as_nop ac_cv_lib_nsl_main=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_nsl_main" >&5 printf "%s\n" "$ac_cv_lib_nsl_main" >&6; } if test "x$ac_cv_lib_nsl_main" = xyes then : TLIBS="$TLIBS -lnsl" fi fi # readline # Check whether --enable-readline was given. if test ${enable_readline+y} then : enableval=$enable_readline; fi if test "$use" = "mingw" ; then enable_readline=no fi if test "$enable_readline" != "no" ; then for ac_header in readline/readline.h do : ac_fn_c_check_header_compile "$LINENO" "readline/readline.h" "ac_cv_header_readline_readline_h" "#include " if test "x$ac_cv_header_readline_readline_h" = xyes then : printf "%s\n" "#define HAVE_READLINE_READLINE_H 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for rl_initialize in -lreadline" >&5 printf %s "checking for rl_initialize in -lreadline... " >&6; } if test ${ac_cv_lib_readline_rl_initialize+y} then : printf %s "(cached) " >&6 else $as_nop 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. */ char rl_initialize (); int main (void) { return rl_initialize (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_readline_rl_initialize=yes else $as_nop ac_cv_lib_readline_rl_initialize=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_readline_rl_initialize" >&5 printf "%s\n" "$ac_cv_lib_readline_rl_initialize" >&6; } if test "x$ac_cv_lib_readline_rl_initialize" = xyes then : printf "%s\n" "#define USE_READLINE 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for el_getc in -lreadline" >&5 printf %s "checking for el_getc in -lreadline... " >&6; } if test ${ac_cv_lib_readline_el_getc+y} then : printf %s "(cached) " >&6 else $as_nop 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. */ char el_getc (); int main (void) { return el_getc (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_readline_el_getc=yes else $as_nop ac_cv_lib_readline_el_getc=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_readline_el_getc" >&5 printf "%s\n" "$ac_cv_lib_readline_el_getc" >&6; } if test "x$ac_cv_lib_readline_el_getc" = xyes then : printf "%s\n" "#define READLINE_IS_EDITLINE 1" >>confdefs.h fi # These tests discover differences between readline 4.1 and 4.3 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for rl_completion_matches in -lreadline" >&5 printf %s "checking for rl_completion_matches in -lreadline... " >&6; } if test ${ac_cv_lib_readline_rl_completion_matches+y} then : printf %s "(cached) " >&6 else $as_nop 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. */ char rl_completion_matches (); int main (void) { return rl_completion_matches (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_readline_rl_completion_matches=yes else $as_nop ac_cv_lib_readline_rl_completion_matches=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_readline_rl_completion_matches" >&5 printf "%s\n" "$ac_cv_lib_readline_rl_completion_matches" >&6; } if test "x$ac_cv_lib_readline_rl_completion_matches" = xyes then : printf "%s\n" "#define HAVE_DECL_RL_COMPLETION_MATCHES 1" >>confdefs.h printf "%s\n" "#define HAVE_RL_COMPENTRY_FUNC_T 1" >>confdefs.h fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking RL_COMPLETION_ENTRY_FUNCTION_TYPE_FUNCTION" >&5 printf %s "checking RL_COMPLETION_ENTRY_FUNCTION_TYPE_FUNCTION... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include extern Function *rl_completion_entry_function __attribute__((weak)); int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : printf "%s\n" "#define RL_COMPLETION_ENTRY_FUNCTION_TYPE_FUNCTION 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking RL_COMPLETION_ENTRY_FUNCTION_TYPE_RL_COMPENTRY_FUNC_T" >&5 printf %s "checking RL_COMPLETION_ENTRY_FUNCTION_TYPE_RL_COMPENTRY_FUNC_T... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include extern rl_compentry_func_t *rl_completion_entry_function __attribute__((weak)); int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : printf "%s\n" "#define RL_COMPLETION_ENTRY_FUNCTION_TYPE_RL_COMPENTRY_FUNC_T 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } as_fn_error $? "Unknown rl_completion_entry_function return type" "$LINENO" 5 fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking RL_READLINE_NAME_TYPE_CHAR" >&5 printf %s "checking RL_READLINE_NAME_TYPE_CHAR... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include extern char *rl_readline_name __attribute__((weak)); int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : printf "%s\n" "#define RL_READLINE_NAME_TYPE_CHAR 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking RL_READLINE_NAME_TYPE_CONST_CHAR" >&5 printf %s "checking RL_READLINE_NAME_TYPE_CONST_CHAR... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include extern const char *rl_readline_name __attribute__((weak)); int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : printf "%s\n" "#define RL_READLINE_NAME_TYPE_CONST_CHAR 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } as_fn_error $? "Unknown rl_readline_name return type" "$LINENO" 5 fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext TLIBS="$TLIBS -lreadline" #some machines don't link this, e.g. Slackware RL_OBJS=gcl_readline fi fi done fi # sockets { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking For network code for nsocket.c" >&5 printf %s "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 (void) { 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 : printf "%s\n" "#define HAVE_NSOCKET 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking check for listen using fcntl" >&5 printf %s "checking check for listen using fcntl... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main (void) { 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 : printf "%s\n" "#define LISTEN_USE_FCNTL 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.beam 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_nop printf "%s\n" "#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 : printf "%s\n" "#define HAVE_SETENV 1" >>confdefs.h else $as_nop 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 : printf "%s\n" "#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 : printf "%s\n" "#define USE_CLEANUP 1" >>confdefs.h fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking FIONBIO vs. O_NONBLOCK for nonblocking I/O" >&5 printf %s "checking FIONBIO vs. O_NONBLOCK for nonblocking I/O... " >&6; } case $system in OSF*) printf "%s\n" "#define USE_FIONBIO 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: FIONBIO" >&5 printf "%s\n" "FIONBIO" >&6; } ;; SunOS-4*) printf "%s\n" "#define USE_FIONBIO 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: FIONBIO" >&5 printf "%s\n" "FIONBIO" >&6; } ;; ULTRIX-4.*) printf "%s\n" "#define USE_FIONBIO 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: FIONBIO" >&5 printf "%s\n" "FIONBIO" >&6; } ;; *) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: O_NONBLOCK" >&5 printf "%s\n" "O_NONBLOCK" >&6; } ;; esac { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking check for SV_ONSTACK" >&5 printf %s "checking check for SV_ONSTACK... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int joe=SV_ONSTACK; int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : printf "%s\n" "#define HAVE_SV_ONSTACK 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking check for SIGSYS" >&5 printf %s "checking check for SIGSYS... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int joe=SIGSYS; int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : printf "%s\n" "#define HAVE_SIGSYS 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking check for SIGEMT" >&5 printf %s "checking check for SIGEMT... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int joe=SIGEMT; int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : printf "%s\n" "#define HAVE_SIGEMT 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_fn_c_check_func "$LINENO" "sigaltstack" "ac_cv_func_sigaltstack" if test "x$ac_cv_func_sigaltstack" = xyes then : printf "%s\n" "#define HAVE_SIGALTSTACK 1" >>confdefs.h fi ac_fn_c_check_func "$LINENO" "feenableexcept" "ac_cv_func_feenableexcept" if test "x$ac_cv_func_feenableexcept" = xyes then : printf "%s\n" "#define HAVE_FEENABLEEXCEPT 1" >>confdefs.h fi for ac_header in dis-asm.h do : ac_fn_c_check_header_compile "$LINENO" "dis-asm.h" "ac_cv_header_dis_asm_h" "$ac_includes_default" if test "x$ac_cv_header_dis_asm_h" = xyes then : printf "%s\n" "#define HAVE_DIS_ASM_H 1" >>confdefs.h MLIBS=$LIBS { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for init_disassemble_info in -lopcodes" >&5 printf %s "checking for init_disassemble_info in -lopcodes... " >&6; } if test ${ac_cv_lib_opcodes_init_disassemble_info+y} then : printf %s "(cached) " >&6 else $as_nop 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. */ char init_disassemble_info (); int main (void) { return init_disassemble_info (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_opcodes_init_disassemble_info=yes else $as_nop ac_cv_lib_opcodes_init_disassemble_info=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_opcodes_init_disassemble_info" >&5 printf "%s\n" "$ac_cv_lib_opcodes_init_disassemble_info" >&6; } if test "x$ac_cv_lib_opcodes_init_disassemble_info" = xyes then : printf "%s\n" "#define HAVE_LIBOPCODES 1" >>confdefs.h LIBS="-lopcodes $LIBS" fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5 printf %s "checking for dlopen in -ldl... " >&6; } if test ${ac_cv_lib_dl_dlopen+y} then : printf %s "(cached) " >&6 else $as_nop 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. */ char dlopen (); int main (void) { return dlopen (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_dl_dlopen=yes else $as_nop ac_cv_lib_dl_dlopen=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5 printf "%s\n" "$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 : printf "%s\n" "#define HAVE_PRINT_INSN_I386 1" >>confdefs.h LIBS="$MLIBS -ldl" fi done fi fi done #if test $use = "386-linux" ; then ac_fn_c_check_header_compile "$LINENO" "asm/sigcontext.h" "ac_cv_header_asm_sigcontext_h" "$ac_includes_default" if test "x$ac_cv_header_asm_sigcontext_h" = xyes then : printf "%s\n" "#define HAVE_ASM_SIGCONTEXT_H 1" >>confdefs.h fi ac_fn_c_check_header_compile "$LINENO" "asm/signal.h" "ac_cv_header_asm_signal_h" "$ac_includes_default" if test "x$ac_cv_header_asm_signal_h" = xyes then : printf "%s\n" "#define HAVE_ASM_SIGNAL_H 1" >>confdefs.h fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for sigcontext..." >&5 printf %s "checking for sigcontext...... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { struct sigcontext foo; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : printf "%s\n" "#define SIGNAL_H_HAS_SIGCONTEXT 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: sigcontext of signal.h" >&5 printf "%s\n" "sigcontext of signal.h" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: sigcontext NOT of signal.h" >&5 printf "%s\n" "sigcontext NOT of signal.h" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for sigcontext..." >&5 printf %s "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 (void) { struct sigcontext foo; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : printf "%s\n" "#define HAVE_SIGCONTEXT 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: sigcontext asm files" >&5 printf "%s\n" "sigcontext asm files" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no sigcontext found" >&5 printf "%s\n" "no sigcontext found" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext # Extract the first word of "emacs", so it can be a program name with args. set dummy emacs; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_path_EMACS+y} then : printf %s "(cached) " >&6 else $as_nop 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 case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac 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" printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $EMACS" >&5 printf "%s\n" "$EMACS" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi # check for where the emacs site lisp directory is. rm -f conftest.el cat >> conftest.el <&5 printf %s "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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $EMACS_SITE_LISP" >&5 printf "%s\n" "$EMACS_SITE_LISP" >&6; } # check for where the emacs site lisp default.el is rm -f conftest.el cat >> conftest.el <&5 printf %s "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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $EMACS_DEFAULT_EL" >&5 printf "%s\n" "$EMACS_DEFAULT_EL" >&6; } # check for where the emacs site lisp info/dir is rm -f conftest.el cat >> conftest.el <&5 printf %s "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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $INFO_DIR" >&5 printf "%s\n" "$INFO_DIR" >&6; } # Check whether --enable-tcltk was given. if test ${enable_tcltk+y} then : enableval=$enable_tcltk; fi # Check whether --enable-tkconfig was given. if test ${enable_tkconfig+y} then : enableval=$enable_tkconfig; TK_CONFIG_PREFIX=$enableval else $as_nop TK_CONFIG_PREFIX=unknown fi # Check whether --enable-tclconfig was given. if test ${enable_tclconfig+y} then : enableval=$enable_tclconfig; TCL_CONFIG_PREFIX=$enableval else $as_nop TCL_CONFIG_PREFIX=unknown fi if test "$enable_tcltk" != "no" ; then 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_TCLSH+y} then : printf %s "(cached) " >&6 else $as_nop 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 case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac 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" printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $TCLSH" >&5 printf "%s\n" "$TCLSH" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi if test "${TCLSH}" = "" ; then true ; else rm -f conftest.tcl cat >> conftest.tcl <&5 printf %s "checking for main in -llieee... " >&6; } if test ${ac_cv_lib_lieee_main+y} then : printf %s "(cached) " >&6 else $as_nop ac_check_lib_save_LIBS=$LIBS LIBS="-llieee $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { return main (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_lieee_main=yes else $as_nop ac_cv_lib_lieee_main=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_lieee_main" >&5 printf "%s\n" "$ac_cv_lib_lieee_main" >&6; } if test "x$ac_cv_lib_lieee_main" = xyes then : have_ieee=1 else $as_nop have_ieee=0 fi if test "$have_ieee" = "0" ; then TCL_LIBS=`echo ${TCL_LIBS} | sed -e "s:-lieee::g" ` fi TCL_STUB_LIBS="" fi fi if test "${TK_BUILTIN_PREFIX}" = "yes"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Builtin TK requested, checking Tk library header" >&5 printf "%s\n" "Builtin TK requested, checking Tk library header" >&6; } if test "${TK_INCLUDE}" = "" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Builtin TK requested but libraries not found so ignoring" >&5 printf "%s\n" "Builtin TK requested but libraries not found so ignoring" >&6; } else CFLAGS="$CFLAGS -DBUILD_tcl $TCL_DEFS $TK_DEFS $TK_INCLUDE $TCL_INCLUDE $TK_XINCLUDES" LIBS="$LIBS $TK_LIB_SPEC $TCL_LIB_SPEC $TK_LIBS" printf "%s\n" "#define HAVE_TK 1" >>confdefs.h EXTRA_LOBJS="${EXTRA_LOBJS} gcl_tk.o" fi else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Builtin TK not requested" >&5 printf "%s\n" "Builtin TK not requested" >&6; } fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for tcl/tk" >&5 printf %s "checking for tcl/tk... " >&6; } if test -d "${TK_CONFIG_PREFIX}" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: using TK_VERSION=${TK_VERSION} of ${TK_CONFIG_PREFIX}" >&5 printf "%s\n" "using TK_VERSION=${TK_VERSION} of ${TK_CONFIG_PREFIX}" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not found" >&5 printf "%s\n" "not found" >&6; } fi # Check whether --enable-notify was given. if test ${enable_notify+y} then : enableval=$enable_notify; NOTIFY=$enable_notify fi # 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_compile "$LINENO" "sys/mman.h" "ac_cv_header_sys_mman_h" "$ac_includes_default" if test "x$ac_cv_header_sys_mman_h" = xyes then : printf "%s\n" "#define HAVE_SYS_MMAN_H 1" >>confdefs.h ac_fn_c_check_func "$LINENO" "mprotect" "ac_cv_func_mprotect" if test "x$ac_cv_func_mprotect" = xyes then : printf "%s\n" "#define HAVE_MPROTECT 1" >>confdefs.h fi fi done ac_fn_c_check_header_compile "$LINENO" "alloca.h" "ac_cv_header_alloca_h" "$ac_includes_default" if test "x$ac_cv_header_alloca_h" = xyes then : printf "%s\n" "#define HAVE_ALLOCA_H 1" >>confdefs.h fi 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 $as_nop printf "%s\n" "#define size_t unsigned int" >>confdefs.h fi # The Ultrix 4.2 mips builtin alloca declared by alloca.h only works # for constant arguments. Useless! { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for working alloca.h" >&5 printf %s "checking for working alloca.h... " >&6; } if test ${ac_cv_working_alloca_h+y} then : printf %s "(cached) " >&6 else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { 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 $as_nop ac_cv_working_alloca_h=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_working_alloca_h" >&5 printf "%s\n" "$ac_cv_working_alloca_h" >&6; } if test $ac_cv_working_alloca_h = yes; then printf "%s\n" "#define HAVE_ALLOCA_H 1" >>confdefs.h fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for alloca" >&5 printf %s "checking for alloca... " >&6; } if test ${ac_cv_func_alloca_works+y} then : printf %s "(cached) " >&6 else $as_nop if test $ac_cv_working_alloca_h = yes; then ac_cv_func_alloca_works=yes else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #ifndef alloca # ifdef __GNUC__ # define alloca __builtin_alloca # elif defined _MSC_VER # include # define alloca _alloca # else # ifdef __cplusplus extern "C" # endif void *alloca (size_t); # endif #endif int main (void) { 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 $as_nop ac_cv_func_alloca_works=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_func_alloca_works" >&5 printf "%s\n" "$ac_cv_func_alloca_works" >&6; } fi if test $ac_cv_func_alloca_works = yes; then printf "%s\n" "#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 printf "%s\n" "#define C_ALLOCA 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking stack direction for C alloca" >&5 printf %s "checking stack direction for C alloca... " >&6; } if test ${ac_cv_c_stack_direction+y} then : printf %s "(cached) " >&6 else $as_nop if test "$cross_compiling" = yes then : ac_cv_c_stack_direction=0 else $as_nop 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 $as_nop 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_stack_direction" >&5 printf "%s\n" "$ac_cv_c_stack_direction" >&6; } printf "%s\n" "#define STACK_DIRECTION $ac_cv_c_stack_direction" >>confdefs.h fi LDFLAGS="`echo $GPL_FLAG $LDFLAGS | sed 's,gcl.script,../unixport/gcl.script,g'`" LIBS="$X_PRE_LIBS $X_LIBS $X_EXTRA_LIBS $LIBS $TLIBS" CFLAGS="$CFLAGS $GP_FLAG" FINAL_CFLAGS="$CFLAGS $CPPFLAGS $X_CFLAGS" # Work around bug with gcc on ppc -- CM NIFLAGS="$CFLAGS $CPPFLAGS $TONIFLAGS -I\$(GCLDIR)/o" CFLAGS="$CFLAGS $CPPFLAGS $TO3FLAGS -I\$(GCLDIR)/o" O3FLAGS=$TOSFLAGS 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_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 printf "%s\n" "$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+y} || &/ 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 printf "%s\n" "$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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 printf "%s\n" "$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=`printf "%s\n" "$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" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 printf "%s\n" "$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 as_nop=: if test ${ZSH_VERSION+y} && (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 $as_nop case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi # Reset variables that may have inherited troublesome values from # the environment. # IFS needs to be set, to space, tab, and newline, in precisely that order. # (If _AS_PATH_WALK were called with IFS unset, it would have the # side effect of setting IFS to empty, thus disabling word splitting.) # Quoting is to prevent editors from complaining about space-tab. as_nl=' ' export as_nl IFS=" "" $as_nl" PS1='$ ' PS2='> ' PS4='+ ' # Ensure predictable behavior from utilities with locale-dependent output. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # We cannot yet rely on "unset" to work, but we need these variables # to be unset--not just set to an empty or harmless value--now, to # avoid bugs in old shells (e.g. pre-3.0 UWIN ksh). This construct # also avoids known problems related to "unset" and subshell syntax # in other old shells (e.g. bash 2.01 and pdksh 5.2.14). for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH do eval test \${$as_var+y} \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done # Ensure that fds 0, 1, and 2 are open. if (exec 3>&0) 2>/dev/null; then :; else exec 0&1) 2>/dev/null; then :; else exec 1>/dev/null; fi if (exec 3>&2) ; then :; else exec 2>/dev/null; fi # The user is always right. if ${PATH_SEPARATOR+false} :; 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 # 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 case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac 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 printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # 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 printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi printf "%s\n" "$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_nop 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_nop 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 || printf "%s\n" 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 # Determine whether it's possible to make 'echo' print without a newline. # These variables are no longer used directly by Autoconf, but are AC_SUBSTed # for compatibility with existing Makefiles. 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 # For backward compatibility with old third-party macros, we provide # the shell variables $as_echo and $as_echo_n. New code should use # AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively. as_echo='printf %s\n' as_echo_n='printf %s' 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=`printf "%s\n" "$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 || printf "%s\n" 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.71. 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 ac_cs_config=`printf "%s\n" "$ac_configure_args" | sed "$ac_safe_unquote"` ac_cs_config_escaped=`printf "%s\n" "$ac_cs_config" | sed "s/^ //; s/'/'\\\\\\\\''/g"` cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config='$ac_cs_config_escaped' ac_cs_version="\\ config.status configured by $0, generated by GNU Autoconf 2.71, with options \\"\$ac_cs_config\\" Copyright (C) 2021 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 ) printf "%s\n" "$ac_cs_version"; exit ;; --config | --confi | --conf | --con | --co | --c ) printf "%s\n" "$ac_cs_config"; exit ;; --debug | --debu | --deb | --de | --d | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`printf "%s\n" "$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=`printf "%s\n" "$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 ) printf "%s\n" "$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 \printf "%s\n" "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 printf "%s\n" "$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+y} || CONFIG_FILES=$config_files test ${CONFIG_HEADERS+y} || 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=`printf "%s\n" "$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 '` printf "%s\n" "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' `' by configure.' if test x"$ac_file" != x-; then configure_input="$ac_file. $configure_input" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 printf "%s\n" "$as_me: creating $ac_file" >&6;} fi # Neutralize special characters interpreted by sed in replacement strings. case $configure_input in #( *\&* | *\|* | *\\* ) ac_sed_conf_input=`printf "%s\n" "$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 || printf "%s\n" 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=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`printf "%s\n" "$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@*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 printf "%s\n" "$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"; } && { printf "%s\n" "$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 printf "%s\n" "$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 { printf "%s\n" "/* $configure_input */" >&1 \ && 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $ac_file is unchanged" >&5 printf "%s\n" "$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 printf "%s\n" "/* $configure_input */" >&1 \ && 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 printf "%s\n" "$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 gcl27-2.7.0/configure-new.ac000066400000000000000000000635311454061450500155270ustar00rootroot00000000000000AC_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 | sed -e /^Warn/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 gcl27-2.7.0/configure.in000066400000000000000000002123461454061450500147630ustar00rootroot00000000000000AC_INIT AC_PREREQ([2.71]) AC_CONFIG_HEADERS([h/gclincl.h]) VERSION=`cat majvers`.`cat minvers` AC_SUBST(VERSION) AC_ARG_ENABLE(xgcl,[ --enable-xgcl=yes will compile in support for XGCL], [enable_xgcl=$enableval],[enable_xgcl="yes"]) # # Host information # AC_CHECK_PROGS(AWK,gawk nawk awk) AC_CANONICAL_HOST 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]]}'` 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) use=unknown case $canonical in sh4*linux*) use=sh4-linux;; *x86_64*linux*) use=amd64-linux;; *x86_64*kfreebsd*) use=amd64-kfreebsd;; *86*linux*) use=386-linux;; *riscv64*linux*) use=riscv64-linux;; *86*kfreebsd*) use=386-kfreebsd;; *86*gnu*) use=386-gnu;; m68k*linux*) 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*hf) use=armhf-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;; i*mingw*|i*msys*) use=mingw;; *cygwin*) if $CC -v 2>&1 | fgrep ming > /dev/null ; then use=mingw else use=gnuwin95 fi;; *openbsd*) use=FreeBSD;; sparc-sun-solaris*) use=solaris;; i?86-pc-solaris*) use=solaris-i386;; esac AC_ARG_ENABLE([machine],[ --enable-machine=XXXX will force the use of one of the definitions in h/XXXX.defs], [echo enable_machine=$enableval ; use=$enableval]) AC_MSG_RESULT([use=$use]) def_dlopen="no" def_statsysbfd="no" def_custreloc="yes" 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 ia64*) def_dlopen="yes" ; def_custreloc="no" ;; hppa*) def_pic="yes" ;; esac;; esac AC_ARG_ENABLE([widecons],[ --enable-widecons will use a three word cons with simplified typing], [if test "$enableval" = "yes" ; then AC_DEFINE([WIDE_CONS],[1],[three word cons]) fi]) AC_ARG_ENABLE([safecdr],[ --enable-safecdr will protect cdr from immfix and speed up type processing], [if test "$enableval" = "yes" ; then AC_DEFINE([USE_SAFE_CDR],[1],[protect cdr from immfix and speed up type processing]) AC_ARG_ENABLE([safecdrdbg],[ --enable-safecdrdbg will debug safecdr code], [if test "$enableval" = "yes" ; then AC_DEFINE([DEBUG_SAFE_CDR],[1],[debug safecdr code]) fi]) fi]) AC_ARG_ENABLE([prelink],[ --enable-prelink will insist that the produced images may be prelinked], [if test "$enable_prelink" = "yes" ; then PRELINK_CHECK=t; fi]) AC_SUBST(PRELINK_CHECK) AC_ARG_ENABLE([vssize],[ --enable-vssize=XXXX will compile in a value stack of size XXX], [AC_DEFINE_UNQUOTED(VSSIZE,$enableval,[value stack size])]) AC_ARG_ENABLE([bdssize],[ --enable-bdssize=XXXX will compile in a binding stack of size XXX], [AC_DEFINE_UNQUOTED(BDSSIZE,$enableval,[binding stack size])]) AC_ARG_ENABLE([ihssize],[ --enable-ihssize=XXXX will compile in a invocation history stack of size XXX], [AC_DEFINE_UNQUOTED(IHSSIZE,$enableval,[invocation history stack size])]) AC_ARG_ENABLE([frssize],[ --enable-frssize=XXXX will compile in a frame stack of size XXX], [AC_DEFINE_UNQUOTED(FRSSIZE,$enableval,[frame stack size])]) 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=$prefix/share/info]) INFO_DIR=`eval echo $INFO_DIR/` AC_ARG_ENABLE([emacsdir],[ --enable-emacsdir=XXXX will manually specify the location for elisp files], [EMACS_SITE_LISP=$enableval],[EMACS_SITE_LISP=$prefix/share/emacs/site-lisp]) EMACS_SITE_LISP=`eval echo $EMACS_SITE_LISP/` AC_ARG_ENABLE([xgcl],[ --enable-xgcl=yes will compile in support for XGCL],,[enable_xgcl=yes]) 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 system bfd library for loading and relocating object files], ,[enable_statsysbfd=$def_statsysbfd]) AC_ARG_ENABLE([dynsysbfd],[ --enable-dynsysbfd uses a dynamic shared system bfd library for loading and relocating object files], ,[enable_dynsysbfd=no]) 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([static],[ --enable-static will link your GCL against static as opposed to shared system libraries], ,[enable_static=$def_static]) AC_ARG_ENABLE([pic],[ --enable-pic builds gcl with -fPIC in CFLAGS],,[enable_pic=$def_pic]) 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_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 custreloc=$enable_custreloc" AC_MSG_ERROR([loader option failure]) fi # # 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_USE_SYSTEM_EXTENSIONS AC_PROG_CC AC_PROG_CPP AC_SUBST(CC) GCL_CC=`basename $CC` if echo $GCL_CC |grep gcc |grep -q win; then GCL_CC=gcc fi AC_SUBST(GCL_CC) AC_SUBST(CPP) add_arg_to_cflags() { AC_MSG_CHECKING([for CFLAG $1]) CFLAGS_ORI=$CFLAGS CFLAGS="$CFLAGS -Werror $1 `echo $1|sed 's,-Wno-,-W,1'`" AC_RUN_IFELSE( [AC_LANG_PROGRAM([[]],[[]])], [CFLAGS="$CFLAGS_ORI $1";AC_MSG_RESULT([yes]);return 0], [AC_MSG_RESULT([no])], [AC_MSG_RESULT([no])]) CFLAGS=$CFLAGS_ORI return 1 } assert_arg_to_cflags() { if ! add_arg_to_cflags $1 ; then AC_MSG_RESULT([cannot add $1 to CFLAGS]); exit 1 ; fi return 0 } add_args_to_cflags() { while test "$#" -ge 1 ; do add_arg_to_cflags $1 shift done } add_arg_to_ldflags() { AC_MSG_CHECKING([for LDFLAG $1]) LDFLAGS_ORI=$LDFLAGS LDFLAGS="$LDFLAGS -Werror $1" AC_RUN_IFELSE( [AC_LANG_PROGRAM([[]],[[]])], [LDFLAGS="$LDFLAGS_ORI $1";AC_MSG_RESULT([yes]);return 0], [AC_MSG_RESULT([no])], [AC_MSG_RESULT([no])]) LDFLAGS=$LDFLAGS_ORI return 1 } assert_arg_to_ldflags() { if ! add_arg_to_ldflags $1 ; then AC_MSG_RESULT([cannot add $1 to LDFLAGS]); exit 1 ; fi return 0 } add_args_to_ldflags() { while test "$#" -ge 1 ; do add_arg_to_ldflags $1 shift done } remove_arg_from_ldflags() { NEW_LDFLAGS="" for i in $LDFLAGS; do if ! test "$i" = "$1" ; then NEW_LDFLAGS="$NEW_LDFLAGS $i" else AC_MSG_RESULT([removing $1 from LDFLAGS]) fi done LDFLAGS=$NEW_LDFLAGS return 0 } add_args_to_cflags -fsigned-char -pipe -fcommon \ -fno-builtin-malloc -fno-builtin-free \ -fno-PIE -fno-pie -fno-PIC -fno-pic \ -Wall \ -Wno-builtin-requires-header -Wno-empty-body -Wno-self-assign \ -Wno-unused-but-set-variable add_args_to_ldflags -no-pie # -Wl,-z,lazy AC_MSG_CHECKING([for inline semantics]) AC_COMPILE_IFELSE( [AC_LANG_SOURCE([[ inline int foo(int i) {return i;} int bar(int i) {return foo(i);} ]])], [if `nm conftest.o |grep foo |awk '{if (NF==3) exit(-1)}'` ; then AC_MSG_RESULT([new]) else AC_COMPILE_IFELSE( [AC_LANG_SOURCE([[ extern inline int foo(int i) {return i;} int bar(int i) {return foo(i);} ]])], [if `nm conftest.o |grep foo |awk '{if (NF==3) exit(-1)}'` ; then AC_MSG_RESULT([old]) AC_DEFINE([OLD_INLINE],[1],[extern inline semantics]) else AC_MSG_ERROR([need working inline semantics]) fi], [AC_MSG_ERROR([need to probe inline semantics])]) fi], [AC_MSG_ERROR([need to probe inline semantics])]) AC_MSG_CHECKING([for clang]) AC_RUN_IFELSE( [AC_LANG_PROGRAM([[ #ifdef __clang__ #define RET 0 #else #define RET 1 #endif ]], [[ return RET; ]])], [AC_MSG_RESULT([yes]) clang="yes" remove_arg_from_ldflags -pie AC_DEFINE([CLANG],[1],[running clang compiler])], [AC_MSG_RESULT([no])]) case $use in *mingw*) assert_arg_to_cflags -fno-zero-initialized-in-bss assert_arg_to_cflags -mms-bitfields for i in makedefc windows/gcl.iss windows/sysdir.bat windows/install.lsp h/gclincl.h; do cat $i.in | sed 's,[^\r]\n$,\r\n,g' >tmp && mv tmp $i.in; done OLD_LDFLAGS=$LDFLAGS assert_arg_to_ldflags -pg GPL_FLAG="-pg" LDFLAGS=$OLD_LDFLAGS;; *gnuwin*) assert_arg_to_cflags -fno-zero-initialized-in-bss assert_arg_to_cflags -mms-bitfields assert_arg_to_ldflags -Wl,--stack,8000000 OLD_LDFLAGS=$LDFLAGS assert_arg_to_ldflags -pg GPL_FLAG="-pg" LDFLAGS=$OLD_LDFLAGS;; 386-macosx) # assert_arg_to_cflags -Wno-error=implicit-function-declaration add_arg_to_cflags -Wno-incomplete-setjmp-declaration assert_arg_to_ldflags -Wl,-no_pie if test "$build_cpu" = "x86_64" ; then assert_arg_to_cflags -m64 assert_arg_to_ldflags -m64 assert_arg_to_ldflags -Wl,-headerpad,72 else assert_arg_to_cflags -m32 assert_arg_to_ldflags -m32 assert_arg_to_ldflags -Wl,-headerpad,56 fi;; FreeBSD) assert_arg_to_ldflags -Z;; esac if test "$enable_static" = "yes" ; then assert_arg_to_ldflags -static assert_arg_to_ldflags -Wl,-zmuldefs AC_DEFINE(STATIC_LINKING,1,[staticly linked images]) fi TO3FLAGS="" TO2FLAGS="" TOSFLAGS="" 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]) GCL_CC_ARGS=`echo $CC | ${AWK} '{$1="";print}'` GCL_CC="`basename $CC` $GCL_CC_ARGS" if echo $GCL_CC |grep gcc |grep -q win; then GCL_CC=gcc fi AC_SUBST(GCL_CC) GPROF="gprof_objs" AC_ARG_ENABLE([gprof],[ --enable-gprof builds gcl with -pg in CFLAGS to enable profiling with gprof], [if test "$enableval" != "yes" ; then GPROF=""; fi]) if test "$GPROF" != "" ; then AC_MSG_CHECKING([working gprof]) case $use in powerpc*) if test "$host_cpu" = "powerpc64le" ; then GPROF=""; fi;; s390*) GPROF="";;#mcount smashes float args in make_shortfloat 20180313 sh4*) GPROF="";; m68k*) GPROF="";; ia64*) GPROF="";; hppa*) GPROF="";; arm*) if echo $canonical |grep -q hf$; then GPROF=""; fi;;#FIXME CALL and JUMP24 veneers needed for thumb 20190201 #FIXME mcount compiled as a 24/22 bit reloc even with -mlong-calls, marginally accessible aarch64*) GPROF="";;#unreproducible buildd bug 20170824 *gnu) GPROF="";; esac if test "$GPROF" = "" ; then AC_MSG_RESULT([disabled]) else AC_MSG_RESULT([ok]) OLD_CFLAGS=$CFLAGS # Do not run configure tests with -pg assert_arg_to_cflags -pg CFLAGS=$OLD_CFLAGS fi fi AC_SUBST(GPROF) if test "$enable_debug" = "yes" ; then assert_arg_to_cflags -g # for subconfigurations CFLAGS="$CFLAGS -g" else TOSFLAGS="-O2" # "-Os $TFPFLAG" 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) assert_arg_to_cflags -mlongcall;; *linux) case $use in alpha*) assert_arg_to_cflags -mieee # if test "$enable_debug" != "yes" ; then TO3FLAGS="-O0" ; fi #FIXME needed asof gcc 4.8.1 ;; aarch64*) TLIBS="$TLIBS -lgcc_s";; hppa*) assert_arg_to_cflags -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 ;; mips*) case $canonical in mips64*linux*) # assert_arg_to_cflags -mxgot assert_arg_to_ldflags -Wl,-z,now;; esac ;; ia64*) if test "$enable_debug" != "yes" ; then TO3FLAGS="-O" ; fi #FIXME needed asof gcc 4.8.1 ;; arm*) AC_DEFINE([SET_STACK_POINTER],["mov %%sp,%0\n\t"],[asm string to set the stack pointer]) AC_MSG_CHECKING([how to set stack pointer]) AC_MSG_RESULT([done]) assert_arg_to_cflags -fdollars-in-identifiers assert_arg_to_cflags -g #? ;; powerpc*) assert_arg_to_cflags -mlongcall if test "$host_cpu" != "powerpc64le" ; then assert_arg_to_cflags -mno-pltseq; fi ;; esac;; esac if test "$enable_pic" = "yes" ; then assert_arg_to_cflags -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'` TOSFLAGS=`echo $TOSFLAGS | 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'` TOSFLAGS=`echo $TOSFLAGS | 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'` TOSFLAGS=`echo "$TOSFLAGS" | 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'` TOSFLAGS=`echo $TOSFLAGS | sed 's,\-fomit-frame-pointer,,g'` fi if test "$FOMITF" != "" ; then TO3FLAGS="$TO3FLAGS $FOMITF" 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_CHECK_PROGS(MAKEINFO,makeinfo,"false") AC_SUBST(MAKEINFO) AC_MSG_CHECKING([system version (for dynamic loading)]) if machine=`uname -m` ; then true; else machine=unknown ; fi 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 (cannot 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_PROGRAM( [[ #include #include ]], [[ FILE *fp=fopen("conftest1","w"); fprintf(fp,"%lu\n",sizeof(jmp_buf)); fclose(fp); ]])], [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]) hz=0 AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #include #include ]], [[ FILE *fp=fopen("conftest1","w"); fprintf(fp,"%lu\n",sysconf(_SC_CLK_TCK)); fclose(fp); ]], [hz=`cat conftest1` AC_DEFINE_UNQUOTED(HZ,$hz,[time system constant])])]) AC_MSG_RESULT($hz)])]) rm -f makedefsafter AC_ARG_ENABLE([dynsysgmp], [ --enable-dynsysgmp will link against the system libgmp3 overriding certain functions with patched versions from the local source]) if test "$enable_dynsysgmp" != "no" ; then AC_CHECK_HEADERS( [gmp.h], [AC_CHECK_LIB( [gmp],[__gmpz_init], [AC_MSG_CHECKING([for external gmp version]) AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #include ]], [[ #if __GNU_MP_VERSION > 3 return 0; #else return -1; #endif ]])], [AC_MSG_RESULT([good]) 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])])]) if test "$MP_INCLUDE" = "" ; then AC_MSG_RESULT([Cannot use dynamic gmp lib]) fi fi if test "$MP_INCLUDE" = "" ; then GMPDIR=gmp4 AC_MSG_CHECKING([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 --host=$host --build=$build && 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);d=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 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); ]])],[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 AC_MSG_CHECKING([for GNU ld option -Map]) touch map foo.c $CC -o foo [ -Wl,-Map ] map foo.c >/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 # # X windows # if test "$enable_xgcl" = "yes" ; then AC_PATH_X AC_CHECK_LIB(X11,main, [X_LIBS="$X_LIBS -lX11" AC_DEFINE(HAVE_XGCL,1,[using xgcl])], [AC_MSG_RESULT([missing x libraries -- cannot compile xgcl])]) fi AC_SUBST(X_LIBS) AC_SUBST(X_CFLAGS) # # Dynamic loading # if test "$enable_dlopen" = "yes" ; then AC_CHECK_LIB([dl],[dlopen],,AC_MSG_ERROR([Cannot find dlopen])) TLIBS="$TLIBS -ldl -rdynamic" assert_arg_to_cflags -fPIC 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([need to define CONST for bfd]) AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #define IN_GCC #include ]], [[ symbol_info t; ]])], AC_MSG_RESULT([no]), AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #define CONST const #define IN_GCC #include ]], [[ symbol_info t; ]])], 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;} ]], [[]])], [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 AC_ARG_ENABLE([xdr],[ --enable-xdr=yes will compile in support for XDR]) if test "$enable_xdr" != "no" ; then XDR_LIB="" AC_CHECK_FUNC([xdr_double],XDR_LIB=" ", [AC_CHECK_LIB([tirpc],[xdr_double],[XDR_LIB=tirpc], [AC_CHECK_LIB([gssrpc],[xdr_double],[XDR_LIB=gssrpc], [AC_CHECK_LIB([rpc],[xdr_double],[XDR_LIB=rpc], [AC_CHECK_LIB([oncrpc],[xdr_double],[XDR_LIB=oncrpc])])])])]) if test "$XDR_LIB" != ""; then AC_DEFINE(HAVE_XDR,1,[have xdr extensions]) if test "$XDR_LIB" != " "; then TLIBS="$TLIBS -l$XDR_LIB" add_arg_to_cflags -I/usr/include/$XDR_LIB fi fi fi AC_MSG_CHECKING([__builtin_clzl]) AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #include #include ]], [[ 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; ]])], [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_PROGRAM( [[ #include #include ]], [[ 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); ]])], [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 #include #include #define EXTER #define INLINE #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 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))); ]])],[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)); ]])], [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]) AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #include #include #include #define EXTER #define INLINE #include "$MP_INCLUDE" #include "h/enum.h" #include "h/type.h" #include "h/lu.h" #include "h/object.h" ]], [[ FILE *f=fopen("conftest1","w"); fprintf(f,"%u",sizeof(struct contblock)); fclose(f); ]])], [sizeof_contblock=`cat conftest1`], [AC_MSG_ERROR([Cannot find sizeof struct contblock])], [AC_MSG_ERROR([Cannot find sizeof struct contblock])]) 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_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #include #include ]], [[ FILE *f; if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%p",sbrk(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); ]])], [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); ]])], [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); ]])], [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 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]) SBRK=0 AC_RUN_IFELSE( [AC_LANG_SOURCE( [[ #include #include 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,"%p",sbrk(0)); return 0; } ]])],[SBRK=`cat conftest1`]) if test "$SBRK" = "0" ; then AC_MSG_ERROR([cannot trap sbrk]) fi SBRK1=0 AC_RUN_IFELSE( [AC_LANG_SOURCE( [[ #include #include 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,"%p",sbrk(0)); return 0; } ]])],[SBRK1=`cat conftest1`]) if test "$SBRK1" = "0" ; then AC_MSG_ERROR([cannot trap sbrk]) 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" AC_MSG_ERROR([exiting]) fi fi AC_MSG_CHECKING(CSTACK_DIRECTION) AC_RUN_IFELSE( [AC_LANG_SOURCE( [[ #include #include int main(int argc,char **argv,char **envp) { FILE *fp = fopen("conftest1","w"); #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif fprintf(fp,"%d",(alloca(sizeof(void *))>alloca(sizeof(void *))) ? -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) AC_MSG_CHECKING([finding CSTACK_ALIGNMENT]) AC_RUN_IFELSE( [AC_LANG_SOURCE( [[ #include #include 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_ARG_ENABLE([cstackmax],[ --enable-cstackmax=xxxx will ensure that the cstack begins below xxxx or fail], [if test "$enableval" != "" ; then AC_DEFINE_UNQUOTED([CSTACKMAX],$enableval,[cstack max]) fi]) AC_MSG_CHECKING(CSTACK_ADDRESS) AC_RUN_IFELSE( [AC_LANG_SOURCE( [[ #include #include int main(int argc,char **argv,char **envp) { 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)alloca(sizeof(void *)); if ($cstack_direction==1) 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 int main(int argc,char **argv,char **envp) { void *v ; FILE *fp = fopen("conftest1","w"); long i,j; #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif j=1; j<<=$PAGEWIDTH; j<<=16; i=(long)&v; if ($cstack_direction==1) i-=j; j--; i+=j; i&=~j; for (j=0;(i>>j)!=(i>>(sizeof(long)*8-1));j++); fprintf(fp,"%ld",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 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_ARG_ENABLE([immfix],[ --enable-immfix will enable an immediate fixnum table above the C stack]) AC_ARG_ENABLE([fastimmfix],[ --enable-fastimmfix=XXXX will reject low immediate fixnums unless 2^XXX can be attained],,[enable_fastimmfix=64]) 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 $LDFLAGS -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_CHECKING([output_arch]) output_arch=`cat gcl.script |grep OUTPUT_ARCH|head -n 1|sed 's,.*(\(.*\)).*,\1,1'|cut -f1 -d:`; if test "$output_arch" != "" ; then AC_DEFINE_UNQUOTED(OUTPUT_ARCH,bfd_arch_${output_arch},[bfd output arch]) AC_MSG_RESULT([bfd_arch_${output_arch}]) else AC_MSG_RESULT([not found]) fi 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 $LDFLAGS -Wl,-T gcl.script foo.c -o foo >/dev/null 2>&1 && ./foo >/dev/null 2>&1 ) >/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 assert_arg_to_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_DEFINE_UNQUOTED(OBJNULL,NULL,[lowest address non-object]) AC_MSG_RESULT([not found]) fi else AC_DEFINE_UNQUOTED(OBJNULL,NULL,[lowest address non-object]) fi AC_DEFINE_UNQUOTED(CSSIZE,$enable_cssize,[maximum C stack size]) mem_top=0 mem_range=0 AC_MSG_CHECKING(mem top) AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #include ]], [[ unsigned long i,j,k,l; 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" != "no" ; then if test "$mem_top" != "0x0" ; then if test "$mem_range" != "0x0" ; then AC_DEFINE_UNQUOTED(IM_FIX_BASE,${mem_top}UL,[beginning address for immediate fixnum range]) AC_DEFINE_UNQUOTED(IM_FIX_LIM,${mem_range}UL,[size of immediate fixnum address space]) fi fi fi 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 #include ]], [[ struct dirent *d; DIR *r=opendir("./"); for (;(d=readdir(r)) && strcmp("configure",d->d_name);); return d && d->d_type==DT_REG ? 0 : -1; ]])], [AC_MSG_RESULT([yes]) AC_DEFINE(HAVE_D_TYPE,1,[have struct dirent d_type field])], AC_MSG_RESULT([no]),AC_MSG_RESULT([no]))) # # ParGCL # # ParGCL (includes MPINU) AC_ARG_ENABLE(pargcl, [ --enable-pargcl enables ParGCL (for parallel computing), including subset of MPI (see pargcl/doc/)], ,enable_pargcl="no") AC_ARG_WITH(mpicc, [ --with-mpicc=PATH define path to mpicc (default is built-in MPI subset)], , with_mpicc=no) # ansi lisp SYSTEM=ansi_gcl CLSTANDARD=ANSI AC_ARG_ENABLE([ansi],[ --enable-ansi builds a large gcl aiming for ansi compliance], [if test "$enable_ansi" = "no" ; then SYSTEM=gcl CLSTANDARD=CLtL1 fi]) if test "$enable_pargcl" != "no" ; then AC_MSG_CHECKING([enable_pargcl=yes, doing configure in pargcl directory]) if test -d pargcl; then PARGCLDIR=pargcl fi echo echo "#" echo "#" echo "# -------------------" echo "# Subconfigure of ParGCL" echo "#" echo "#" #SYSTEM is either gcl or ansi_gcl. This must come after def of SYSTEM PARGCL_GCLDIR=`pwd` ( cd $PARGCLDIR && ./configure --with-gcl=$PARGCL_GCLDIR/bin/$SYSTEM \ --with-gcl-build-dir=$PARGCL_GCLDIR --with-mpicc=$with_mpicc ) #MY_SUBDIRS="$MY_SUBDIRS $PARGCLDIR" echo "#" echo "#" echo "#" echo "# Subconfigure of ParGCL done" echo "# ------------------------" echo "#" AC_SUBST(PARGCLDIR) 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_FUNCS(rename) AC_CHECK_FUNC(uname, , AC_DEFINE(NO_UNAME,1,[no uname call])) AC_CHECK_FUNC(gettimeofday,, AC_DEFINE(NO_GETTOD,[1],[no gettimeofday call])) 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_EGREP_HEADER([gettimeofday], [sys/time.h], [AC_MSG_CHECKING([for gettimeofday declaration]) AC_MSG_RESULT([present])], [AC_MSG_CHECKING([for gettimeofday declaration]) AC_MSG_RESULT([missing]) AC_DEFINE(GETTOD_NOT_DECLARED,1,[No gettimeofday call -- fixme])]) if test "$use" != "mingw" ; then AC_CHECK_LIB(m,sin,LIBS="${LIBS} -lm",true) fi 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= AC_ARG_ENABLE([japi],[ --enable-japi=yes will compile in support for the JAPI graphical interface if present on your system], [if test "$enable_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]) # 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 of 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)])]) #-------------------------------------------------------------------- # 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"])) # readline AC_ARG_ENABLE(readline,[ --enable-readline enables command line completion via the readline library ]) if test "$use" = "mingw" ; then enable_readline=no fi if test "$enable_readline" != "no" ; then AC_CHECK_HEADERS([readline/readline.h], AC_CHECK_LIB([readline],[rl_initialize], [AC_DEFINE(USE_READLINE,1,[use readline library]) AC_CHECK_LIB([readline],[el_getc],AC_DEFINE(READLINE_IS_EDITLINE,1,[readline is editline])) # 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])]) AC_MSG_CHECKING([RL_COMPLETION_ENTRY_FUNCTION_TYPE_FUNCTION]) AC_COMPILE_IFELSE( [AC_LANG_PROGRAM( [[ #include extern Function *rl_completion_entry_function __attribute__((weak)); ]], [[]])], [AC_DEFINE(RL_COMPLETION_ENTRY_FUNCTION_TYPE_FUNCTION,1,[rl_completion_entry_function returns type Function]) AC_MSG_RESULT([yes])], [AC_MSG_RESULT([no]) AC_MSG_CHECKING([RL_COMPLETION_ENTRY_FUNCTION_TYPE_RL_COMPENTRY_FUNC_T]) AC_COMPILE_IFELSE( [AC_LANG_PROGRAM( [[ #include extern rl_compentry_func_t *rl_completion_entry_function __attribute__((weak)); ]], [[]])], [AC_DEFINE(RL_COMPLETION_ENTRY_FUNCTION_TYPE_RL_COMPENTRY_FUNC_T,1,[rl_completion_entry_function returns type rl_compentry_func_t]) AC_MSG_RESULT([yes])], [AC_MSG_RESULT([no]) AC_MSG_ERROR([Unknown rl_completion_entry_function return type])])]) AC_MSG_CHECKING([RL_READLINE_NAME_TYPE_CHAR]) AC_COMPILE_IFELSE( [AC_LANG_PROGRAM( [[ #include extern char *rl_readline_name __attribute__((weak)); ]], [[]])], [AC_DEFINE(RL_READLINE_NAME_TYPE_CHAR,1,[rl_readline_name returns type char]) AC_MSG_RESULT([yes])], [AC_MSG_RESULT([no]) AC_MSG_CHECKING([RL_READLINE_NAME_TYPE_CONST_CHAR]) AC_COMPILE_IFELSE( [AC_LANG_PROGRAM( [[ #include extern const char *rl_readline_name __attribute__((weak)); ]], [[]])], [AC_DEFINE(RL_READLINE_NAME_TYPE_CONST_CHAR,1,[rl_readline_name returns type const char]) AC_MSG_RESULT([yes])], [AC_MSG_RESULT([no]) AC_MSG_ERROR([Unknown rl_readline_name return type])])]) TLIBS="$TLIBS -lreadline" #some machines don't link this, e.g. Slackware RL_OBJS=gcl_readline]), [],[AC_INCLUDES_DEFAULT([#include ])]) fi AC_SUBST(RL_OBJS) AC_SUBST(RL_LIB) # sockets AC_MSG_CHECKING([For network code for nsocket.c]) AC_LINK_IFELSE( [AC_LANG_PROGRAM( [[ #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_COMPILE_IFELSE( [AC_LANG_PROGRAM( [[ #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) 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_COMPILE_IFELSE( [AC_LANG_PROGRAM( [[ #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_COMPILE_IFELSE( [AC_LANG_PROGRAM( [[ #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_COMPILE_IFELSE( [AC_LANG_PROGRAM( [[ #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_COMPILE_IFELSE( [AC_LANG_PROGRAM( [[ #include ]], [[ struct sigcontext foo; ]])], [AC_DEFINE(SIGNAL_H_HAS_SIGCONTEXT,1,[have sigcontext of signal.h]) AC_MSG_RESULT([sigcontext of signal.h])], [AC_MSG_RESULT([sigcontext NOT of signal.h]) AC_MSG_CHECKING([for sigcontext...]) AC_COMPILE_IFELSE( [AC_LANG_PROGRAM( [[ #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 asm files)], [AC_MSG_RESULT([no sigcontext found])])]) 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) AC_ARG_ENABLE([tcltk],[ --enable-tcltk will try to build gcl-tk]) 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]) if test "$enable_tcltk" != "no" ; then 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 <, Wed Dec 14 18:55:19 2005 gcl27-2.7.0/debian/changelog000066400000000000000000004070131454061450500155430ustar00rootroot00000000000000gcl27 (2.7.0-1) unstable; urgency=medium * New upstream release -- Camm Maguire Thu, 14 Dec 2023 16:20:45 -0500 gcl (2.6.13-5) unstable; urgency=medium * Version_2_6_14pre4 -- Camm Maguire Sun, 25 Dec 2022 07:14:33 -0500 gcl (2.6.13-4) unstable; urgency=medium * Version_2_6_14pre3 -- Camm Maguire Fri, 23 Dec 2022 11:34:35 -0500 gcl (2.6.13-3) unstable; urgency=medium * Version_2_6_14pre2 -- Camm Maguire Thu, 22 Dec 2022 19:09:24 -0500 gcl (2.6.13-2) unstable; urgency=medium * Version_2_6_14pre1 -- Camm Maguire Wed, 21 Dec 2022 14:40:21 -0500 gcl (2.6.13-1) unstable; urgency=medium * New Upstream Release -- Camm Maguire Tue, 20 Dec 2022 10:35:44 -0500 gcl (2.6.12-131) unstable; urgency=medium * Version_2.6.13pre131 -- Camm Maguire Sat, 17 Dec 2022 12:15:58 -0500 gcl (2.6.12-130) unstable; urgency=medium * Version_2.6.13pre130 -- Camm Maguire Fri, 16 Dec 2022 12:41:29 -0500 gcl (2.6.12-129) unstable; urgency=medium * Version_2.6.13pre129 -- Camm Maguire Sun, 13 Nov 2022 07:55:14 -0500 gcl (2.6.12-128) unstable; urgency=medium * Version_2.6.13pre128 -- Camm Maguire Sat, 12 Nov 2022 11:02:31 -0500 gcl (2.6.12-126) unstable; urgency=medium * Version_2.6.13pre126 -- Camm Maguire Tue, 08 Nov 2022 19:43:41 -0500 gcl (2.6.12-125) unstable; urgency=medium * Version_2.6.13pre125 -- Camm Maguire Tue, 08 Nov 2022 15:33:25 -0500 gcl (2.6.12-124) unstable; urgency=medium * Version_2.6.13pre124 -- Camm Maguire Thu, 11 Aug 2022 13:16:42 -0400 gcl (2.6.12-123) unstable; urgency=medium * Version_2.6.13pre123 -- Camm Maguire Mon, 08 Aug 2022 13:00:55 -0400 gcl (2.6.12-122) unstable; urgency=medium * Version_2.6.13pre122 -- Camm Maguire Mon, 08 Aug 2022 11:50:22 -0400 gcl (2.6.12-121) unstable; urgency=medium * Version_2.6.13pre121 -- Camm Maguire Mon, 08 Aug 2022 11:45:30 -0400 gcl (2.6.12-120) unstable; urgency=medium * Version_2.6.13pre120 -- Camm Maguire Sun, 07 Aug 2022 12:26:10 -0400 gcl (2.6.12-119) unstable; urgency=medium * Version_2.6.13pre119 -- Camm Maguire Sun, 31 Jul 2022 12:00:02 -0400 gcl (2.6.12-118) unstable; urgency=medium * Bug fix: "emacs dependency should be "emacs | emacsen"", thanks to Adrian Bunk (Closes: #1006617). * Bug fix: "Please remove dependency on install-info", thanks to hille42@web.de; (Closes: #1013691). * Version_2.6.13pre118 -- Camm Maguire Tue, 12 Jul 2022 17:17:09 -0400 gcl (2.6.12-117) unstable; urgency=medium * Version_2.6.13pre114 -- Camm Maguire Sat, 25 Dec 2021 11:38:16 -0500 gcl (2.6.12-116) unstable; urgency=medium * Version_2.6.13pre113 -- Camm Maguire Wed, 22 Dec 2021 19:52:18 +0000 gcl (2.6.12-115) unstable; urgency=medium * Version_2.6.13pre112 -- Camm Maguire Fri, 17 Dec 2021 16:08:45 +0000 gcl (2.6.12-114) unstable; urgency=medium * Version_2.6.13pre111 -- Camm Maguire Thu, 16 Dec 2021 11:35:04 +0000 gcl (2.6.12-113) unstable; urgency=medium * Version_2.6.13pre110 -- Camm Maguire Thu, 16 Dec 2021 11:35:04 +0000 gcl (2.6.12-112) unstable; urgency=medium * Version_2.6.13pre109 -- Camm Maguire Wed, 15 Dec 2021 19:39:42 +0000 gcl (2.6.12-111) unstable; urgency=medium * Version_2.6.13pre108 -- Camm Maguire Thu, 11 Nov 2021 17:10:43 +0000 gcl (2.6.12-110) unstable; urgency=medium * Version_2.6.13pre107 -- Camm Maguire Thu, 11 Nov 2021 01:34:07 +0000 gcl (2.6.12-109) unstable; urgency=medium * Version_2.6.13pre106 -- Camm Maguire Wed, 10 Nov 2021 18:57:21 +0000 gcl (2.6.12-108) unstable; urgency=medium * Version_2.6.13pre105 -- Camm Maguire Tue, 09 Nov 2021 18:22:58 +0000 gcl (2.6.12-107) unstable; urgency=medium * Version_2.6.13pre103 -- Camm Maguire Tue, 09 Nov 2021 10:10:19 +0000 gcl (2.6.12-106) unstable; urgency=medium * Version_2.6.13pre102 -- Camm Maguire Thu, 04 Nov 2021 14:33:53 +0000 gcl (2.6.12-105) unstable; urgency=medium * Version_2.6.13pre101 * Bug fix: "fails to start with glibc 2.33", thanks to Andreas Kloeckner (Closes: #995323). -- Camm Maguire Sun, 10 Oct 2021 13:18:39 +0000 gcl (2.6.12-104) unstable; urgency=medium * Version_2.6.13pre100 * standardize cstack start address on 32bit arm -- Camm Maguire Sun, 10 Oct 2021 12:44:51 +0000 gcl (2.6.12-103) unstable; urgency=medium * Bug fix: "Fails to install in unstable", thanks to Samuel Thibault (Closes: #993480). -- Camm Maguire Sat, 04 Sep 2021 19:23:26 +0000 gcl (2.6.12-102) unstable; urgency=medium * Version_2.6.13pre99 * Bug fix: "describe fails because gcl-si.info does not exist", thanks to Leo Butler (Closes: #980003). -- Camm Maguire Fri, 29 Jan 2021 19:08:05 +0000 gcl (2.6.12-101) unstable; urgency=medium * Version_2.6.13pre98 -- Camm Maguire Sun, 17 Jan 2021 16:25:34 +0000 gcl (2.6.12-100) unstable; urgency=medium * Version_2.6.13pre97 -- Camm Maguire Fri, 04 Dec 2020 14:51:41 +0000 gcl (2.6.12-99) unstable; urgency=medium * Version_2.6.13pre95 -- Camm Maguire Sat, 28 Nov 2020 15:50:42 +0000 gcl (2.6.12-98) unstable; urgency=medium * Version_2.6.13pre94 -- Camm Maguire Tue, 29 Sep 2020 18:29:10 +0000 gcl (2.6.12-97) unstable; urgency=medium * Bug fix: "Removal of obsolete debhelper compat 5 and 6 in bookworm", thanks to Niels Thykier (Closes: #965543). * Version_2.6.13pre93 -- Camm Maguire Sat, 29 Aug 2020 16:23:07 +0000 gcl (2.6.12-96) unstable; urgency=high * Version_2.6.13pre92: Work around armhf strip bug producing undefined instruction in .plt -- Camm Maguire Sun, 23 Aug 2020 17:53:14 +0000 gcl (2.6.12-95) unstable; urgency=high * Version_2_6_13pre90 * build under GCL_MEM_MULTIPLE=0.1 * Bug fix: "FTBFS: Unrecoverable error: Segmentation violation..", thanks to Lucas Nussbaum (Closes: #952334). -- Camm Maguire Fri, 01 May 2020 12:55:02 +0000 gcl (2.6.12-94) unstable; urgency=medium * re-release to overcome hopefully transient buildd failure -- Camm Maguire Mon, 24 Feb 2020 20:02:52 +0000 gcl (2.6.12-93) unstable; urgency=medium * Version_2_6_13pre90 -- Camm Maguire Fri, 21 Feb 2020 19:06:56 +0000 gcl (2.6.12-92) unstable; urgency=medium * Version_2_6_13pre89 -- Camm Maguire Mon, 30 Dec 2019 15:46:22 +0000 gcl (2.6.12-91) unstable; urgency=medium * Version_2_6_13pre88 -- Camm Maguire Wed, 18 Dec 2019 20:14:09 +0000 gcl (2.6.12-90) unstable; urgency=medium * Version_2_6_13pre87 * latest standards -- Camm Maguire Sun, 08 Dec 2019 19:27:24 +0000 gcl (2.6.12-89) unstable; urgency=medium * Bug fix: "gcl - FTBFS on ppc64el - invalid relocation type 31", thanks to thierry.fauck@fr.ibm.com; (Closes: #942312). * Bug fix: "FTBFS on ppc64el", thanks to Ivo De Decker (Closes: #944651). -- Camm Maguire Sat, 07 Dec 2019 23:27:53 +0000 gcl (2.6.12-88) unstable; urgency=medium * Source only upload -- Camm Maguire Fri, 11 Oct 2019 19:18:44 +0000 gcl (2.6.12-87) unstable; urgency=medium * Version_2_6_13pre84 -- Camm Maguire Sat, 06 Apr 2019 13:03:21 +0000 gcl (2.6.12-86) unstable; urgency=medium * Version_2_6_13pre83 -- Camm Maguire Tue, 02 Apr 2019 19:57:15 +0000 gcl (2.6.12-85) unstable; urgency=medium * Version_2_6_13pre82 -- Camm Maguire Thu, 28 Mar 2019 18:48:55 +0000 gcl (2.6.12-84) unstable; urgency=medium * Version_2_6_13pre80 -- Camm Maguire Thu, 21 Mar 2019 18:59:40 +0000 gcl (2.6.12-83) unstable; urgency=high * Version_2_6_13pre79 * Fix acl2 arm builds (Closes: #919477). -- Camm Maguire Tue, 05 Feb 2019 21:54:42 +0000 gcl (2.6.12-82) unstable; urgency=high * Version_2_6_13pre74 -- Camm Maguire Sat, 02 Feb 2019 17:40:20 +0000 gcl (2.6.12-81) unstable; urgency=high * Version_2_6_13pre72 * Fix to ppc64el for acl2 FTBFS bug -- Camm Maguire Mon, 21 Jan 2019 16:40:36 +0000 gcl (2.6.12-80) unstable; urgency=medium * Version_2_6_13pre71 * Bug fix: "FTBFS on hppa - segmentation fault assembling gbc.s", thanks to John David Anglin (Closes: #912071). -- Camm Maguire Tue, 30 Oct 2018 17:20:43 +0000 gcl (2.6.12-79) unstable; urgency=medium * Version_2_6_13pre70 -- Camm Maguire Mon, 29 Oct 2018 16:52:17 +0000 gcl (2.6.12-78) unstable; urgency=medium * rebuild against latest compilers and tools * Version_2_6_13pre69 -- Camm Maguire Thu, 11 Oct 2018 16:40:48 +0000 gcl (2.6.12-77) unstable; urgency=medium * Version_2_6_13pre68 * Bug fix: "GCL fails to load .o files it generates", thanks to Gong-Yi Liao (Closes: #902475). Add support for R_X86_64_PLT32 relocs. -- Camm Maguire Tue, 24 Jul 2018 20:06:45 +0000 gcl (2.6.12-76) unstable; urgency=medium * Version_2_6_13pre67 -- Camm Maguire Fri, 23 Mar 2018 19:25:22 +0000 gcl (2.6.12-75) unstable; urgency=medium * Version_2_6_13pre65 -- Camm Maguire Wed, 21 Mar 2018 20:28:08 +0000 gcl (2.6.12-74) unstable; urgency=medium * Version_2_6_13pre63 -- Camm Maguire Sat, 17 Mar 2018 11:56:05 +0000 gcl (2.6.12-73) unstable; urgency=medium * Version_2_6_13pre62 -- Camm Maguire Wed, 14 Mar 2018 15:38:43 +0000 gcl (2.6.12-72) unstable; urgency=medium * Version_2_6_13pre61 -- Camm Maguire Tue, 13 Mar 2018 15:32:44 +0000 gcl (2.6.12-71) unstable; urgency=medium * Version_2_6_13pre60 -- Camm Maguire Mon, 12 Mar 2018 19:44:47 +0000 gcl (2.6.12-70) unstable; urgency=medium * Version_2_6_13pre59 -- Camm Maguire Mon, 12 Mar 2018 16:19:00 +0000 gcl (2.6.12-69) unstable; urgency=medium * Version_2_6_13pre58 -- Camm Maguire Fri, 09 Mar 2018 17:10:51 +0000 gcl (2.6.12-68) unstable; urgency=medium * Version_2_6_13pre57 -- Camm Maguire Sun, 04 Mar 2018 13:21:00 +0000 gcl (2.6.12-67) unstable; urgency=medium * Version_2_6_13pre55 -- Camm Maguire Sat, 03 Mar 2018 14:27:51 +0000 gcl (2.6.12-66) unstable; urgency=medium * Version_2_6_13pre54 -- Camm Maguire Fri, 02 Mar 2018 21:19:03 +0000 gcl (2.6.12-65) unstable; urgency=medium * Version_2_6_13pre52 * Bug fix: "FTBFS on hurd-i386", thanks to svante.signell@gmail.com; (Closes: #802593). -- Camm Maguire Fri, 23 Feb 2018 15:55:23 +0000 gcl (2.6.12-64) unstable; urgency=medium * list_order.24 -- Camm Maguire Sun, 04 Feb 2018 13:26:27 +0000 gcl (2.6.12-63) unstable; urgency=medium * list_order.23 -- Camm Maguire Thu, 01 Feb 2018 18:36:29 +0000 gcl (2.6.12-62) unstable; urgency=medium * list_order.22 -- Camm Maguire Thu, 01 Feb 2018 01:05:10 +0000 gcl (2.6.12-61) unstable; urgency=medium * list_order.21 -- Camm Maguire Tue, 30 Jan 2018 21:13:13 +0000 gcl (2.6.12-60) unstable; urgency=medium * list_order.19 -- Camm Maguire Tue, 23 Jan 2018 18:11:59 +0000 gcl (2.6.12-59) unstable; urgency=medium * list_order.16 -- Camm Maguire Fri, 12 Jan 2018 03:25:08 +0000 gcl (2.6.12-58) unstable; urgency=medium * list_order.14 -- Camm Maguire Mon, 18 Sep 2017 15:45:10 +0000 gcl (2.6.12-57) unstable; urgency=medium * list_order.13 -- Camm Maguire Fri, 25 Aug 2017 13:44:10 +0000 gcl (2.6.12-56) unstable; urgency=medium * list_order.12 -- Camm Maguire Thu, 24 Aug 2017 19:12:50 +0000 gcl (2.6.12-55) unstable; urgency=medium * disable gprof on aarch64 * Bug fix: "gcl FTBFS on arm64: Unrecoverable error: Segmentation violation..", thanks to Adrian Bunk (Closes: #873052). -- Camm Maguire Thu, 24 Aug 2017 16:37:07 +0000 gcl (2.6.12-54) unstable; urgency=medium * list_order.11 -- Camm Maguire Wed, 23 Aug 2017 22:19:14 +0000 gcl (2.6.12-53) unstable; urgency=medium * list_order.9 -- Camm Maguire Sun, 18 Jun 2017 18:32:30 +0000 gcl (2.6.12-52) unstable; urgency=medium * list_order.8 -- Camm Maguire Thu, 15 Jun 2017 18:04:41 +0000 gcl (2.6.12-51) unstable; urgency=medium * list_order.7 -- Camm Maguire Wed, 14 Jun 2017 18:30:46 +0000 gcl (2.6.12-50) unstable; urgency=medium * list_order.6 -- Camm Maguire Tue, 13 Jun 2017 22:38:52 +0000 gcl (2.6.12-49) unstable; urgency=medium * list_order.5 -- Camm Maguire Thu, 08 Jun 2017 17:21:01 +0000 gcl (2.6.12-48) unstable; urgency=medium * list_order.1 -- Camm Maguire Sun, 28 May 2017 01:42:29 +0000 gcl (2.6.12-47) unstable; urgency=high * pathnames1.13 -- Camm Maguire Tue, 22 Nov 2016 04:53:35 +0000 gcl (2.6.12-46) unstable; urgency=high * pathnames1.12 * Bug fix: "maintainer script(s) do not start on #!", thanks to treinen@debian.org; (Closes: #843303). -- Camm Maguire Fri, 18 Nov 2016 18:27:53 +0000 gcl (2.6.12-45) unstable; urgency=high * pathnames1.11 -- Camm Maguire Mon, 31 Oct 2016 22:57:27 +0000 gcl (2.6.12-44) unstable; urgency=high * pathnames1.9 -- Camm Maguire Fri, 28 Oct 2016 17:04:38 +0000 gcl (2.6.12-43) unstable; urgency=medium * pathnames1.7 -- Camm Maguire Thu, 27 Oct 2016 03:46:32 +0000 gcl (2.6.12-42) unstable; urgency=medium * pathnames1.6 * Bug fix: "FTBFS with bindnow and PIE enabled", thanks to Balint Reczey (Closes: #837481). * Bug fix: "FTBFS with compilers that default to -fPIE (patch attached)", thanks to Adam Conrad (Closes: #822820). -- Camm Maguire Wed, 26 Oct 2016 23:04:57 +0000 gcl (2.6.12-41) unstable; urgency=medium * pathnames1.4, kfreebsd fix -- Camm Maguire Fri, 14 Oct 2016 01:17:18 +0000 gcl (2.6.12-40) unstable; urgency=medium * pathnames1.2 * Bug fix: "popen arguments not quoted causes trouble and security issues", thanks to axel (Closes: #802203). -- Camm Maguire Wed, 12 Oct 2016 18:09:26 +0000 gcl (2.6.12-39) unstable; urgency=medium * pathnames1.1 * ansi-test clean target -- Camm Maguire Wed, 12 Oct 2016 01:32:05 +0000 gcl (2.6.12-38) unstable; urgency=medium * Version_2_6_13pre50 -- Camm Maguire Tue, 04 Oct 2016 19:45:38 +0000 gcl (2.6.12-37) unstable; urgency=medium * Version_2_6_13pre49 -- Camm Maguire Mon, 03 Oct 2016 14:54:09 +0000 gcl (2.6.12-36) unstable; urgency=medium * Version_2_6_13pre48 -- Camm Maguire Sat, 01 Oct 2016 12:10:25 +0000 gcl (2.6.12-35) unstable; urgency=medium * Version_2_6_13pre47 -- Camm Maguire Fri, 30 Sep 2016 21:21:43 +0000 gcl (2.6.12-34) unstable; urgency=medium * Version_2_6_13pre45 -- Camm Maguire Fri, 23 Sep 2016 19:42:37 +0000 gcl (2.6.12-33) unstable; urgency=medium * Version_2_6_13pre43 -- Camm Maguire Tue, 03 May 2016 16:17:03 +0000 gcl (2.6.12-32) unstable; urgency=medium * Version_2_6_13pre40 * Bug fix: "[INTL:pt_BR] Brazilian Portuguese debconf templates translation", thanks to Adriano Rafael Gomes (Closes: #811523). -- Camm Maguire Wed, 20 Apr 2016 15:18:35 +0000 gcl (2.6.12-31) unstable; urgency=medium * Version_2_6_13pre39 -- Camm Maguire Mon, 11 Apr 2016 00:41:11 +0000 gcl (2.6.12-30) unstable; urgency=medium * Version_2_6_13pre38 -- Camm Maguire Wed, 06 Apr 2016 00:20:15 +0000 gcl (2.6.12-29) unstable; urgency=medium * Version_2_6_13pre35; support latest binutils * Bug fix: "gcl ftbfs on amd64 and i386 with binutils from experimental", thanks to Matthias Klose (Closes: #803214). -- Camm Maguire Thu, 29 Oct 2015 15:20:27 +0000 gcl (2.6.12-28) unstable; urgency=medium * Version_2_6_13pre35; restore hppa build -- Camm Maguire Tue, 27 Oct 2015 20:00:46 +0000 gcl (2.6.12-27) unstable; urgency=medium * Version_2_6_13pre34; mips64 relocs; stack saving tail-recursive equal. -- Camm Maguire Tue, 27 Oct 2015 16:35:06 +0000 gcl (2.6.12-26) unstable; urgency=medium * Version_2_6_13pre32 -- Camm Maguire Fri, 23 Oct 2015 00:03:34 +0000 gcl (2.6.12-25) unstable; urgency=medium * Version_2_6_13pre31, kfreebsd and mips64 FTBFS fix -- Camm Maguire Fri, 16 Oct 2015 15:03:03 +0000 gcl (2.6.12-24) unstable; urgency=medium * Version_2_6_13pre30 -- Camm Maguire Fri, 16 Oct 2015 02:44:23 +0000 gcl (2.6.12-23) unstable; urgency=medium * Version_2_6_13pre29 -- Camm Maguire Thu, 15 Oct 2015 18:09:59 +0000 gcl (2.6.12-22) unstable; urgency=medium * Version_2_6_13pre27 -- Camm Maguire Tue, 13 Oct 2015 14:38:53 +0000 gcl (2.6.12-21) unstable; urgency=medium * Version_2_6_13pre26 -- Camm Maguire Wed, 07 Oct 2015 15:14:27 +0000 gcl (2.6.12-20) unstable; urgency=medium * Version_2_6_13pre25 -- Camm Maguire Thu, 01 Oct 2015 15:16:14 +0000 gcl (2.6.12-19) unstable; urgency=medium * Use-dpkg-buidflags-opt-levels-in-debian-rules, -O3 has bug in 5.2.1 * Version_2_6_13pre24 -- Camm Maguire Wed, 30 Sep 2015 15:45:20 +0000 gcl (2.6.12-18) unstable; urgency=medium * Version_2_6_13pre22 -- Camm Maguire Tue, 29 Sep 2015 16:51:03 +0000 gcl (2.6.12-17) unstable; urgency=medium * Version_2_6_13pre20 -- Camm Maguire Sat, 26 Sep 2015 10:34:23 -0400 gcl (2.6.12-16) unstable; urgency=medium * Version_2_6_13pre19 -- Camm Maguire Fri, 25 Sep 2015 18:39:52 -0400 gcl (2.6.12-15) unstable; urgency=medium * Version_2_6_13pre18 -- Camm Maguire Fri, 25 Sep 2015 15:08:50 +0000 gcl (2.6.12-14) unstable; urgency=medium * Version_2_6_13pre17 -- Camm Maguire Thu, 28 May 2015 03:37:47 +0000 gcl (2.6.12-13) unstable; urgency=medium * Version_2_6_13pre16 -- Camm Maguire Fri, 15 May 2015 18:09:38 +0000 gcl (2.6.12-12) unstable; urgency=medium * Version_2_6_13pre13 -- Camm Maguire Fri, 01 May 2015 11:08:46 -0400 gcl (2.6.12-11) unstable; urgency=medium * Version_2_6_13pre12 -- Camm Maguire Thu, 30 Apr 2015 12:49:16 -0400 gcl (2.6.12-10) unstable; urgency=medium * rebuild in clean sid environment -- Camm Maguire Mon, 27 Apr 2015 15:34:15 -0400 gcl (2.6.12-9) unstable; urgency=medium * Version_2_6_13pre8b * Bug fix: "ftbfs with GCC-5", thanks to Matthias Klose (Closes: #777866). -- Camm Maguire Mon, 27 Apr 2015 12:32:49 -0400 gcl (2.6.12-8) unstable; urgency=medium * Version_2_6_13pre7 -- Camm Maguire Fri, 24 Apr 2015 13:38:30 -0400 gcl (2.6.12-7) unstable; urgency=medium * Version_2_6_13pre6 -- Camm Maguire Thu, 23 Apr 2015 13:43:45 -0400 gcl (2.6.12-6) unstable; urgency=medium * Version_2_6_13pre5 -- Camm Maguire Wed, 22 Apr 2015 17:14:16 -0400 gcl (2.6.12-5) unstable; urgency=medium * Version_2_6_13pre4 -- Camm Maguire Wed, 22 Apr 2015 10:25:36 -0400 gcl (2.6.12-4) unstable; urgency=medium * Version_2_6_13pre3a -- Camm Maguire Mon, 20 Apr 2015 13:26:36 -0400 gcl (2.6.12-3) unstable; urgency=medium * Version_2_6_13pre2 -- Camm Maguire Fri, 17 Apr 2015 15:50:37 -0400 gcl (2.6.12-2) unstable; urgency=medium * Version_2_6_13pre1 -- Camm Maguire Wed, 26 Nov 2014 11:12:46 -0500 gcl (2.6.12-1) unstable; urgency=medium * New upstream release -- Camm Maguire Tue, 28 Oct 2014 09:56:15 -0400 gcl (2.6.11-6) unstable; urgency=medium * 2.6.12pre5 -- Camm Maguire Thu, 23 Oct 2014 17:33:22 -0400 gcl (2.6.11-5) unstable; urgency=medium * 2.6.12pre4 -- Camm Maguire Sat, 18 Oct 2014 09:46:34 -0400 gcl (2.6.11-4) unstable; urgency=medium * 2.6.12pre3 -- Camm Maguire Thu, 16 Oct 2014 11:56:15 -0400 gcl (2.6.11-3) unstable; urgency=medium * 2.6.12pre2 -- Camm Maguire Sun, 28 Sep 2014 20:56:18 -0400 gcl (2.6.11-2) unstable; urgency=medium * 2.6.12pre1 -- Camm Maguire Fri, 19 Sep 2014 14:49:25 -0400 gcl (2.6.11-1) unstable; urgency=medium * New upstream release -- Camm Maguire Sat, 06 Sep 2014 12:28:46 -0400 gcl (2.6.10-54) unstable; urgency=medium * remove-debug-message-from-BUGGY_MAXIMUM_SSCANF_LENGTH-code -- Camm Maguire Fri, 05 Sep 2014 10:35:46 -0400 gcl (2.6.10-53) unstable; urgency=medium * ppc64le-support-headers -- Camm Maguire Wed, 03 Sep 2014 15:02:12 -0400 gcl (2.6.10-52) unstable; urgency=medium * accept-TMP-paths-with-types-versions -- Camm Maguire Fri, 29 Aug 2014 17:51:04 -0400 gcl (2.6.10-51) unstable; urgency=medium * fix-match-function-proclaim-skew -- Camm Maguire Fri, 29 Aug 2014 16:40:30 +0000 gcl (2.6.10-50) unstable; urgency=medium * trial_selinux_support -- Camm Maguire Thu, 21 Aug 2014 17:29:50 +0000 gcl (2.6.10-49) unstable; urgency=medium * R_ARM_JUMP24 -- Camm Maguire Wed, 20 Aug 2014 17:08:23 +0000 gcl (2.6.10-48) unstable; urgency=medium * try-SGC-for-aarch64 -- Camm Maguire Tue, 19 Aug 2014 18:35:22 +0000 gcl (2.6.10-47) unstable; urgency=medium * set-stack_guard-after-alloc-setup * Bug fix: "work around build failure on AArch64", thanks to Matthias Klose (Closes: #758101). -- Camm Maguire Thu, 14 Aug 2014 19:36:48 +0000 gcl (2.6.10-46) unstable; urgency=medium * R_AARCH64_LDST128_ABS_LO12_NC -- Camm Maguire Wed, 13 Aug 2014 21:39:50 +0000 gcl (2.6.10-45) unstable; urgency=medium * fix sh4 CLEAR_CACHE -- Camm Maguire Sun, 10 Aug 2014 20:12:03 +0000 gcl (2.6.10-44) unstable; urgency=medium * clear_protect_memory on all elf machines -- Camm Maguire Sat, 09 Aug 2014 00:55:17 +0000 gcl (2.6.10-43) unstable; urgency=medium * mips uses builtin_clear_cache like mipsel -- Camm Maguire Fri, 08 Aug 2014 23:42:42 +0000 gcl (2.6.10-42) unstable; urgency=medium * backport travel_push_new from master -- Camm Maguire Wed, 06 Aug 2014 20:14:14 +0000 gcl (2.6.10-41) unstable; urgency=medium * protos and CFLAGS for axiom extensions -- Camm Maguire Wed, 06 Aug 2014 01:54:38 +0000 gcl (2.6.10-40) unstable; urgency=medium * better solaris unexec fix -- Camm Maguire Mon, 04 Aug 2014 22:00:54 +0000 gcl (2.6.10-39) unstable; urgency=medium * earlier prelink_init, phys_pages w/o malloc -- Camm Maguire Mon, 04 Aug 2014 16:52:09 +0000 gcl (2.6.10-38) unstable; urgency=medium * error on overflow of array dimensions -- Camm Maguire Fri, 01 Aug 2014 14:35:44 +0000 gcl (2.6.10-37) unstable; urgency=medium * FILE * casts for windows feof wrapper -- Camm Maguire Thu, 31 Jul 2014 02:17:11 +0000 gcl (2.6.10-36) unstable; urgency=medium * better casts for frs_jmpbuf -- Camm Maguire Wed, 30 Jul 2014 17:00:06 +0000 gcl (2.6.10-35) unstable; urgency=medium * find_sym_ptable typo fix -- Camm Maguire Tue, 29 Jul 2014 18:08:57 +0000 gcl (2.6.10-34) unstable; urgency=medium * --enable-prelink configure arg; stack_chk_guard for 68k -- Camm Maguire Fri, 25 Jul 2014 20:39:10 +0000 gcl (2.6.10-33) unstable; urgency=medium * hurd stack_guard, ppc64 C_GC_OFFSET -- Camm Maguire Thu, 24 Jul 2014 21:46:24 +0000 gcl (2.6.10-32) unstable; urgency=medium * __stack_chk_guard fix for arm/sh4 -- Camm Maguire Wed, 23 Jul 2014 18:12:56 +0000 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 gcl27-2.7.0/debian/compat000066400000000000000000000000031454061450500150630ustar00rootroot0000000000000013 gcl27-2.7.0/debian/control000066400000000000000000000027561454061450500153010ustar00rootroot00000000000000Source: gcl27 Section: lisp Priority: optional Maintainer: Camm Maguire Homepage: http://gnu.org/software/gcl Build-Depends: debhelper (>= 13), libeditreadline-dev, m4, tk8.6-dev, libgmp-dev, libxmu-dev, libxaw7-dev, po-debconf, zlib1g-dev, tcl, gcc-11 Standards-Version: 4.5.0 Package: gcl27 Architecture: any Depends: ${shlibs:Depends}, ${misc:Depends}, ${gcc}, debconf (>= 1.2.0), emacs | emacsen, ucf Breaks: emacsen-common (<< 2.0.0) Suggests: gcl27-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: gcl27-doc Section: doc Architecture: all Conflicts: gclinfo Replaces: gclinfo Depends: dpkg (>= 1.15.4), ${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. gcl27-2.7.0/debian/control_000066400000000000000000000027461454061450500154370ustar00rootroot00000000000000Source: gcl Section: lisp Priority: optional Maintainer: Camm Maguire Homepage: http://gnu.org/software/gcl Build-Depends: debhelper (>= 13), libeditreadline-dev, m4, tk8.6-dev, libgmp-dev, libxmu-dev, libxaw7-dev, po-debconf, zlib1g-dev, tcl, gcc-11 Standards-Version: 4.5.0 Package: gcl Architecture: any Depends: ${shlibs:Depends}, ${misc:Depends}, ${gcc}, debconf (>= 1.2.0), emacs | 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), ${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. gcl27-2.7.0/debian/control_27000066400000000000000000000027561454061450500156110ustar00rootroot00000000000000Source: gcl27 Section: lisp Priority: optional Maintainer: Camm Maguire Homepage: http://gnu.org/software/gcl Build-Depends: debhelper (>= 13), libeditreadline-dev, m4, tk8.6-dev, libgmp-dev, libxmu-dev, libxaw7-dev, po-debconf, zlib1g-dev, tcl, gcc-11 Standards-Version: 4.5.0 Package: gcl27 Architecture: any Depends: ${shlibs:Depends}, ${misc:Depends}, ${gcc}, debconf (>= 1.2.0), emacs | emacsen, ucf Breaks: emacsen-common (<< 2.0.0) Suggests: gcl27-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: gcl27-doc Section: doc Architecture: all Conflicts: gclinfo Replaces: gclinfo Depends: dpkg (>= 1.15.4), ${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. gcl27-2.7.0/debian/control_cvs000066400000000000000000000030211454061450500161360ustar00rootroot00000000000000Source: gclcvs Section: lisp Priority: optional Maintainer: Camm Maguire Homepage: http://gnu.org/software/gcl Build-Depends: debhelper (>= 13), libeditreadline-dev, m4, tk8.6-dev, libgmp-dev, libxmu-dev, libxaw7-dev, po-debconf, zlib1g-dev, tcl, gcc-11 Standards-Version: 4.5.0 Package: gclcvs Architecture: any Depends: ${shlibs:Depends}, ${misc:Depends}, ${gcc}, debconf (>= 1.2.0), emacs | 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), ${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. gcl27-2.7.0/debian/copyright000066400000000000000000000055071454061450500156260ustar00rootroot00000000000000This 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'. gcl27-2.7.0/debian/gcl.lintian-overrides000066400000000000000000000012041454061450500200060ustar00rootroot00000000000000gcl: binary-compiled-with-profiling-enabled usr/lib/gcl-2.6.12-prof/unixport/saved_ansi_gcl gcl: binary-compiled-with-profiling-enabled usr/lib/gcl-2.6.12-prof/unixport/saved_gcl gcl: binary-compiled-with-profiling-enabled usr/lib/gcl-2.6.12/unixport/saved_ansi_gcl gcl: binary-compiled-with-profiling-enabled usr/lib/gcl-2.6.12/unixport/saved_gcl gcl: hardening-no-pie usr/lib/gcl-2.6.12-prof/unixport/saved_ansi_gcl gcl: hardening-no-pie usr/lib/gcl-2.6.12-prof/unixport/saved_gcl gcl: hardening-no-pie usr/lib/gcl-2.6.12/unixport/saved_ansi_gcl gcl: hardening-no-pie usr/lib/gcl-2.6.12/unixport/saved_gcl gcl: emacsen-common-without-dh-elpa gcl27-2.7.0/debian/gcl.sh000077500000000000000000000012641454061450500147730ustar00rootroot00000000000000#!/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 DIR=/usr/lib/gcl-$VERS; if [ "$GCL_ANSI" = "" ] ; then if [ "$GCL_PROF" = "" ] ; then EXE=saved_gcl; else EXE=saved_gcl_gprof; fi else if [ "$GCL_PROF" = "" ] ; then EXE=saved_ansi_gcl; else EXE=saved_ansi_gcl_gprof; fi 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)" gcl27-2.7.0/debian/gcl.templates000066400000000000000000000031111454061450500163450ustar00rootroot00000000000000# 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. gcl27-2.7.0/debian/in.gcl-clc.sh000066400000000000000000000071201454061450500161310ustar00rootroot00000000000000#!/bin/sh progname=$(basename $0) clc_src=/usr/share/common-lisp/source if test ! -f $clc_src/common-lisp-controller/common-lisp-controller.lisp ; then echo "Cannot find common-lisp-controller." 1>&2 echo "Please report this as a bug." 1>&2 exit 1 fi export GCL_ANSI=true gcl_bin=/usr/bin/gcl@EXT@ # is better than $(which gcl) command=$1 shift build_error() { echo "Error building $1" 1>&2 exit 1 } if [ "$command" = "make-user-image" ] ; then echo $progname Building image with $1 ... if test ! -r $1; then echo "Trying to make user image: Cannot access file $1" 1>&2 exit 1 fi $gcl_bin <&2 exit 1 fi case $command in rebuild) while test -x $gcl_bin -a -n "$1" do echo $progname Rebuilding $1 ... echo ' (setq *compile-print* t) (setq *compile-verbose* t) (setq *load-verbose* t) (setq *require-verbose* t) (ignore-errors (clc:compile-library (quote '"$1"')) (lisp:quit 0)) (lisp:quit 1) ' | $gcl_bin || build_error $1 shift done ;; remove) while test -n "$1" do echo $progname Removing $1 rm -rf "${gcl_clc}$1" shift done ;; install-clc) if ! [ -e /etc/default/$(basename $gcl_bin) ] ; then echo $(basename $gcl_bin) not configured, aborting exit 5 fi echo $progname Uninstalling clc image and purging object cache ... test -x $gcl_bin || { echo "Cannot install as there is no GCL" exit -1 } rm -rf $gcl_clc mkdir -p $gcl_clc # chown cl-builder.cl-builder $gcl_clc rm -f $image echo $progname Installing clc as $image ... if test -x $gcl_bin; then $gcl_bin < /dev/null 2>&1 || \ echo "$progname: Unknown command '$command'" 1>&2 echo "Usage: $progname " 1>&2 echo "Where is one of:" 1>&2 echo " install-clc, remove-clc," 1>&2 echo " rebuild *, remove *," 1>&2 echo " or make-user-image " 1>&2 echo "And is a cl-debpkg (e.g. cl-rt)" 1>&2 echo " with a defsystem/asdf definition." 1>&2 exit 1 ;; esac done exit 0 gcl27-2.7.0/debian/in.gcl-doc.README.Debian000066400000000000000000000004521454061450500176420ustar00rootroot00000000000000New 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 gcl27-2.7.0/debian/in.gcl-doc.doc-base.main000066400000000000000000000004171454061450500201250ustar00rootroot00000000000000Document: gcl@EXT@-doc Title: GNU Common Lisp Documentation Author: W. Schelter Abstract: A Common Lisp compiler and interpreter based on C Section: Programming Format: HTML Index: /usr/share/doc/gcl@EXT@-doc/gcl/index.html Files: /usr/share/doc/gcl@EXT@-doc/gcl/*.html gcl27-2.7.0/debian/in.gcl-doc.doc-base.si000066400000000000000000000006311454061450500176120ustar00rootroot00000000000000Document: 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 gcl27-2.7.0/debian/in.gcl-doc.doc-base.tk000066400000000000000000000006271454061450500176220ustar00rootroot00000000000000Document: 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 gcl27-2.7.0/debian/in.gcl-doc.doc-base.xgcl000066400000000000000000000006531454061450500201400ustar00rootroot00000000000000Document: 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 gcl27-2.7.0/debian/in.gcl-doc.docs000066400000000000000000000000271454061450500164520ustar00rootroot00000000000000faq readme readme.xgcl gcl27-2.7.0/debian/in.gcl-doc.info000066400000000000000000000011221454061450500164520ustar00rootroot00000000000000debian/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 debian/tmp/usr/share/info/gcl@EXT@.info debian/tmp/usr/share/info/gcl@EXT@.info-1 debian/tmp/usr/share/info/gcl@EXT@.info-2 debian/tmp/usr/share/info/gcl@EXT@.info-3 debian/tmp/usr/share/info/gcl@EXT@.info-4 debian/tmp/usr/share/info/gcl@EXT@.info-5 debian/tmp/usr/share/info/gcl@EXT@.info-6 debian/tmp/usr/share/info/gcl@EXT@.info-7 debian/tmp/usr/share/info/gcl@EXT@.info-8 debian/tmp/usr/share/info/gcl@EXT@.info-9 gcl27-2.7.0/debian/in.gcl-doc.install000066400000000000000000000000461454061450500171710ustar00rootroot00000000000000debian/tmp/usr/share/doc/gcl@EXT@-doc gcl27-2.7.0/debian/in.gcl.1000066400000000000000000000130601454061450500151200ustar00rootroot00000000000000.TH GCL 1L "17 March 1997" .SH NAME gcl@EXT@ \- GCL Common Lisp interpreter/compiler, CVS snapshot .SH SYNOPSIS .B gcl@EXT@ [ .B options ] .SH DESCRIPTION The program .I gcl@EXT@ 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@EXT@-si for basic common lisp descriptions, and features unique to .I gcl@EXT@ The .I gcl@EXT@-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@EXT@ 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@EXT@ 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 .BR \-load\ pathname .RB Load the file whose .I pathname is specified after .BR \-load . .TP .B \-f Replace si::*command-args* by the the list starting after .BR \-f . 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. 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@EXT@ -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 L\s-2ISP\s0 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 sytem. 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. .\" gcl27-2.7.0/debian/in.gcl.config000066400000000000000000000007341454061450500162310ustar00rootroot00000000000000#!/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 gcl27-2.7.0/debian/in.gcl.docs000066400000000000000000000000531454061450500157060ustar00rootroot00000000000000ansi-tests/test_results RELEASE-2.6.2.html gcl27-2.7.0/debian/in.gcl.emacsen-compat000066400000000000000000000000021454061450500176440ustar00rootroot000000000000000 gcl27-2.7.0/debian/in.gcl.emacsen-install000066400000000000000000000023271454061450500200430ustar00rootroot00000000000000#! /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 gcl27-2.7.0/debian/in.gcl.emacsen-remove000066400000000000000000000007261454061450500176730ustar00rootroot00000000000000#!/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 gcl27-2.7.0/debian/in.gcl.emacsen-startup000066400000000000000000000015041454061450500200730ustar00rootroot00000000000000;; -*-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) gcl27-2.7.0/debian/in.gcl.install000066400000000000000000000001011454061450500164160ustar00rootroot00000000000000debian/tmp/usr/lib debian/tmp/usr/bin debian/tmp/usr/share/emacs gcl27-2.7.0/debian/in.gcl.manpages000066400000000000000000000000511454061450500165470ustar00rootroot00000000000000debian/tmp/usr/share/man/man1/gcl@EXT@.1 gcl27-2.7.0/debian/in.gcl.postinst000066400000000000000000000014341454061450500166450ustar00rootroot00000000000000#!/bin/sh case "$1" in configure) # CONFIGFILE=$(tempfile -m 644) CONFIGFILE=$(mktemp) chmod 644 $CONFIGFILE 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# gcl27-2.7.0/debian/in.gcl.postrm000066400000000000000000000006241454061450500163060ustar00rootroot00000000000000#!/bin/sh set -e 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# gcl27-2.7.0/debian/in.gcl.templates000066400000000000000000000025221454061450500167570ustar00rootroot00000000000000Template: 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. 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. Template: gcl@EXT@/default_gcl_prof Type: boolean _Description: Use the profiling build by default? 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. gcl27-2.7.0/debian/old.in.gcl-doc.doc-base.main000066400000000000000000000005631454061450500207040ustar00rootroot00000000000000Document: 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 gcl27-2.7.0/debian/po/000077500000000000000000000000001454061450500143025ustar00rootroot00000000000000gcl27-2.7.0/debian/po/POTFILES.in000066400000000000000000000000501454061450500160520ustar00rootroot00000000000000[type: gettext/rfc822deb] gcl.templates gcl27-2.7.0/debian/po/cs.po000066400000000000000000000144531454061450500152560ustar00rootroot00000000000000# # 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." gcl27-2.7.0/debian/po/da.po000066400000000000000000000071411454061450500152310ustar00rootroot00000000000000# 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." gcl27-2.7.0/debian/po/de.po000066400000000000000000000143531454061450500152400ustar00rootroot00000000000000# 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 standardmig 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, zustzlich 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 fr eine kurze Beschreibung dieser " "Begriffe. Die Wahl dieser Option bestimmen, welches Image standardmig " "verwendet wird, wenn gcl@EXT@ ausgefhrt 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 fhrt zur ANSI-Erstellung, und die " "leere Zeichenkette fhrt 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 standardmig den Profiling-Build?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "GCL besitzt optionale Untersttzung fr 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 fr si::gprof-start und si::gprof-quit fr " "Details. Da ein solches Programm langsamer ist als ein Programm ohne Gprof-" "Untersttzung, wird dies fr 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, fr Profiling-Untersttzung; 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 fr den " #~ "Produktiveinsatz zustzlich an der Bereitstellung eines kompatiblen ANSI-" #~ "Images. Bitte beachten Sie die README.Debian-Datei fr eine kurze " #~ "Beschreibung dieses Themas. Durch diese Variable definieren Sie, welches " #~ "Image voreingestellt bei der Ausfhrung von gcl@EXT@ verwendet wird. " #~ "Diese Auswahl kann lokal, durch einen nicht leeren Wert in der " #~ "Umgebungsvariable GCL_ANSI fr den ANSI-Build, bzw. einen leeren Wert " #~ "fr den CLtL1-Build, z.B. GCL_ANSI=t gcl@EXT@ definiert werden. Es " #~ "erfolgt eine Meldung ber die aktive Erstellung im einfhrenden 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 Untersttzung fr Profiling mit gprof. Bitte lesen " #~ "Sie hierzu die Dokumentation von si::gprof-start und si::gprof-quit fr " #~ "weiterfhrende Informationen. Da dieser Build langsamer ist als ohne " #~ "gprof-Untersttzung, wird dieser Weg nicht fr den endgltig produktiven " #~ "Einsatz empfohlen. Sie knnen die hier gemachten Angaben lokal ber die " #~ "GCL_PROF-Umgebungsvariable durch einen beliebigen Wert ndern, bzw. durch " #~ "einen leeren Wert fr das weitaus anpassungsfhigere Build, z.B. " #~ "GCL_PROF=t gcl@EXT@. Falls Profiling aktiviert ist, erfolgt eine Meldung " #~ "im einfhrenden Start-Banner." gcl27-2.7.0/debian/po/es.po000066400000000000000000000240201454061450500152470ustar00rootroot00000000000000# 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." gcl27-2.7.0/debian/po/fi.po000066400000000000000000000070231454061450500152420ustar00rootroot00000000000000msgid "" 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." gcl27-2.7.0/debian/po/fr.po000066400000000000000000000144351454061450500152600ustar00rootroot00000000000000# 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 dfaut?" #. 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 utilise 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 brve description de ces " "termes. Le choix de cette option dterminera quelle image sera utilise par " "dfaut en excutant 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 rglage peut tre chang en affectant la variable d'environnement " "GCL_ANSI une chane non vide pour la compilation ANSI, et une chane vide " "pour la compilation CLtL1, par exemple GCL_ANSI=t gcl@EXT@. Le type de " "compilation sera affich dans le bandeau de dmarrage." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "Faut-il utiliser le profilage par dfaut?" #. 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 dtails. Comme cet excutable est plus lent que " "les excutables 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 chane vide la variable d'environnement GCL_PROF " "pour des compilations optimises, ou une chane 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 dmarrage." #~ 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 dfinition de " #~ "l'ANSI en plus de son image traditionnelle CLtL1 qui est toujours " #~ "utilise en production. Veuillez consulter le fichier README.Debian " #~ "pour plus d'informations sur ces normes. Ce choix dterminera quelle " #~ "norme vous allez utiliser par dfaut lors de l'excution de " #~ "gcl@EXT@. Vous pouvez localement modifier ce choix en " #~ "affectant une chane non vide la variable d'environnement GCL_ANSI " #~ "pour une compilation respectant la norme dfinie par l'ANSI, et une " #~ "chane 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 dmarrage." #~ 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 gre dsormais 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 consquent 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 chane non vide " #~ "pour activer le profilage, ou une chane vide pour une compilation " #~ "optimise, par exemple GCL_PROF=t gcl@EXT@. Si le profilage est " #~ "activ, cela sera affich dans le bandeau de dmarrage." gcl27-2.7.0/debian/po/gl.po000066400000000000000000000143611454061450500152510ustar00rootroot00000000000000# 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." gcl27-2.7.0/debian/po/it.po000066400000000000000000000073451454061450500152670ustar00rootroot00000000000000# 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." gcl27-2.7.0/debian/po/ja.po000066400000000000000000000074771454061450500152530ustar00rootroot00000000000000# 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 ãŒæœ‰åŠ¹ãªå ´åˆã€åˆæœŸã®é–‹å§‹æ™‚ãƒãƒŠãƒ¼ã§å ±å‘Šã•ã‚Œã¾ã™ã€‚" gcl27-2.7.0/debian/po/nl.po000066400000000000000000000074001454061450500152540ustar00rootroot00000000000000# 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 ." gcl27-2.7.0/debian/po/pt.po000066400000000000000000000074301454061450500152710ustar00rootroot00000000000000# 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." gcl27-2.7.0/debian/po/pt_BR.po000066400000000000000000000072561454061450500156620ustar00rootroot00000000000000# Debconf translations for gcl. # Copyright (C) 2016 THE gcl'S COPYRIGHT HOLDER # This file is distributed under the same license as the gcl package. # Adriano Rafael Gomes , 2016. # 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: 2016-01-05 11:09-0200\n" "Last-Translator: Adriano Rafael Gomes \n" "Language-Team: Brazilian Portuguese \n" "Language: pt_BR\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 "Usar a versão ANSI em desenvolvimento por padrã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 "" "O GCL está em processo de fornecer uma imagem de acordo com o padrão ANSI em " "adição à sua imagem CLtL1 tradicional, ainda em uso em 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 arquivo README.Debian para uma breve descrição desses " "termos. Escolher essa opção determinará qual imagem será usada por padrã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 "" "Essa configuração pode ser sobreposta definindo a variável de ambiente " "GCL_ANSI para qualquer texto não vazio para a versão ANSI, e para um texto " "vazio para a versão CLtL1, por exemplo, GCL_ANSI=t gcl@EXT@. O sabor da " "versão atualmente definida será exibida na mensagem de inicialização." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "Usar a versão de \"profiling\" por padrão?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "O GCL tem suporte opcional a \"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 para si::gprof-start e si::gprof-quit para " "detalhes. Como essa versão é mais lenta que versões sem suporte a gprof, ela " "não é recomendada para uso final em produção." #. 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 "" "Defina a variável de ambiente GCL_PROF para um texto vazio para versões mais " "otimizadas, ou para qualquer texto não vazio para ter suporte a \"profiling" "\"; por exemplo, GCL_PROF=t gcl@EXT@. Se o \"profiling\" estiver habilitado, " "isso será exibido na mensagem de inicialização." gcl27-2.7.0/debian/po/ru.po000066400000000000000000000107721454061450500152770ustar00rootroot00000000000000# 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@. ЕÑли профилирование включено, то об Ñтом будет " "напиÑано при первом запуÑке." gcl27-2.7.0/debian/po/sv.po000066400000000000000000000077001454061450500152760ustar00rootroot00000000000000# 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 "Anvnd det nnu inte frdiga 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 tillhandahlla en ANSI-godknd bild frutom dess " "traditionella CLtL1-bild som fortfarande anvnds i produktionsmiljn." #. 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 fr en versiktlig beskrivning av dessa termer. Nr " "du vljer det hr alternativet avgrs vilken bild som kommer anvndas som " "standard nr 'gcl@EXT@' krs." #. 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 instllning kan verskridas genom att stta miljvariabeln GCL_ANSI " "till en icke-tom strng fr ANSI-bygget, och till den tomma strngen fr " "CLtL1-bygget, t. ex. GCL_ANSI=t gcl@EXT@. Det bygge som fr tillfllet " "anvnds kommer anges i uppstartsutskriften." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "Anvnd profileringsbygget som standard?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "GCL har valfritt std fr 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 fr si::gprof-start och si::gprof-quit fr detaljer. " "Eftersom detta bygge r lngsammare n byggen utan std fr gprof, " "rekommenderas det inte fr slutlig anvndning 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 "" "Stt miljvariabeln GCL_PROF till den tomma strngen fr mer optimiserade " "byggen, eller en icke-tom strng fr profileringsstd; t. ex. GCL_PROF=t " "gcl@EXT@. Om profilering r aktiverad, kommer denna rapporteras i den " "ursprungliga uppstartsutskriften." gcl27-2.7.0/debian/po/templates.pot000066400000000000000000000045161454061450500170320ustar00rootroot00000000000000# 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 "" gcl27-2.7.0/debian/po/vi.po000066400000000000000000000101141454061450500152550ustar00rootroot00000000000000# 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." gcl27-2.7.0/debian/rules000077500000000000000000000207671454061450500147600ustar00rootroot00000000000000#!/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 #export GCL_MEM_MULTIPLE=0.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= ARCHCONF?= ifeq ($(ARCHT),armhf) ARCHCONF=--enable-cstackmax=0xc0000000 endif ifeq ($(ARCHT),armel) ARCHCONF=--enable-cstackmax=0xc0000000 endif #ifeq ($(ARCHT),hppa) #DEBUG=--enable-debug #endif VERS=$(shell echo $$(cat majvers).$$(cat minvers)) EXT=$(shell echo $(VERS) | sed 's,\([0-9]\)\.\([0-9]\)\..*,\1\2,') #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/* [ "$*" != "trad" ] || FLAGS="--disable-ansi" ; \ [ "$*" != "gprof" ] || FLAGS="--disable-ansi --enable-gprof" ; \ [ "$*" != "ansi-gprof" ] || FLAGS="--enable-gprof" ; \ eval `dpkg-buildflags --export=sh` && CC=$(MCC) ./configure \ --host=$$(dpkg-architecture -qDEB_HOST_GNU_TYPE) \ --disable-statsysbfd \ --disable-custreloc \ --disable-dlopen \ --disable-prelink \ --disable-pargcl \ --enable-$(RELOC) \ $(GMP) \ $(DEBUG) \ $(ARCHCONF) \ $$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 "(si::reset-sys-paths \"$$new/\")(si::save-system \"debian/tmp-image\")" | $$tmp/$$new/unixport/$$i &&\ mv debian/tmp-image $$tmp/$$new/unixport/$$i;) touch $@ configure-stamp: $(CFGS) dh_testdir # ! [ -e unixport/saved_pre_gcl ] || $(MAKE) clean # chmod -R +x gmp4/* eval `dpkg-buildflags --export=sh` && CC=$(MCC) ./configure \ --host=$$(dpkg-architecture -qDEB_HOST_GNU_TYPE) \ --disable-statsysbfd \ --disable-custreloc \ --disable-dlopen \ --disable-prelink \ --disable-pargcl \ --enable-$(RELOC) \ $(GMP) \ $(DEBUG) \ $(ARCHCONF) \ --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 rm -rf debian/tmp1 mkdir -p debian/tmp1 $(MAKE) $(MAKE) install DESTDIR=$$(pwd)/debian/tmp1 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,\([^x]gcl\),\1$(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_prep dh_installdirs # mkdir -p debian/tmp cp -a debian/tmp1 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 -e "s,(provide 'dbl),(provide 'dbl$(EXT)),1" -e "s,(require 'gcl),(require 'gcl$(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)" = "" ] || \ (mv debian/tmp/usr/share/man/man1/gcl.1 debian/foo && cat debian/foo |sed -e 's, gcl , gcl$(EXT) ,g' -e 's, GCL , GCL$(EXT) ,g' >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 -Xlibgcl_gprof -Xlibansi_gcl_gprof # -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 gcl27-2.7.0/debian/source/000077500000000000000000000000001454061450500151645ustar00rootroot00000000000000gcl27-2.7.0/debian/source/format000066400000000000000000000000141454061450500163720ustar00rootroot000000000000003.0 (quilt) gcl27-2.7.0/debian/source/include-binaries000066400000000000000000000000761454061450500203270ustar00rootroot00000000000000info/gcl.pdf info/gcl-si.pdf info/gcl-tk.pdf xgcl-2/dwdoc.pdf gcl27-2.7.0/debian/source/lintian-overrides000066400000000000000000000015651454061450500205540ustar00rootroot00000000000000gcl source: source-is-missing [info/gcl/Constraints-on-the-COMMON_002dLISP-Package-for-Conforming-Programs.html] gcl source: source-is-missing [info/gcl/Defsetf-Lambda-Lists.html] gcl source: source-is-missing [info/gcl/Destructuring-Lambda-Lists.html] gcl source: source-is-missing [info/gcl/Generic-Function-Lambda-Lists.html] gcl source: source-is-missing [info/gcl/Macro-Lambda-Lists.html] gcl source: source-is-missing [info/gcl/Ordinary-Lambda-Lists.html] gcl source: source-is-missing [info/gcl/Specialized-Lambda-Lists.html] gcl source: source-is-missing [info/gcl/The-_0022Compound-Type-Specifier-Arguments_0022-Section-of-a-Dictionary-Entry.html] gcl source: source-is-missing [info/gcl/The-_0022Compound-Type-Specifier-Syntax_0022-Section-of-a-Dictionary-Entry.html] gcl source: source-is-missing [info/gcl/defmethod.html] gcl source: source-is-missing [info/gcl/loop.html] gcl27-2.7.0/debian/texi.awk000077500000000000000000000004751454061450500153520ustar00rootroot00000000000000#!/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; } gcl27-2.7.0/debian/upstream/000077500000000000000000000000001454061450500155245ustar00rootroot00000000000000gcl27-2.7.0/debian/upstream/signing-key.asc000066400000000000000000000125501454061450500204430ustar00rootroot00000000000000-----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----- gcl27-2.7.0/debian/watch000066400000000000000000000001631454061450500147150ustar00rootroot00000000000000version=4 options=pasv,pgpsigurlmangle=s/$/.sig/ ftp://ftp.gnu.org/pub/gnu/gcl gcl-([0-9.]*).tar.gz debian uupdate gcl27-2.7.0/doc/000077500000000000000000000000001454061450500132075ustar00rootroot00000000000000gcl27-2.7.0/doc/bignum000066400000000000000000000046661454061450500144270ustar00rootroot00000000000000 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)))))))) gcl27-2.7.0/doc/c-gc000066400000000000000000000025251454061450500137470ustar00rootroot00000000000000 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. gcl27-2.7.0/doc/c-gc.doc000066400000000000000000000021641454061450500145120ustar00rootroot00000000000000 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. gcl27-2.7.0/doc/compile-file-handling-of-top-level-forms000066400000000000000000000236311454061450500227210ustar00rootroot00000000000000Forum: 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. gcl27-2.7.0/doc/contributors000066400000000000000000000025661454061450500157000ustar00rootroot00000000000000 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) gcl27-2.7.0/doc/debug000066400000000000000000000017121454061450500142210ustar00rootroot00000000000000New 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. gcl27-2.7.0/doc/enhancements000066400000000000000000000143431454061450500156070ustar00rootroot00000000000000 @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. gcl27-2.7.0/doc/fast-link000066400000000000000000000122461454061450500150270ustar00rootroot00000000000000 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 gcl27-2.7.0/doc/format000066400000000000000000000026051454061450500144250ustar00rootroot00000000000000 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. gcl27-2.7.0/doc/funcall-comp000066400000000000000000000016741454061450500155220ustar00rootroot00000000000000 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. gcl27-2.7.0/doc/funcall.lsp000066400000000000000000000064501454061450500153600ustar00rootroot00000000000000 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 gcl27-2.7.0/doc/makefile000066400000000000000000000003461454061450500147120ustar00rootroot00000000000000# 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 gcl27-2.7.0/doc/multiple-values000066400000000000000000000051531454061450500162660ustar00rootroot00000000000000 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 gcl27-2.7.0/doc/profile000066400000000000000000000024501454061450500145730ustar00rootroot00000000000000 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. gcl27-2.7.0/dos/000077500000000000000000000000001454061450500132275ustar00rootroot00000000000000gcl27-2.7.0/dos/dostimes.c000077500000000000000000000004451454061450500152300ustar00rootroot00000000000000#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; } gcl27-2.7.0/dos/dum_dos.c000077500000000000000000000002651454061450500150330ustar00rootroot00000000000000#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) gcl27-2.7.0/dos/makefile000066400000000000000000000004071454061450500147300ustar00rootroot00000000000000.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) gcl27-2.7.0/dos/read.s000077500000000000000000000020201454061450500143230ustar00rootroot00000000000000/* 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 gcl27-2.7.0/dos/readme000077500000000000000000000003361454061450500144140ustar00rootroot00000000000000 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 gcl27-2.7.0/dos/sigman.s000077500000000000000000000024171454061450500147000ustar00rootroot00000000000000 .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 */ gcl27-2.7.0/dos/signal.c000077500000000000000000000060701454061450500146560ustar00rootroot00000000000000/* 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 gcl27-2.7.0/dos/signal.h000077500000000000000000000113761454061450500146700ustar00rootroot00000000000000/* 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 gcl27-2.7.0/elisp/000077500000000000000000000000001454061450500135565ustar00rootroot00000000000000gcl27-2.7.0/elisp/add-default.el000066400000000000000000000001671454061450500162560ustar00rootroot00000000000000 ;;;BEGIN gcl addition (autoload 'dbl "dbl" "Make a debugger to run lisp, maxima and or gdb in" t) ;;;END gcl addition gcl27-2.7.0/elisp/ansi-doc.el000077500000000000000000000061071454061450500156040ustar00rootroot00000000000000;; 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) ) gcl27-2.7.0/elisp/dbl.el000077500000000000000000000545641454061450500146620ustar00rootroot00000000000000;; 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 keys &optional doc) (let ((keys (if (consp keys) keys (list keys))) (fun (intern (format "dbl-%s" (read name))))) `(progn (defun ,fun (arg) ,(or doc "") (interactive "p") (dbl-call ,name arg) ,@(mapcar #'(lambda (key) `(define-key dbl-mode-map ,key ',fun)) keys))))) (def-dbl ":step %p" ("\M-s" "\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" "\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") (defvar dbl-last-frame nil) (defvar dbl-last-frame-displayed-p t) (defvar dbl-delete-prompt-marker nil) (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 (;; important for winnt version of emacs (binary-process-input t) (binary-process-output nil) (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 (cond ((string-match "\032\032\\([A-Za-z]?:?[^:]*\\):\\([0-9]*\\):[^\n]+\n" string) (setq dbl-last-frame (cons (match-string 1 string) (string-to-number (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))) (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)) (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 ((progn (beginning-of-line) (get-text-property (point) 'file-line))) ((progn (end-of-line) (re-search-backward " \\([^: ]+\\):\\([0-9]+\\)" 300 nil)) (let* ((file (buffer-substring (match-beginning 1) (match-end 1))) (line (buffer-substring (match-beginning 2) (match-end 2))) (line (read line)) (file (search-path file 'dbl-dirs))) (and (integerp line) file (list file line)))))) (t (list (buffer-file-name) (+ 1 (if (featurep 'xemacs) (line-number) (line-number-at-pos)))))))) (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) (process-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 (if (featurep 'xemacs) (line-number) (line-number-at-pos))))))))) (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) (process-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))) (process-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 (point)) begin (found (if (search-backward "0x" (- pt 7) t) (point)))) (cond (found (forward-char 2) (buffer-substring found (progn (re-search-forward "[^0-9a-f]") (forward-char -1) (point)))) (t (setq begin (progn (re-search-backward "[^0-9]") (forward-char 1) (point))) (forward-char 1) (re-search-forward "[^0-9]") (forward-char -1) (buffer-substring begin (point))))))) (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 (point-max)) (insert comm))) (provide 'dbl) gcl27-2.7.0/elisp/doc-to-texi.el000077500000000000000000000103201454061450500162330ustar00rootroot00000000000000 (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)))) gcl27-2.7.0/elisp/gcl.el000077500000000000000000000266531454061450500146640ustar00rootroot00000000000000;; 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)gcl27-2.7.0/elisp/makefile000066400000000000000000000014261454061450500152610ustar00rootroot00000000000000 -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 gcl27-2.7.0/elisp/man1-to-texi.el000077500000000000000000000331161454061450500163320ustar00rootroot00000000000000;;;;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)))) gcl27-2.7.0/elisp/readme000077500000000000000000000003541454061450500147430ustar00rootroot00000000000000 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. gcl27-2.7.0/elisp/smart-complete.el000066400000000000000000000117211454061450500170360ustar00rootroot00000000000000;; 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) gcl27-2.7.0/elisp/sshell.el000077500000000000000000000320031454061450500153730ustar00rootroot00000000000000 ;; 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)gcl27-2.7.0/eval.html000077500000000000000000000051521454061450500142650ustar00rootroot00000000000000 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
    }
}
gcl27-2.7.0/eval.tcl000077500000000000000000000036311454061450500141030ustar00rootroot00000000000000# 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 } } gcl27-2.7.0/faq000077500000000000000000000050521454061450500131410ustar00rootroot00000000000000 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.... =========== gcl27-2.7.0/gcl-tk/000077500000000000000000000000001454061450500136235ustar00rootroot00000000000000gcl27-2.7.0/gcl-tk/comm.c000077500000000000000000000160051454061450500147270ustar00rootroot00000000000000 #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",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(int 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)) { char *start = sfd->valid_data+sfd->valid_data_size; again: 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; } return 0; } /* 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("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 gcl27-2.7.0/gcl-tk/convert.el000077500000000000000000000146521454061450500156400ustar00rootroot00000000000000 (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))))) gcl27-2.7.0/gcl-tk/decode.tcl000066400000000000000000000206421454061450500155560ustar00rootroot00000000000000# 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" } gcl27-2.7.0/gcl-tk/demos-4.1/000077500000000000000000000000001454061450500152325ustar00rootroot00000000000000gcl27-2.7.0/gcl-tk/demos-4.1/items.lisp000077500000000000000000000316361454061450500172600ustar00rootroot00000000000000;;# 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)) ) gcl27-2.7.0/gcl-tk/demos-4.2/000077500000000000000000000000001454061450500152335ustar00rootroot00000000000000gcl27-2.7.0/gcl-tk/demos-4.2/widget000077500000000000000000000321031454061450500164430ustar00rootroot00000000000000#!/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." } gcl27-2.7.0/gcl-tk/demos-4.2/widget.lisp000077500000000000000000000355761454061450500174320ustar00rootroot00000000000000;;#!/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.") ) gcl27-2.7.0/gcl-tk/demos/000077500000000000000000000000001454061450500147325ustar00rootroot00000000000000gcl27-2.7.0/gcl-tk/demos/gc-monitor.lisp000077500000000000000000000120461454061450500177070ustar00rootroot00000000000000 ;; 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 (seqind 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 seqind (+ 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 seqind (- tot (the seqind nfree))))) tot)))) (declare (seqind 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) ) gcl27-2.7.0/gcl-tk/demos/mkArrow.tcl000077500000000000000000000162061454061450500170700ustar00rootroot00000000000000# 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 } } gcl27-2.7.0/gcl-tk/demos/mkBasic.lisp000077500000000000000000000053531454061450500172050ustar00rootroot00000000000000;;# 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")) ) gcl27-2.7.0/gcl-tk/demos/mkBasic.tcl000077500000000000000000000047111454061450500170150ustar00rootroot00000000000000# 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" } gcl27-2.7.0/gcl-tk/demos/mkBitmaps.tcl000077500000000000000000000026751454061450500174020ustar00rootroot00000000000000# 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 } } gcl27-2.7.0/gcl-tk/demos/mkButton.tcl000077500000000000000000000023231454061450500172440ustar00rootroot00000000000000# 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 } gcl27-2.7.0/gcl-tk/demos/mkCanvText.lisp000077500000000000000000000116251454061450500177170ustar00rootroot00000000000000;;# 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)) ) gcl27-2.7.0/gcl-tk/demos/mkCanvText.tcl000077500000000000000000000105471454061450500175340ustar00rootroot00000000000000# 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} } gcl27-2.7.0/gcl-tk/demos/mkCheck.tcl000077500000000000000000000026501454061450500170110ustar00rootroot00000000000000# 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 } gcl27-2.7.0/gcl-tk/demos/mkDialog.tcl000077500000000000000000000043401454061450500171710ustar00rootroot00000000000000# 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 } gcl27-2.7.0/gcl-tk/demos/mkEntry.lisp000077500000000000000000000033101454061450500172540ustar00rootroot00000000000000;;# 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.") ) gcl27-2.7.0/gcl-tk/demos/mkEntry.tcl000077500000000000000000000027451454061450500171020ustar00rootroot00000000000000# 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." } gcl27-2.7.0/gcl-tk/demos/mkEntry2.lisp000077500000000000000000000047751454061450500173560ustar00rootroot00000000000000;;# 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.") ) gcl27-2.7.0/gcl-tk/demos/mkEntry2.tcl000077500000000000000000000040231454061450500171530ustar00rootroot00000000000000# 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." } gcl27-2.7.0/gcl-tk/demos/mkFloor.tcl000077500000000000000000002260401454061450500170560ustar00rootroot00000000000000# 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} } gcl27-2.7.0/gcl-tk/demos/mkForm.lisp000077500000000000000000000036331454061450500170660ustar00rootroot00000000000000;;# 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 )) ) gcl27-2.7.0/gcl-tk/demos/mkForm.tcl000077500000000000000000000030321454061450500166720ustar00rootroot00000000000000# 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] } gcl27-2.7.0/gcl-tk/demos/mkHScale.lisp000077500000000000000000000030041454061450500173120ustar00rootroot00000000000000;;# 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) ) gcl27-2.7.0/gcl-tk/demos/mkHScale.tcl000077500000000000000000000023171454061450500171330ustar00rootroot00000000000000# 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 } gcl27-2.7.0/gcl-tk/demos/mkIcon.tcl000077500000000000000000000037411454061450500166660ustar00rootroot00000000000000# 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 } gcl27-2.7.0/gcl-tk/demos/mkItems.lisp000077500000000000000000000353221454061450500172440ustar00rootroot00000000000000;;# 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))))) gcl27-2.7.0/gcl-tk/demos/mkItems.tcl000077500000000000000000000234231454061450500170560ustar00rootroot00000000000000# 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" } gcl27-2.7.0/gcl-tk/demos/mkLabel.lisp000077500000000000000000000031241454061450500171750ustar00rootroot00000000000000;;# 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") ) gcl27-2.7.0/gcl-tk/demos/mkLabel.tcl000077500000000000000000000024671454061450500170210ustar00rootroot00000000000000# 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 } gcl27-2.7.0/gcl-tk/demos/mkListbox.lisp000077500000000000000000000033671454061450500176130ustar00rootroot00000000000000(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) gcl27-2.7.0/gcl-tk/demos/mkListbox.tcl000077500000000000000000000033011454061450500174120ustar00rootroot00000000000000# 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 } gcl27-2.7.0/gcl-tk/demos/mkListbox2.tcl000077500000000000000000000114261454061450500175030ustar00rootroot00000000000000# 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\]" } gcl27-2.7.0/gcl-tk/demos/mkListbox3.tcl000077500000000000000000000040701454061450500175010ustar00rootroot00000000000000# 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" } gcl27-2.7.0/gcl-tk/demos/mkPlot.lisp000077500000000000000000000055511454061450500171020ustar00rootroot00000000000000(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)) ) ) gcl27-2.7.0/gcl-tk/demos/mkPlot.tcl000077500000000000000000000044551454061450500167170ustar00rootroot00000000000000# 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 } gcl27-2.7.0/gcl-tk/demos/mkPuzzle.tcl000077500000000000000000000040341454061450500172630ustar00rootroot00000000000000# 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) } } gcl27-2.7.0/gcl-tk/demos/mkRadio.lisp000077500000000000000000000057731454061450500172300ustar00rootroot00000000000000(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") ) gcl27-2.7.0/gcl-tk/demos/mkRadio.tcl000077500000000000000000000050201454061450500170240ustar00rootroot00000000000000# 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 } gcl27-2.7.0/gcl-tk/demos/mkRuler.lisp000077500000000000000000000121461454061450500172530ustar00rootroot00000000000000;;# 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") ) )) gcl27-2.7.0/gcl-tk/demos/mkRuler.tcl000077500000000000000000000074761454061450500171000ustar00rootroot00000000000000# 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 } } gcl27-2.7.0/gcl-tk/demos/mkScroll.tcl000077500000000000000000000054351454061450500172360ustar00rootroot00000000000000# 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]" } gcl27-2.7.0/gcl-tk/demos/mkSearch.lisp000077500000000000000000000116131454061450500173650ustar00rootroot00000000000000;;# 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"))))) gcl27-2.7.0/gcl-tk/demos/mkSearch.tcl000077500000000000000000000112041454061450500171740ustar00rootroot00000000000000# 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] } } gcl27-2.7.0/gcl-tk/demos/mkStyles.lisp000077500000000000000000000121571454061450500174470ustar00rootroot00000000000000;;# 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)))) gcl27-2.7.0/gcl-tk/demos/mkStyles.tcl000077500000000000000000000104031454061450500172520ustar00rootroot00000000000000# 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 } } gcl27-2.7.0/gcl-tk/demos/mkTear.tcl000077500000000000000000000014501454061450500166640ustar00rootroot00000000000000# 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 } gcl27-2.7.0/gcl-tk/demos/mkTextBind.lisp000077500000000000000000000100501454061450500176730ustar00rootroot00000000000000;;# 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)))) gcl27-2.7.0/gcl-tk/demos/mkTextBind.tcl000077500000000000000000000064431454061450500175210ustar00rootroot00000000000000# 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 } } gcl27-2.7.0/gcl-tk/demos/mkVScale.lisp000077500000000000000000000030011454061450500173250ustar00rootroot00000000000000(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) ) gcl27-2.7.0/gcl-tk/demos/mkVScale.tcl000077500000000000000000000023001454061450500171410ustar00rootroot00000000000000# 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 } gcl27-2.7.0/gcl-tk/demos/mkdialog.lisp000077500000000000000000000047511454061450500174240ustar00rootroot00000000000000;;# 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) ) gcl27-2.7.0/gcl-tk/demos/nqthm-stack.lisp000077500000000000000000000050511454061450500200610ustar00rootroot00000000000000(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 #+anci-cl cl-user::do-frames #-ansi-cl user::do-frames) :command #+ansi-cl '(cl-user::MAINTAIN-REWRITE-PATH cl-user::do-frames) #-ansi-cl '(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))) #+ansi-cl(in-package "CL-USER") #-ansi-cl(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 #+ansi-cl cl-user::REWRITE-PATH-STK-PTR #-ansi-cl user::REWRITE-PATH-STK-PTR do (setq tem (aref #+ansi-cl cl-user::REWRITE-PATH-STK #-ansi-cl 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 |.|))))))gcl27-2.7.0/gcl-tk/demos/showVars.lisp000077500000000000000000000021051454061450500174400ustar00rootroot00000000000000(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) ) gcl27-2.7.0/gcl-tk/demos/showVars.tcl000077500000000000000000000014401454061450500172540ustar00rootroot00000000000000# 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 } gcl27-2.7.0/gcl-tk/demos/tclIndex000077500000000000000000000126661454061450500164450ustar00rootroot00000000000000# 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]] gcl27-2.7.0/gcl-tk/demos/widget.lisp000077500000000000000000000244041454061450500171150ustar00rootroot00000000000000 (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 }") gcl27-2.7.0/gcl-tk/dir.sed000077500000000000000000000000561454061450500151020ustar00rootroot00000000000000/DIR=/a\ DIR=/home/wfs/gcl-2.0/gcl-tk /DIR=/d gcl27-2.7.0/gcl-tk/gcl-1.tcl000077500000000000000000000025751454061450500152460ustar00rootroot00000000000000 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" } gcl27-2.7.0/gcl-tk/gcl.tcl000077500000000000000000000025761454061450500151110ustar00rootroot00000000000000 # 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 }}} gcl27-2.7.0/gcl-tk/gcl_cmpinit.lsp000077500000000000000000000000271454061450500166350ustar00rootroot00000000000000(load "tk-package.lsp")gcl27-2.7.0/gcl-tk/gcl_guisl.h000077500000000000000000000001771454061450500157540ustar00rootroot00000000000000 static L1(); static L2(); static char * VVi[2]={ #define Cdata VV[1] (char *)(L1), (char *)(L2) }; #define VV ((object *)VVi) gcl27-2.7.0/gcl-tk/gcltksrv.bat.in000066400000000000000000000002671454061450500165640ustar00rootroot00000000000000set GCL_TK_DIR=c:/cvs/head/gcl/gcl-tk set TCL_LIBRARY=c:/lang/Tcl-8.4.1.0/lib/tcl8.4 set TK_LIBRARY=c:/lang/Tcl-8.4.1.0/lib/tcl8.4 echo %1 %2 %3 start %GCL_TK_DIR%/gcltkaux %1 %2 %3 gcl27-2.7.0/gcl-tk/gcltksrv.in000077500000000000000000000013461454061450500160210ustar00rootroot00000000000000#!/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 gcl27-2.7.0/gcl-tk/gcltksrv.in.interp000077500000000000000000000004421454061450500173150ustar00rootroot00000000000000#!/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 gcl27-2.7.0/gcl-tk/gcltksrv.prev000077500000000000000000000006441454061450500163670ustar00rootroot00000000000000#!/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 gcl27-2.7.0/gcl-tk/guis.c000077500000000000000000000265011454061450500147450ustar00rootroot00000000000000/* 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,(void *)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,(void *)&(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; } gcl27-2.7.0/gcl-tk/guis.h000077500000000000000000000033651454061450500147550ustar00rootroot00000000000000#ifndef _GUIS_H_ #define _GUIS_H_ #include #define NO_PRELINK_UNEXEC_DIVERSION #define IMMNUM_H #define GMP_WRAPPERS_H #define ERROR_H #undef INLINE #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_) gcl27-2.7.0/gcl-tk/helpers.lisp000077500000000000000000000012711454061450500161620ustar00rootroot00000000000000 (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) )))) gcl27-2.7.0/gcl-tk/index.lsp000077500000000000000000000034621454061450500154620ustar00rootroot00000000000000 (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*))gcl27-2.7.0/gcl-tk/intrs.h000077500000000000000000000000001454061450500151240ustar00rootroot00000000000000gcl27-2.7.0/gcl-tk/makefile000066400000000000000000000041721454061450500153270ustar00rootroot00000000000000 .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)$(EXE) $(LISPFLAGS)) .lisp.o: echo "(compile-file \"$*.lisp\" :c-file nil :c-debug nil)" | ../unixport/$(FLISP)$(EXE) $(LISPFLAGS) .lsp.o: echo "(compile-file \"$*.lsp\" :c-file nil :c-debug nil)" | ../unixport/$(FLISP)$(EXE) $(LISPFLAGS) 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 $(filter-out -pg,$(CFLAGS1)) -fPIE ${ODIR_DEBUG} $*.c # for some reason -lieee is on various linux systems in the list of requireds.. gcltkaux: $(GUIOS) $(LD_ORDINARY_CC) $(GUIOS) $(filter-out %gcl.script,$(LDFLAGS)) -pie -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 gcl27-2.7.0/gcl-tk/makefile.prev000066400000000000000000000060211454061450500162750ustar00rootroot00000000000000 .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 gcl27-2.7.0/gcl-tk/ngcltksrv000077500000000000000000000003651454061450500155720ustar00rootroot00000000000000#!/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 gcl27-2.7.0/gcl-tk/our_io.c000077500000000000000000000037231454061450500152730ustar00rootroot00000000000000 #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; } gcl27-2.7.0/gcl-tk/sheader.h000077500000000000000000000060031454061450500154110ustar00rootroot00000000000000 #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 (~(~0UL << 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(); gcl27-2.7.0/gcl-tk/socketsl.lisp000077500000000000000000000020361454061450500163470ustar00rootroot00000000000000(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 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")) gcl27-2.7.0/gcl-tk/socks.h000077500000000000000000000015521454061450500151240ustar00rootroot00000000000000#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 */ gcl27-2.7.0/gcl-tk/sysdep-sunos.h000077500000000000000000000002311454061450500164470ustar00rootroot00000000000000#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 gcl27-2.7.0/gcl-tk/tclwinkill.c000066400000000000000000000164461454061450500161560ustar00rootroot00000000000000/* gcc -fPIC -c -g -O2 testload.c gcc -shared tclWinkill.o -ltclstub -o winkill.dll and then load winkill.dll winkill -pid 23423 -signal INT # should rewrite this all to make more general utilitity: sharedmem init name length sharedmem set name ind value sharedmem get name ind length or to just init the shared memory.. winkill -pid 23423 */ #define USE_TCL_STUBS #include "windows.h" #include "tcl.h" #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLEXPORT #include #include #define signal_mask(n) (1 << (n)) typedef struct _sharedMemory sharedMemory; struct _sharedMemory { HANDLE handle; LPVOID address; DWORD length ; char name[20] ; int pid; sharedMemory *next; }; static sharedMemory *sharedMemoryPtr; #define MEMSIZE 0x10000 typedef struct {int signumber; char *name ;} sigNameStruct; sigNameStruct sigNames[]= { #ifdef SIGHUP { SIGHUP, "HUP" }, /* Hangup (POSIX). */ #endif #ifdef SIGINT { SIGINT, "INT" }, /* Interrupt (ANSI). */ #endif #ifdef SIGQUIT { SIGQUIT, "QUIT" }, /* Quit (POSIX). */ #endif #ifdef SIGILL { SIGILL, "ILL" }, /* Illegal instruction (ANSI). */ #endif #ifdef SIGTRAP { SIGTRAP, "TRAP" }, /* Trace trap (POSIX). */ #endif #ifdef SIGABRT { SIGABRT, "ABRT" }, /* Abort (ANSI). */ #endif #ifdef SIGIOT { SIGIOT, "IOT" }, /* IOT trap (4.2 BSD). */ #endif #ifdef SIGBUS { SIGBUS, "BUS" }, /* BUS error (4.2 BSD). */ #endif #ifdef SIGFPE { SIGFPE, "FPE" }, /* Floating-point exception (ANSI). */ #endif #ifdef SIGKILL { SIGKILL, "KILL" }, /* Kill, unblockable (POSIX). */ #endif #ifdef SIGUSR1 { SIGUSR1, "USR1" }, /* User-defined signal 1 (POSIX). */ #endif #ifdef SIGSEGV { SIGSEGV, "SEGV" }, /* Segmentation violation (ANSI). */ #endif #ifdef SIGUSR2 { SIGUSR2, "USR2" }, /* User-defined signal 2 (POSIX). */ #endif #ifdef SIGPIPE { SIGPIPE, "PIPE" }, /* Broken pipe (POSIX). */ #endif #ifdef SIGALRM { SIGALRM, "ALRM" }, /* Alarm clock (POSIX). */ #endif #ifdef SIGTERM { SIGTERM, "TERM" }, /* Termination (ANSI). */ #endif #ifdef SIGSTKFLT { SIGSTKFLT, "STKFLT" }, /* Stack fault. */ #endif #ifdef SIGCLD { SIGCLD, "CLD" }, /* Same as SIGCHLD (System V). */ #endif #ifdef SIGCHLD { SIGCHLD, "CHLD" }, /* Child status has changed (POSIX). */ #endif #ifdef SIGCONT { SIGCONT, "CONT" }, /* Continue (POSIX). */ #endif #ifdef SIGSTOP { SIGSTOP, "STOP" }, /* Stop, unblockable (POSIX). */ #endif #ifdef SIGTSTP { SIGTSTP, "TSTP" }, /* Keyboard stop (POSIX). */ #endif #ifdef SIGTTIN { SIGTTIN, "TTIN" }, /* Background read from tty (POSIX). */ #endif #ifdef SIGTTOU { SIGTTOU, "TTOU" }, /* Background write to tty (POSIX). */ #endif #ifdef SIGURG { SIGURG, "URG" }, /* Urgent condition on socket (4.2 BSD). */ #endif #ifdef SIGXCPU { SIGXCPU, "XCPU" }, /* CPU limit exceeded (4.2 BSD). */ #endif #ifdef SIGXFSZ { SIGXFSZ, "XFSZ" }, /* File size limit exceeded (4.2 BSD). */ #endif #ifdef SIGVTALRM { SIGVTALRM, "VTALRM" }, /* Virtual alarm clock (4.2 BSD). */ #endif #ifdef SIGPROF { SIGPROF, "PROF" }, /* Profiling alarm clock (4.2 BSD). */ #endif #ifdef SIGWINCH { SIGWINCH, "WINCH" }, /* Window size change (4.3 BSD, Sun). */ #endif #ifdef SIGPOLL { SIGPOLL, "POLL" }, /* Pollable event occurred (System V). */ #endif #ifdef SIGIO { SIGIO, "IO" }, /* I/O now possible (4.2 BSD). */ #endif #ifdef SIGPWR { SIGPWR, "PWR" }, /* Power failure restart (System V). */ #endif #ifdef SIGSYS { SIGSYS, "SYS" }, #endif { 0,0} }; int Tcl_WinKillCmd(ClientData clientData, Tcl_Interp *interp, int argc, char *argv[]); void close_shared_memory1(); void close_shared_memory(ClientData clientData); EXTERN int Tclwinkill_Init( Tcl_Interp *interp); static int refcount; int Tclwinkill_Init( Tcl_Interp *interp) { if (!Tcl_InitStubs(interp, "8.0", 0)) { return TCL_ERROR; } if (refcount==0) atexit(close_shared_memory1); refcount++; Tcl_CreateCommand(interp, "winkill" ,Tcl_WinKillCmd ,NULL,close_shared_memory); return TCL_OK; } void close_shared_memory(ClientData data) { if (--refcount <= 0) { sharedMemory *p,*old = sharedMemoryPtr; p = old; while (p) { if (p->handle) CloseHandle(p->handle); p->handle = NULL; if (p->address) UnmapViewOfFile(p->address); p->address = NULL; old = p; p = p->next; free(old); } } sharedMemoryPtr=NULL; } #define ErrorHandler(x) do {Tcl_AppendResult(interp,x,0); return NULL;} while(0) sharedMemory * getSharedMemoryPtr(Tcl_Interp *interp,int pid) { sharedMemory shm; sharedMemory * shmPtr = sharedMemoryPtr; while (shmPtr) { if (shmPtr->pid == pid) { return shmPtr; } shmPtr=shmPtr->next; } shmPtr = &shm; memset(&shm,0,sizeof(sharedMemory)); shmPtr->pid = pid; shmPtr->next = NULL; shmPtr->handle = NULL; sprintf(shmPtr->name,"gcl-%d",pid); { int value; int *at; shmPtr->handle = OpenFileMapping(FILE_MAP_WRITE, /* Read/write permission. */ FALSE, /* Do not inherit the name */ shmPtr->name); /* of the mapping object. */ if (shmPtr->handle == NULL) { ErrorHandler("winkill: Could not open file-mapping object."); } shmPtr->address = MapViewOfFile(shmPtr->handle, /* Handle to mapping object. */ FILE_MAP_WRITE, /* Read/write permission. */ 0, /* Max. object size. */ 0, /* Size of hFile. */ 0); /* Map entire file. */ if (shmPtr->address == NULL) { ErrorHandler("winkill: Could not map view of file."); } { sharedMemory *newPtr = malloc(sizeof(sharedMemory)); *newPtr = *shmPtr; newPtr->next = sharedMemoryPtr; sharedMemoryPtr = newPtr; } } } int Tcl_WinKillCmd(ClientData clientData, Tcl_Interp *interp, int argc, char *argv[]) {int sig=-1; int pid=-1; int i = 0; int value = 0; char *dosig = NULL; char *in; char *pidPtr = NULL; sharedMemory *shmPtr; sigNameStruct *sigNamePtr = sigNames; if (argc < 3 || argv[1][0] != '-') { { USAGE: Tcl_AppendResult(interp,"winkill -pid pid -signal SIG",0); return TCL_ERROR; } } for (i = 1 ; i < argc ; i+=2) { if (argv[i][0]!='-') { goto USAGE;} if (argv[i][1]=='s' && strcmp(&argv[i][1],"signal")==0) { in = &(argv[i+1][1]); if (sscanf(in,"%d",&sig)==0) { while(sigNamePtr->name) { if (strcmp(sigNamePtr->name,in)==0) { sig = sigNamePtr->signumber; break; } sigNamePtr++; } } if (sig<0) { Tcl_AppendResult(interp,"Bad Signal",0); goto USAGE; } value |= signal_mask(sig); } else if (argv[i][1]=='p' && strcmp(&argv[i][1],"pid")==0) { pidPtr = argv[i+1]; if (1 != sscanf(argv[i+1],"%d",&pid)) { Tcl_AppendResult(interp,"Bad pid arg:",argv[2],".",0); goto USAGE; } } else goto USAGE; } if (pidPtr== NULL || (shmPtr = getSharedMemoryPtr(interp,pid))==NULL) { Tcl_AppendResult(interp,"Could not open shared memory for pid ", pidPtr,0); return TCL_ERROR; } { int *at; at = (int *)(shmPtr->address); *at |= value; } return TCL_OK; } void close_shared_memory1() { refcount=0; close_shared_memory(NULL); } gcl27-2.7.0/gcl-tk/tinfo.lsp000077500000000000000000000450271454061450500154750ustar00rootroot00000000000000;; 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: *** gcl27-2.7.0/gcl-tk/tk-package.lsp000077500000000000000000000016001454061450500163520ustar00rootroot00000000000000(unless (find-package "TK") (make-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") gcl27-2.7.0/gcl-tk/tkAppInit.c000077500000000000000000000070351454061450500157020ustar00rootroot00000000000000/* * 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; } gcl27-2.7.0/gcl-tk/tkMain.c000077500000000000000000000440611454061450500152220ustar00rootroot00000000000000/* * 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] ; snprintf(buf,sizeof(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, (void *)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, (void *)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); */ /* } */ /* */ gcl27-2.7.0/gcl-tk/tkXAppInit.c000077500000000000000000000106301454061450500160250ustar00rootroot00000000000000/* * 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; } gcl27-2.7.0/gcl-tk/tkXshell.c000077500000000000000000000274021454061450500155750ustar00rootroot00000000000000/* * 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); } } gcl27-2.7.0/gcl-tk/tkl.lisp000077500000000000000000001377751454061450500153350ustar00rootroot00000000000000;; 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 fsubseq (s &optional (b 0) (e (length s))) (make-array (- e b) :element-type (array-element-type s) :displaced-to s :displaced-index-offset b :fill-pointer (- e b))) (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* (fsubseq 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 (fsubseq 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*))) "" (fsubseq 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 (fsubseq 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 ""))) (assert (array-has-fill-pointer-p string)) (setf (fill-pointer string) start) (si::c-set-stream-object0 s 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 (fsubseq 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 (fsubseq x beg i) ans)) (setq skipping t))) (incf brace-level -1))))) finally (unless skipping (setq ans (cons (fsubseq 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))) (fsubseq 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"))) (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) (si::system command)) (can-rsh (si::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: *** gcl27-2.7.0/gcl-tk/tktst.c000077500000000000000000000126221454061450500151460ustar00rootroot00000000000000/*-*-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; } gcl27-2.7.0/gcl-tk/winkill.c000066400000000000000000000127041454061450500154440ustar00rootroot00000000000000#include #include #include #include #define signal_mask(n) (1 << (n)) /* Meant to resemble kill under unix. Basic idea is that the process we want to kill, has a shared memory segment, and we write into it the flag of the signal we want to send. That process has to frequently check that memory location. Sample USAGE: winkill -SIGNAL ProcessID eg: C:> winkill -INT 243232 */ static struct { HANDLE handle; LPVOID address; DWORD length ; char name[20] ; } sharedMemory = {0,0,0x10000} ; typedef struct {int signumber; char *name ;} sigNameStruct; sigNameStruct sigNames[]= { #ifdef SIGHUP { SIGHUP, "HUP" }, /* Hangup (POSIX). */ #endif #ifdef SIGINT { SIGINT, "INT" }, /* Interrupt (ANSI). */ #endif #ifdef SIGQUIT { SIGQUIT, "QUIT" }, /* Quit (POSIX). */ #endif #ifdef SIGILL { SIGILL, "ILL" }, /* Illegal instruction (ANSI). */ #endif #ifdef SIGTRAP { SIGTRAP, "TRAP" }, /* Trace trap (POSIX). */ #endif #ifdef SIGABRT { SIGABRT, "ABRT" }, /* Abort (ANSI). */ #endif #ifdef SIGIOT { SIGIOT, "IOT" }, /* IOT trap (4.2 BSD). */ #endif #ifdef SIGBUS { SIGBUS, "BUS" }, /* BUS error (4.2 BSD). */ #endif #ifdef SIGFPE { SIGFPE, "FPE" }, /* Floating-point exception (ANSI). */ #endif #ifdef SIGKILL { SIGKILL, "KILL" }, /* Kill, unblockable (POSIX). */ #endif #ifdef SIGUSR1 { SIGUSR1, "USR1" }, /* User-defined signal 1 (POSIX). */ #endif #ifdef SIGSEGV { SIGSEGV, "SEGV" }, /* Segmentation violation (ANSI). */ #endif #ifdef SIGUSR2 { SIGUSR2, "USR2" }, /* User-defined signal 2 (POSIX). */ #endif #ifdef SIGPIPE { SIGPIPE, "PIPE" }, /* Broken pipe (POSIX). */ #endif #ifdef SIGALRM { SIGALRM, "ALRM" }, /* Alarm clock (POSIX). */ #endif #ifdef SIGTERM { SIGTERM, "TERM" }, /* Termination (ANSI). */ #endif #ifdef SIGSTKFLT { SIGSTKFLT, "STKFLT" }, /* Stack fault. */ #endif #ifdef SIGCLD { SIGCLD, "CLD" }, /* Same as SIGCHLD (System V). */ #endif #ifdef SIGCHLD { SIGCHLD, "CHLD" }, /* Child status has changed (POSIX). */ #endif #ifdef SIGCONT { SIGCONT, "CONT" }, /* Continue (POSIX). */ #endif #ifdef SIGSTOP { SIGSTOP, "STOP" }, /* Stop, unblockable (POSIX). */ #endif #ifdef SIGTSTP { SIGTSTP, "TSTP" }, /* Keyboard stop (POSIX). */ #endif #ifdef SIGTTIN { SIGTTIN, "TTIN" }, /* Background read from tty (POSIX). */ #endif #ifdef SIGTTOU { SIGTTOU, "TTOU" }, /* Background write to tty (POSIX). */ #endif #ifdef SIGURG { SIGURG, "URG" }, /* Urgent condition on socket (4.2 BSD). */ #endif #ifdef SIGXCPU { SIGXCPU, "XCPU" }, /* CPU limit exceeded (4.2 BSD). */ #endif #ifdef SIGXFSZ { SIGXFSZ, "XFSZ" }, /* File size limit exceeded (4.2 BSD). */ #endif #ifdef SIGVTALRM { SIGVTALRM, "VTALRM" }, /* Virtual alarm clock (4.2 BSD). */ #endif #ifdef SIGPROF { SIGPROF, "PROF" }, /* Profiling alarm clock (4.2 BSD). */ #endif #ifdef SIGWINCH { SIGWINCH, "WINCH" }, /* Window size change (4.3 BSD, Sun). */ #endif #ifdef SIGPOLL { SIGPOLL, "POLL" }, /* Pollable event occurred (System V). */ #endif #ifdef SIGIO { SIGIO, "IO" }, /* I/O now possible (4.2 BSD). */ #endif #ifdef SIGPWR { SIGPWR, "PWR" }, /* Power failure restart (System V). */ #endif #ifdef SIGSYS { SIGSYS, "SYS" }, #endif { 0,0} }; int ErrorHandler(char *s) { fprintf(stderr,s); fflush(stderr); exit(1); } void close_shared_memory() { if (sharedMemory.handle) CloseHandle(sharedMemory.handle); sharedMemory.handle = NULL; if (sharedMemory.address) UnmapViewOfFile(sharedMemory.address); sharedMemory.address = NULL; } int main(int argc, char *argv[]) { int sig=-1; int pid=-1; char *in; sigNameStruct *sigNamePtr = sigNames; if (argc < 3 || argv[1][0] != '-') { USAGE: fprintf(stderr,"Sample usage: winkill -INT 232423, to interrupt the process 232423 "); {int i = 0; fprintf(stderr,"\nargv[1][0]=%c,%d",argv[1][0],argv[1][0]); fprintf(stderr,"\nCalled with: argc=%d <",argc); while (i < argc) fprintf(stderr, " %s",argv[i++]); fprintf(stderr,">\n"); } exit(1); } in = &(argv[1][1]); if (sscanf(&(argv[1][1]),"%d",&sig)==0) { while(sigNamePtr->name) { if (strcmp(sigNamePtr->name,in)==0) { sig = sigNamePtr->signumber; break; } sigNamePtr++; } } if (sig<0) { fprintf(stderr,"[had sig=%d]\n", sig); goto USAGE; } if (sscanf(argv[2],"%d",&pid)!=1 ) { fprintf(stderr,"sscanf(argv[2],\"%d\",&pid) failed for %s,%d", argv[2],atoi(argv[2])); goto USAGE; } sprintf(sharedMemory.name,"gcl-%d",pid); { int value; int *at; value = signal_mask(sig); sharedMemory.handle = OpenFileMapping(FILE_MAP_WRITE, /* Read/write permission. */ FALSE, /* Do not inherit the name */ sharedMemory.name); /* of the mapping object. */ if (sharedMemory.handle == NULL) { ErrorHandler("winkill: Could not open file-mapping object."); } 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) { ErrorHandler("winkill: Could not map view of file."); } at = (int *)(sharedMemory.address); *at |= value; close_shared_memory(); exit(0); } } gcl27-2.7.0/gcl.ico000066400000000000000000000557161454061450500137210ustar00rootroot00000000000000 èv00h^ ¨Æ 00¨n h!  ¨~%00 ¨%&6( @€€€€€€€€€€€€ÀÀÀÿÿÿÿÿÿÿÿÿÿÿÿÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌGw||ÌÌÌÌÌÌÌÌÌÌÌÿÿÿÿ‡ÌÌÌÌÌÌÌÌÌÈÿÿÿÿÿÿÿtÌÌÌÌÌÌÌÄxÿÿÿÿÿÿÿ‡ÌÌÌÌÌÌÌÌGÿÿÿÿÿÿ‡ÌÌÌÌÌÌÌGÿÿÿÿÿÿÿ|ÌÌÌÌÌGÿÿÿÿÿÿÿÿÿôÌÌÌÌÌÌDGÿÿÿÿÿÿ÷ÌÌÌÌÌÌÌÇÿÿÿÿÿÿÿ‡wÄDLÌÌÌÈÿÿÿÿÿÿÿÿˆÄtÌÌÌÄwˆÿÿÿÿÿÿÿ‡ÌÌÌÌÌÌxÿÿÿÿÿÿÿ‡ÌÌÌÌÌÌÄÿÿÿÿÿÿÿøLÌÌÌÌÄwÿÿÿÿÿÿÿÿôÌÌÌÄÿÿÿÿøwÿÿÿÿ÷ÌÌÌÇÿÿÿÿøÌÄÿÿÿÿôÌÌÌÌGÿÿŒÌÿÿÿÿŒÌÌÌĈÿÿÿ|ÌxÿÿÿÿŒÌÌÌÇÿÿÿ÷ÌÇÿÿÿÿÿLÌÌÌÌLG|ÌÿÿÿÿøÌÌÌÌÌÌøÌÌÄÿÿÿ÷ÌÌÌÌÌÄø|ÌÌÌÿÿÿŒÌÌÌÌÌÄŒÌÌÌOÿÿÿÿLÌÌÌÌÌÌÌÌÌÌGGÿ÷ÌÌÌÌÌÌÌÌÌÌÌÌÌÿŒÌÌÌÌÌÌÌÌÌÌÌÌOÿ÷ÌÌÌÌÌÌÌÌÌÌÌÌÄÿø|ÌÌÌÌÌÌÌÌÌÌÌÌÇø|ÌÌÌÌÌÌÌÌÌÌÌÌÌÇÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌ(0`€€€€€€€€€€€€€ÀÀÀÿÿÿÿÿÿÿÿÿÿÿÿÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÄGGDÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌGÿÿÿø‡DÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌxÿÿÿÿÿÿÿÿ‡ÌÌÌÌÌÌÌÌÌÌÌÌÌÇÿÿÿÿÿÿÿÿÿÿøtÌÌÌÌÌÌÌÌÌÌÌÌÿÿÿÿÿÿÿÿÿÿÿwLÌÌÌÌÌÌÌÌÌÌÄxÿÿÿÿÿÿÿÿÿÿÿ‡LÌÌÌÌÌÌÌÌÌÌÄGxÿÿÿÿÿÿÿÿÿÿ÷LÌÌÌÌÌÌÌÌÌÌÌ@ÿÿÿÿÿÿÿÿÿÿ„ÌÌÌÌÌÌÌÌÌÄGˆÿÿÿÿÿÿÿÿÿÿÿøLÌÌÌÌÌÌÌÌxÿÿÿÿÿÿÿÿÿÿÿÿÿÿ|ÌÌÌÌÌÌÌÌDwˆÿÿÿÿÿÿÿÿÿÿ„ÌÌÌÌÌÌÌÌÌÄDDÿÿÿÿÿÿÿÿÿÿôÌÌÌÌÌÌÌÌÌÌÌÇÿÿÿÿÿÿÿÿÿÿÿwvLÄDLÌÌÌÌÌÌoÿÿÿÿÿÿÿÿÿÿøÿ‡wLDÌÌÌÌÇOÿÿÿÿÿÿÿÿÿÿˆÿÿøx\DLÌÌÌÌÌÄxÿÿÿÿÿÿÿÿÿÿÿÿÿ‡ÌÄÌÌÌÌÌÌÌE6Xÿÿÿÿÿÿÿÿÿÿ‡LÌÌÌÌÌÌÌÌÌOÿÿÿÿÿÿÿÿÿÿÿ‡LÌÌÌÌÌÌÌÌÌÅÿÿÿÿÿÿÿÿÿÿ÷ ÌÌÌÌÌÌÌÌÌÇHÿÿÿÿÿÿÿÿÿÿÿø‡ÌÌÌÌÌÌÌGwxÿÿÿÿÿÿÿÿÿÿÿÿÿøLÌÌÌÌÌGÿÿÿÿÿÿÿˆwÿÿÿÿÿÿøÌÌÌÌÌÌÿÿÿÿÿÿÿw|ÄÿÿÿÿÿøÌÌÌÌÌÄÿÿÿÿÿÿ‡ÌÌHÿÿÿÿÿÿ÷ÌÌÌÌÌÌDwÿÿÿÿ|ÌÇÿÿÿÿÿÿ÷ÌÌÌÌÌÌÄGÿÿÿø|ÌÇÿÿÿÿÿÿÿôÌÌÌÌÌÌxÿÿÿÿÿ÷ÌÌÄÿÿÿÿÿÿ„ÌÌÌÌÌÄÿÿÿÿÿ|ÌÆxÿÿÿÿÿÿÿ|ÌÌÌÌÌÌGwwÿ÷LÌÈÿÿÿÿÿÿÿøLÌÌÌÌÌÌÌÌÇÿtÌÌHÿÿÿÿÿÿ÷ÌÌÌÌÌÌÌÌÌHÿ÷ÌÌÌÌWÿÿÿÿÿôÌÌÌÌÌÌÌÌÌÿtÌÌÌÌÆÿÿÿÿÿ|ÌÌÌÌÌÌÌÌÅÿ‡ÌÌÌÌÌÿÿÿÿÿø|ÌÌÌÌÌÌÌÌƇLÌÌÌÌÇÿÿÿÿÿÿ÷ÌÌÌÌÌÌÌÌÌÄÌÌÌÌÌÌHøˆÿÿÿ„ÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÄDLOÿÿølÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÄÿÿ÷ÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌXÿÿø\ÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÆÿÿ‡ÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌWÿÿ÷LÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÿøLÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÄÿˆDÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÇeLÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÿÿÿÿÿÿÿÿÿÿÿÿ( @mu\20Z[Ys@@m_^{UU› Ž˜œ—›™µ¹¸ ¥ª¨¯¬¤­¹³¶ºº)'!"‘-,™99Ÿ98¡! ©!!¡+*¯..µ""»$$².-®0/µ44¸67´9:¼<;º==ÈÅÂÍ ÑÕÑ Ù Þ ÖËÕÛÜäááåëáé î òõóõúþûùþõ ù þù ý àæêþýÊ##Ï&&Ç('Ú! Õ89ë##ž?@‚EE‰LM•EECC™DE—JJŠYZ‰\\__TU™QQžXX«DD¥QQªQQ­VW‹aaˆgh–ij‹uwœqqšwx§ce¡dd³hi¹ih©}}¸uv´yy×FGÒ__Ã|}Ðvu„€ƒ„„–††žŒ‹“”””¢……¨€¦ŠŠ±‡‡ªª”” œ¦œœª›š¯šš¶œš¢¢¢®¯®º¦¦°°°³´´´µµ¼»»½¾¾ÅŽÇ̲³ÄÄÃÅÅÆÍÅÅÊÊÊÍÌÍÑÏÑÖÕÕßÑÑÙÖÖØ×ØÛÛÛÝÙÙßßÞãããããäåååèæçæçèéèèïïðñññö÷öùùùûüüþþþKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK5.yzz{~]3>KKKKKKKKKKKKKKKKKKKKZ›­µµµµµµµµŠ}FKKKKKKKKKKKKKKKQ>¦µµµµµµµµµµµµµ¨|$>KKKKKKKKKKKKKK:ˆ µµµµµµµµµµµµµµ™k1KKKKKKKKKKKKKK0 p²µµµµµµµµµµµµ¨iDKKKKKKKKKKKK>#w³µµµµµµµµµµµµµµqFKKKKKKKKKK1‚³µµµµµµµµµµµµµµµµµ²#KKKKKKKKKKK0 `‚µµµµµµµµµµµµµµmKKKRKKKKKKKKKKFr²µµµµµµµµµµµµµ­†„"5 7KKKKKK^“µµµµµµµµµµµµµ¯µµµ––= KKKKKQWh’–™µµµµµµµµµµµµµµ¦aKK9KKKKKKKWK"®¨µµµµµµµµµµµµµ¢bKKKKKKKKKKKQ ®µµµµµµµµµµµµµµ“UKKKKKKKKF#_j†«µµµµµµµµµµµµµµµµµ+KKKKKKKŽ²µµµµµµµµµ¤€¯µµµµµµµµ-KKKKKKKsµµµµµµµµµœ\WFe°µµµµµµµµKKKKKKK; µµµµµ­[KP‡µµµµµµµµµ¦7KKKKKKKZŒ¦µµµµµµwKQF¦µµµµµµµµ‘KKKKKKKKg®µµµµµµ‰VK=ˆ¯µµµµµµµµµ*KKKKKKKKFµµ‹7KK.¯µµµµµµµµµŸBKKKKKKKKKKQh²µŽCKKKQµµµµµµµµoKKKKKKKKKKK­¯tDKKKKQ+¦µµµµµµµUKKKKKKKKKKKš'KKKKKK*­µµµµµµµµdKKKKKKKKKKKKKKKKKKKKK(od.uµµµµ‰PKKKKKKKKKKKKKKKKKKKKKKKK%­µµµ”3KKKKKKKKKKKKKKKKKKKKKKKK­µµµŽ9KKKKKKKKKKKKKKKKKKKKKKKK µµ¥lHKKKKKKKKKKKKKKKKKKKKKKKKQƒµ x;KKKKKKKKKKKKKKKKKKKKKKKKKKQ+>KKKKKKKKKKKKKKKKÿÿÿÿÿÿÿÿ(0` "' R_U]a |qzmifvyum+*w$$x""q))|..l>>r11y66A@?KJL[[XoGIlKLqBAuEGjOPOPlTTm\]tYYdedmcclkklmkmnnueavbdtefthgvhjvrsysr{{z†… ‹ “œ’ ‘™•ƒ‹Ž’¦¤ ¬ ·´ ± ¤£¤³¹±ºŽ .,‰))Ž*)%'%$‘-+Ž12‹7:??•3369¢!"¦,,¥96ÆÈÇ ÆÌ ÓÕÒÑÝÕ ÆËÄÃÂÌÚÜâæåìîá æ ãë òöñúþùøþñ ö ô ó öý ïûíéçãæëöûþúþøÄ%%Ï++Ø"$Ñ')Ú))È02þ##þ..þ33ÿ??…AB…FEƒLM˜DB—KK†SS†YZ“^^˜\_¥CCƒaaoo†us{|‹}{¦xx¦«´}~×ZYÊ~}}€€€ƒ€€‡Šˆ‹‹‘ŒŒ˜‰‹Ž‘”‘‘‘“”•••™–—˜—™—šššš ¹‡‡¡³œœ  Ÿ¡Ÿ ¢¢£¯¢¡©©§®­­³««°®«¶­­°¯±²²±³³µµ¶µ»±³¼³³·¸¸¹¹¹½»¼½½½Â««ÁÁ¿ÃÃÃÄÁÁÃÄÄÆÆÆÈÄÂÉÊÊËÌÊÌÌÊÍÏÎÑÎÏÑÐÑÕÕÖØÖ××Ù×ÙÙ×ÚÛÚÝÚÝÝÝÝßàßâââçæèéééìêëëìëíííññðõõõø÷øùùùûûüþþþhEU[£]LdvvL³çûÿÿÿÿÿÿÿòÔ³Z6h†¬âÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿúݵ}—ªÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿûÚ§;voÏÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿöÄ!:}v±áÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿë.;w};#Ãïÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿö1C†C+ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿà†l-ÇëÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿáAØÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ3y} 2ÇÔàçôöÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿò;zo:88òÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿöCŠ˜Šh.öÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÇ4&dvAG—ŠŠÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿóÐÿÿÿÌ¥©+Nk¢ôÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿëØÿÿÿÿÿûÃЙ›K m†—¡j®áûÿûûÿÿÿÿÿÿÿÿÿÿÿÿÿÿûÿÿÿÿÿÿÿç!H’e((Ýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿá2jŠ Š?ôÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿò#9}Š7áÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ¿m„_ÌÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÝÝÂy†J!&1,ÐûÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿéaN%ØüÿÿÿÿÿÿÿÿÿÿÿÿÿÿûÚÉËÿÿÿÿÿÿÿÿÿÿÿÿÿälhÃÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿß·¶— ^ÐÿÿÿÿÿÿÿÿÿÿÿÿØr9Êûÿÿÿÿÿÿÿÿÿÿÿÿû«†ŠG½ÿÿÿÿÿÿÿÿÿÿÿÿÿ¿z—K#4çÿÿÿÿÿÿÿÿÿÇ‘—£çÿÿÿÿÿÿÿÿÿÿÿÿÿÿ­ŠŠ™T+ÐÿÿÿÿÿÿÿÿöX—yºöÿÿÿÿÿÿÿÿÿÿÿÿÿÿW˜RÔÿÿÿÿÿÿÿÿÿÿÿ­†ŠŠCÿÿÿÿÿÿÿÿÿÿÿÿÿÝqQÌÿÿÿÿÿÿÿÿÿÿÿ¼œŸP­ëÿÿÿÿÿÿÿÿÿÿÿÿÿÿ­@&°¿¿¿¸ÿÿÿÿÄHwÌÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿöGŠwz`»ÿÿÿÃNŠqÇöÿÿÿÿÿÿÿÿÿÿÿÿÿÿÈ}Š\ÊÿÿÿÇQžT¨ØÿÿÿÿÿÿÿÿÿÿÿûV¸ÿÿÿ¯™Š}!îÿÿÿÿÿÿÿÿÿÿÿÃûÿô'sŠ—k©ûÿÿÿÿÿÿÿÿÿÿÿö\Sö´R}’1ÿÿÿÿÿÿÿÿÿÿÿÿÿ°{NJKéüòçíëÿÿÿÿÿÿÿéW‘55>Faôÿÿÿÿÿö?åÿÿÿÿÿû%w@åÿÿÿÿÿûwŠŠÜÿÿÿÿÿë$—J½ÿÿÿÿÿ½Ch)ÿÿÿÿÛ¦}Š— ôÿöÍ]aš$\PjŠÿÿÿÿÿÿÿÿÿÿÿÿ(  @©­¬­­­®­¬­«­®­©­§­§­§­§­§­§­§­§­ÿÿç]]ÿß¾¾ÿÎØØÿæÊÊÿí–˜ÿÍEEÿüÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿØ44ÿÒÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿùÿÿÿÄ´µÿ¸..ÿôÿÿÿÿÿÿÿÿÿÿÿÿÿþýkÿÆÖ×ýÿÿÿÿýýýýÿÿÿÿþÿÿýÿÿÿÿÿÿÿýÊøøÿÎýÿÿýýÿÿýýÿÿ«&&ÿƼ»ÿ¼˜˜ÿÕÜÜÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ»­­ÿÿÿÿÿÿÿÿÿÿÿÿýÿÿ²==ýÿÿÿÿÿÿÿýÿÿÿÿýýýýÿÿÿÿþþþýÿýýÿÀÎÎýÉÒÐÿ—rtýt ÿ ýÿÿÿÿÿÿÿÿkkÿÀÈÆÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿüüüÿÿÿÿÿÜâäÿ±NMÿÿÿûÿÿÿâýºÿ¦NNýÿÿÿÿÿÿÿýÿÿÿÿÿÿÿýÿÿÿÿýýýýÿÿÿÿèø÷ý£<:ÿÿýÿÿÿýÁÿíÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿôÿÿÿéxxÿ²ÿ÷ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿͬ­ÿÿÿÿÿÿÿ÷ÿvdcýÿÿÿÿÿÿÿýÿÿÿÿ»HGýÿÿ—²²ýÿÿÿÿýýýýÿÿÿÿÿÿÿýËYWÿÿýÿÿýýÚ ÿמŸÿ£vvÿÿÿÿÿ«ÿÿÿ®ˆˆÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿôÿÿÿÜÿÿÿÿÿÿÿÿÿïý×ÿÿÿ°‘‘ýÿÿÿýÚÿÄÜÜýÿÿÿÿýýýýÿÿÿÿ¿’“ýÿÿýýÿÿýýÿÿãÿÑ((ÿÿÿÿÿÿÿ¡††ÿÙ¥¥ÿÛ××ÿÿÿÿÿäÿÿÿÛÿÿÿÿÿÿÿÿÿÿÿÿýÿÿýýÿÿýýÿÿªýÿÿÿÿèÿÿýÂÿÿýÿÿýýÿÿýýÿÿÿÿÿÿÿÿÿÿÿÿÂÿþÿÿÿÔ¢¢ÿëÿÿÿÿÿÿÿÿÿÿÿÿÿ§­§­§­§­§­ª­— ­‰­²­«­§­§­§­§­§­§­( @ €P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿËý¡'%ÿ¤edÿ‰ÿ‹ýžsuÿÇWVÿÉ!#ÿ¶ýäÿÿÿÿÿÿýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿý¿ý­˜—ýéÿÿþÿÿÿýÿÿÿýÿÿÿýÿÿÿþÿÿÿýÿÿÿýÿÿÿýÿÿÿþ²ÝßýŠ‰ýË35ýöþÿýÿýÿýþþýýýýýýþþýýýýýýþþýýýýýýþ þÙÿÐÿÿÿÿÿÿÿÿÿÿýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿþþþýÿÿÿÿÿÿÿÿÿÿÿÿÕÿÿý–uuÿÿèÿÿýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿ½ÿ††ÿ¾ååýÿÿÿÿÿÿÿÿÿÿÿÿþþÿýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿýÿÿÿÿÿÿÿÿ¤ÓÓÿrGGý´ÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿÁýÿnGHÿ„‡†ÿÿÿÿýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿýßÿÿÿP;=ÿÿÿÿýÿÿÿÿÿÿýýÿÿÿÿÿÿýýýýýýÿýÿþŠý”LLý‹‡‡ýÿÿÿþþþÿýýýýýýýýýþþþþýýýýýýýýýýýýþþþþýýýýýýýýýýýýþþþþÿÿÿýÿÿÿý@VXýÿþÿýýýýýþþýýýýýýþþÿÿÿÿ®ÿI¨ªýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿuýÿÿÿÿÿÿþýÿÿÿÿÿÿýýÿÿÿÿÿÿØýtÿd ÿq ÿgýFRRÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿŠ>>ýÿÿÿÿÿÿÿýÿÿÿÿÿÿÿýÿÿÿÿÿÿÿýÿÿÿÿÿÿu]^ýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿòòòÿpýœ›ÿvÿëÿ@ýxÿ;ÿ¹ÿßýýýýýýýþþýýÿýíý™áßþÿÿÿýÿÿÿýÿÿÿýÿÿÿþýýýýýýýýýýýýþþþþýýýýýýýýýýýýþþþþÿÿÿýèççý¤¤¢ýÿÿÿþÿÿÿýÿÿÿý›¿¿ý¿ûûþôý‚ýŒýþÿÿÿÿÿÿýýÿÿÿÿÿÿ¤ýnNNÿˆÿ›››ÿŸ¡¡ýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿöööÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿæÿÿÿO<=ýÿÿÿÿËÿÿýÿÿÿÿÿÿýýÿÿÿÿÿ ÿÿýpÿþÿÿÿÛÛÚÿÿÿÿýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿýßðôÿf! ÿ¢ÿÿýÿÿÿÿÿÿýýÿÿÿÿÿÿÿýÿÿÿÿÿÿ[ý÷ÿÿÿÿÿÿÿÿÿÿÿþþþýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿ•œšýÿÿÿÿÿþýÿÿÿÿÿÿýýýýÿýÿý{þ},-ýw:9ýaýôÿÿþÿÿÿýýýýýýýýýþþþþþþþýÿÿÿýÿÿÿýÿÿÿþÿÿÿýýýýýýýýýþþþþýýýýýýýýýýýýÿÿÿþÿÿÿý˜!ýÿýþþýýýýýýþþÿÿ§ÿ}­­ÿÿÿÿýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿýÿÿÿÿÓððÿÂb`ÿ¸]_ýåññÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿ›')ÿÿÿýýÿÿÿÿÿÿýýÿÿQ‘•ÿÿÿÿÿÿÿÿýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿ¹ÇÉýËÿÿÿÿÿaýùÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿþþþýÿÿÿÿ‰ÿÿÿýýÿÿÿÿÿÿýýÿÿåÿ†ÿ,+)ý·¹¹ÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿèÿÿÿ¯ýÿÿÿÿ§§ÿÿÿÿýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿýËññÿÖÿÿÿýýÿÿÿÿÿÿýýÿýÏý•¢¢ýåééþÿÿÿýþþþýýýýýþþþþýýýýÿÿÿýtQTýÿþÿ ýÿý0 ýÖÝÞþÿÿÿýýýýýýýýýþþþþýýýýýýýýýýýýÿÿÿþš®«ýÿýýýþþýýýýýýþþÿÿHllÿÿÿÿÿÿÿÿýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿuÿùÿÿýßÿ|†ƒÿÿÿÿÿÿÿÿýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿý‡ ÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿžÿŒý«ÿÿÿÿÿÿÿÿÿý|––ÿäÿÿÿÿý“-/ÿÿÿÿÿÿÿÿÿþþþýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿ¼ååýóÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿÿýP?@ÿÿÿÿÿÿÿÿÿz©§ýéÿÿÿÿÿþýÿÿ³ÿ5ÿÿÿÿýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿ„ABýÿÿÿÿÿÿýýÿÿÿÿÿÿýýýýýýÿý’þÿÿÿýÿÿÿý`ghýûþÿýýýýýþþÿý”ýßúúýÿÿÿþýýýýýýýýýýýýþþþþýýýýÿÿÿý¶èèýâþÿýýýýýþþýýýýýýþþÿÿÿÿÿÿ‹ ý½¼½ÿÿÿÿÿýÿÿÿÿÿÿÿý‰ÿÿÿÿÿÿÿÿÿÿÿÿýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿ`$&ÿÿýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿÿýÿÿÿÿÿÿýýÿÿÿÿÿÿÿý©&&ÿOOÿu--ÿ½ýfABÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿtŒŒÿÿÿÿýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿþýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿvýöÿÿÿÿÿÿÿÿÿÿÿÿÿÿý›»»ÿÉÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿýýýýýýýýþþýýýýýýþþýýýýýýþþýýÿýSýôÿÿþÿÿÿýÿÿÿýÿÿÿý„¨¨þËýÿýýýþþýýýýýýþþýýýýýýþþÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿ“ÿÍø÷ÿÿÿÿýÿÿÿÿÖÿÿÿ|""ÿþýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿþýÿÿj¨§ÿÿÿÿÿ½íïý^_ÿËÿÿÿÿýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ¸::ÿ¶ÿùÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿP\P\P\P\P\P\P\P\P\P\P\P\P\\\[\U\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\(0` €%ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿýýþþþþþþýýÿÿÿýÿþÿþÿýÿÿÿýÿþÿþÿþýýÿÿýýþþþþþþþþýýÿÿýýþþþþþþýýÿÿýýþþþþþþýýÿÿýýþþþþýýÿÿýýþþþþþþþþþþÿÿýýþþÿþÿþÿýËÿ†ýfþV..þIý\01ÿk#ýþ´þáþÿýÿÿÿýÿþÿþÿþþþýýÿÿýýþþþþþþýýÿÿýýþþþþþþýýÿÿýýþþþþýýÿÿýýþþþþþþþþþþÿÿÿýÿþæþ{þ‚‚ƒýÀéçÿÿÿÿýÿÿÿþÿÿÿþÿÿÿýÿÿÿÿÿÿÿýÿÿÿþÿÿÿþ×þþþš½½ýŠwwÿa ýPþÖþÿþÿþÿýÿÿýýþþþþþþýýÿÿýýþþþþþþýýÿÿýýþþþþýýÿÿýýþþþþþþþþþþÿÿÿýv""ý²áàýÿÿÿýÿÿÿýÿÿÿÿÿÿÿýýýýýýýýýýýýýÿÿÿÿýýýýýýýýþþþýÿÿÿýÿÿÿýÿÿÿÿÿÿÿýÿÿÿý§ÐÑý’€‚ýçýøýÿÿÿýÿýýýýýýýÿÿýýýýýýýýýýÿÿýýýýýýýýÿÿýýýýýýýýýýýýÿÿXkkÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ¢ÇÊÿo33ÿaÿóÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿºý‰¶´ýÿÿÿýÿÿÿýÿÿÿýÿÿÿÿýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýýýýýýýýýÿÿÿýÿÿÿýÿÿÿÿÿÿÿýuŸý3)'ý|ýÿýÿÿÿýýýýýýýýýÿÿýýýýýýýýÿÿýýýýýýýýýýýýÿÿÿýúþ=þ`}yþÁÜÜýÿÿÿÿÿÿÿýÿÿÿþÿÿÿþýþþýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþþþþþýýýýÿÿÿÿÿÿÿýÿÿÿþÿÿÿþÛ÷÷þ6SVýcÿÿýÿþþþþþýýÿÿýýþþþþýýÿÿýýþþþþþþþþþþÿÿýýÿþÿþÿþrýÿ59;ý€™™þöû÷þÿÿÿýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþÿÿÿþÿÿÿýÿÿÿÿ0WUýjþÿþÿþýýÿÿýýþþþþýýÿÿýýþþþþþþþþþþÿÿýýýýýýÿýÿýÿÿÿýŽýý152ýÿÿÿÿýýýýýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýýýýýýýýýýýýýÿÿÿÿÿÿÿý½ÝÝý'ýÿýþýÿÿýýýýýýýýÿÿýýýýýýýýýýýýÿÿÿÿÿÿÿÿÿÿÃÿ?ÿA\Uÿ‰žŸÿïòõÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÈååÿKÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿýýþýÿý?RTý¹çëýÿÿÿÿÿÿÿýÿÿÿýÿÿÿýÿÿÿýÿÿÿÿÿÿÿýýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýÿÿÿý@kiýõýÿÿýýýýýýýýÿÿýýýýýýýýýýýýÿÿýýÿþÿþ=þG54ýHqsÿ†¢ ý§¼¸þ¿ØÕþÉãàýùÿÿÿÿÿÿýÿÿÿþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþÿÿÿþíÿÿþhýÿÿýýþþþþÿýÿÿýýþþþþþþþþþþÿÿýýþþÿþÿþÿýùÿ¾ýƒþ{þ‡ý2ÿýïïïþÿÿÿþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþÿÿÿþÿÿÿþrýÿÿÿýÿþÿþõýÿ ÿÿýÿþÿþþþþþþþÿÿýýþþþþþþýýÿÿÿýÿþÿþùý>SUÿÿÿÿýÿÿÿþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþÿÿÿþ}}þ[rqý=WWÿ/ýÉþÿþþýaÿKý¦ þO&&þÿþÿþÿþÿÿýýýýýýýýýýÿÿýýýýÿý: ýÿÿÿÿÿÿÿýýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýýýýýýýýýýýýýÿÿÿÿýýýýÿÿÿýäæåý††‚ýÿÿÿýÿÿÿÿÿÿÿý†­­ýU+-ýz[ZýM~ÿ¼ýÿýý_ý&$ýK87ýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ[[ÿ@ÿýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÁÿ’ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿr~ÿÈèëÿÁÿÞ.1ÿ¤ ÿO ÿá ÿÿ ÿÿÿýýýýýýýýýýÿÿýýý ýÿHHýóý@ÿUiiýÖÙÙýÿÿÿýÿÿÿýÿÿÿýýÿÿÿÿÿÿýýýýýýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýýýýýýýýýýýýýÿÿÿÿÿÿÿýîîïýÿÿÿýýýýýýýýýÿÿÿÿýýýýÿÿÿýÿÿÿýõÿÿý#'(ÿÿýÿýÿý¢ýò$'ýÿýÿÿýýþþþþþþýýÿÿýýþþþþÿýÿÿóýþ7;<þ!!þ''&ý¥§§ÿÿÿÿýþþþþþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿýýýýÿÿÿþþþþþþþþþýýýýÿÿÿÿÿÿÿýÄÚÚþ?jkþ0 ý÷ÿÿýþþþþÿþÿþþþÿÿýýþþþþþþýýÿÿýýþ þþ;;þþýÿÿBýÿÿÿþÿÿÿþÿÿÿþÿÿÿýÿÿÿÿýýýýþþþþþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþÿÿÿýÿÿÿÿ-'(ýyþÿþÿýÿÿýýþþþþþþþþþþÿÿýýþþþþþþýýÿÿýýÿþÿþÿýUÿÊññýÿÿÿþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþÿÿÿþtyvýÿõýÿþÿþýýÿÿýýþþþþþþþþþþÿÿýýþþþþÿþÿýÿÿÿýÿþ•%%þý•·¹ÿÿÿÿýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþÿÿÿþªªªýÌÐÐÿgª©ýêþÿþýýÿÿýýþþþþþþþþþþÿÿýýÿýÿý¤ý5++ý5QRÿMafý2\[ý¡´´ýÿÿÿýÿÿÿÿýýýýýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýÿÿÿýÿÿÿýÿÿÿýÿÿÿýÿÿÿÿýýýýýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýýýýýýýýýÿÿÿýÿÿÿÿÐõõýºýÿýýýÿÿýýýýýýýýýýýýÿÿÿÿ§ÿ&BCÿ£ÆÃÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ½½ÿ¢wwÿœ““ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ¾ÜÛÿµÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÔýq«©ýÿÿÿýÿÿÿýþþþýÿÿÿÿýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýýýýýýýýýÿÿÿýÿÿÿÿ¤±±ý·|}ýÇRQýÿýÿ++ýýˆžŸÿÿÿÿýýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýýýýýýýýýýýýýÿÿÿÿ£ÂÂýÚýÿýýýÿÿýýýýýýýýýýýýÿÿtý’¿ÀþÿÿÿþÿÿÿþÿÿÿýÿÿÿÿýýýýþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþÿÿÿþÿÿÿýZ?Cÿÿýÿþÿþÿþ•þc‹‰ýÿÿÿÿþþþýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿa‹Šýÿþÿþýýÿÿýýþþþþþþþþþþÿÿÿý–þ7þJ66þ`ecýÈÌÌÿÿÿÿýþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþÿÿÿþk› ýÿÿÿýþþÿ þR:8þÊðóþÿÿÿýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿV]\ýÿþþþýýÿÿýýþþþþþþþþþþÿÿÿýÿþÖþvþASOý™•–ÿÿÿÿýþþþþþþþþýýýýÿÿÿÿýýýýþþþþÿÿÿþÿÿÿþ]ýÿÿýýÿþëþ_þÿÿÿþÿÿÿýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþþþÿýÿÿÿÿxýÿþþþýýÿÿýýþþþþþþþþþþÿÿÿ!ýbý½½ýÿÿÿýÿÿÿýÿÿÿÿýýýýýýýýýýýýýýýýÿÿÿÿýýýýþþþýÿÿÿý8GKýÿýÿÿýýÿ ýÿýýýÿÿÿýÿÿÿÿýýýýýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýýýýýýýýýÿÿÿý¯ÑÑÿÇýÿýýýýýÿÿýýýýýýýýýýýýÿÿžÿ’ÔÔÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿW†…ÿÚÿÿÿÿÿÿ..ÿ¡ÿIQNÿÙòòÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿJVVÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿýgý6WWýWyzýo–”ýi‘ÿxŠŠýQRSýÿÿÿýþþþýÿÿÿÿÿÿÿýt£¡ý¥ýÿýýýÿÿúýÁ¿ýÿÿÿýÿÿÿýýýýýýýýýÿÿÿÿýýýýýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýýýýýÿÿÿýÿÿÿý†ÿÿýýýýýýýÿÿýýýýýýýýýýýýÿÿþýÿþÿþÿþûýÿÿ¢ý[roþÿÿÿþýýýýÿÿÿÿg–•ý§þÿþþþýýÿÿÁý}³²þÿÿÿþÿÿÿþÿÿÿþýýýýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþÿÿÿþx––ýÿÿÿýþþþþýýÿÿýýþþþþþþþþþþÿÿýýþþþþÿþÿýzÿ†¡¡ýÿÿÿþþþþþÿÿÿýj ¢ÿ°ýÿþþþþþýýÿÿÿýÇ/3þeþk:?þ §¦þÿÿÿýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþÿÿÿþÿÿÿþ\ýÿÿýýþþþþýýÿÿýýþþþþþþþþþþÿÿýýþþþþÿþî)(ý?nsÿÿÿÿýÿÿÿþÿÿÿþFc`ýÀÿÿýþþþþþþýýÿÿýýÿþÿþ( þáìéþÿÿÿýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþÿÿÿþd’þôýÿÿýýþþþþýýÿÿýýþþþþþþþþþþÿÿýýýýýýÿý6ýÿÿÿÿÿÿÿý÷ÿÿý$@@ýð ýÿ ÿýýýýýýýýýýÿÿÿ ýäý@DDýÿÿÿýÿÿÿýýýýýÿÿÿÿýýýýýýýýýýýýýýýýýýýýÿÿÿÿýýýýÿÿÿýÿÿÿýfýÿýÿÿýýýýýýýýÿÿýýýýýýýýýýýýÿÿÿÿÿÿÿÿÿÿSÿÿÿÿÿ‰}}ÿWÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ,\^ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿFtwÿ÷ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿýýýýýýÿý­ý…ÿÿýÿýÿýýýÿÿýýýýýýýýýýÿÿsýêÿÿýÿÿÿýáøøýÅÞÛýØôöýÐÞßÿÿÿÿýýýýýýýýýýýýýýýýýÿÿÿÿÿÿÿýÓõôýzýÿýýýÿÿýýýýýýýýÿÿýýýýýýýýýýýýÿÿýýþþþþþþÿýÿÿýýþþþþýýÿÿýýþþþþþþýýÿÿù00ýUþ^þwþŽþáýÿìùùýÿÿÿþþþþþþþþþýýýýÿÿÿÿÿÿÿý#þÿþþþýýÿÿýýþþþþýýÿÿýýþþþþþþþþþþÿÿýýþþþþþþýýÿÿýýþþþþýýÿÿýýþþþþþþýýÿÿÿýÿþÿþÿþÿþQýÑêçÿÿÿÿýþþþþþþþþþþþþÿÿÿýÿÿÿÿ:8ýÿþÿþþþýýÿÿýýþþþþýýÿÿýýþþþþþþþþþþÿÿýýýýýýýýýýÿÿýýýýýýýýÿÿýýýýýýýýýýÿÿýýýýýýÿýVýÈððýÿÿÿÿýýýýýýýýýýýýÿÿÿýÿÿÿý!$ÿÿýÿýýýýýýýÿÿýýýýýýýýÿÿýýýýýýýýýýýýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ´ÙÙÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿâýÿÿ745ÿÿ ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿýýýýýýýýýýÿÿýýýýýýýýÿÿýýýýýýýýýýÿÿýýÿý©ýp”“ýÿÿÿýýýýýÿÿÿÿÿÿÿýÿÿÿýhŠŽýbýÿýÿÿýýýýýýýýýýÿÿýýýýýýýýÿÿýýýýýýýýýýýýÿÿýýþþþþþþýýÿÿýýþþþþýýÿÿýýþþþþþþýýÿÿÿýäþ%SSþÿÿÿþÿÿÿþÿÿÿýÿÿÿÿ£ÓÔýb(%þÿþÿþþýÿÿýýþþþþþþýýÿÿýýþþþþýýÿÿýýþþþþþþþþþþÿÿýýþþþþþþýýÿÿýýþþþþýýÿÿýýþþþþþþýýÿÿÿý9þÿÿÿþÿÿÿþúÿÿþ}®¯ý_ÿÀýÿþÿþþþýýÿÿýýþþþþþþýýÿÿýýþþþþýýÿÿýýþþþþþþþþþþÿÿýýþþþþþþýýÿÿýýþþþþýýÿÿýýþþþþþþýýÿÿÿýÙ99þUUUþdþšþæýÿÿÿýþþþþþþýýÿÿýýþþþþþþýýÿÿýýþþþþýýÿÿýýþþþþþþþþþþÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿgcl27-2.7.0/gcl.jpg000077500000000000000000000601001454061450500137110ustar00rootroot00000000000000ÿØÿàJFIFHHÿí ðPhotoshop 3.08BIMíHH8BIMó8BIM 8BIM' 8BIMõH/fflff/ff¡™š2Z5-8BIMøpÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿèÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿèÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿèÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿè8BIM@@8BIM €4€N cÿØÿàJFIFHHÿþ'File written by Adobe Photoshop¨ 4.0ÿîAdobed€ÿÛ„            ÿÀ4€"ÿÝÿÄ?   3!1AQa"q2‘¡±B#$RÁb34r‚ÑC%’Sðáñcs5¢²ƒ&D“TdE£t6ÒUâeò³„ÃÓuãóF'”¤…´•ÄÔäô¥µÅÕåõVfv†–¦¶ÆÖæö7GWgw‡—§·Ç×ç÷5!1AQaq"2‘¡±B#ÁRÑð3$bár‚’CScs4ñ%¢²ƒ&5ÂÒD“T£dEU6teâò³„ÃÓuãóF”¤…´•ÄÔäô¥µÅÕåõVfv†–¦¶ÆÖæö'7GWgw‡—§·ÇÿÚ ?õT’^õ÷묹ý¥ÚXY¦vC 8'ìµYù®Ûý"ÆÄÿ¥Sò¼®Ng(Ç9Hü°ïJ@ .×]úÿÑ:Eƨ»?1„µôÑXá¦Ëòú:Ý»é1ž­ÌÿD¹|ñ¥×òq°ñigaa²Ó÷°â®BŒ{.{h¡£qàpÐÒs¿u«gêÛml±îñ` oËp{–ܹo†r`G7ë2~®)KûÞÜ=÷˜¸§-´t›þ4>±ƒ/ÇÂx𠵇üï^ßú•Óý[úû‰Öl8™}44¹µîÞË>™¦Èc·³é>«ÿn/;Îè=K(ÐÊ-ÈnÐöØÆ ϵî£kÛµK¦ôþ¥F~>G¤jôl$¸Lj×{Z]ù®K™å¾>\Î9qâ"\&¸£n_½ýÅDÎõ²ûS,kÄ‚©õ~¹Òú.8¿¨Þ)k¤VÍ\÷‘ùµTÍÖYô¿±ùëϬlèýùù-6ÕñOÓÃýoÖq¯„‰úuiõŸñ•‘…Õrð±0«¾œ[ >«ìsKœÀÞÖÖÿ¡vúÿ°¬ýZú÷Özƒñ¯Ã«Š«6YklsŒÈeL sôÝÿP¼Ìo:½Åïq%î:’âw=ßÚr辫Wc{t7¸’Ïk?éoW9þK”å¹BF0rúqÆw?TÿJ7îqÍle#-ô}f››hŠ¨ô¶9´7r¼¹æWÿÐô?¬]Tt~‰—Ôcsè¯ôM:ƒcˆª†Ÿäºç±x‘/q/±æËK¬±ÆKœã¹ïq?¾ó¹zoøÓ±íèÌi!¶fVðk.µ ÿn¶/1<.—àx„yydý,“:ÿV/ýÛS­vw¾¯á°:=×™'ù#FûúÖêŸY]Ð3ÿgâbS’êêc¯}®x-{Ç©é·ÓýÚ}'×>©W]­¥í÷7kGÌsÎVþ±}N蜞±Ÿ›“Sïs®³}µ4}*êw»NªÖv<¸rs¹eÍFSâ2Œq)K‹†ôÿ›‡¡yDp¸ÖÿŒ>£cv»§bGõíW¾¬uWõœ«ÆN-ôÐÆõ—’^óì¯ôžß Ëÿì.¤ N±á亯ªTØÑ[[§¬ñc¾pÖàmW~)Êòœ¿-)Cc’DBå§éHüß¹°”‰Ôµþ¼ç·#­}†£ú¿Mo¦àÜðÛ2_ýŸÑQÿZX¸4 ò˜Ç `÷¼x†þoöœ£•cíÌɵÿNËís§Ä½ê÷@ v[Ø~›šÝ£ÄwÇýs(<¯Ãä1ïÞŸ¦y?ÆŸº´z§¯Rö¥zÎÖãPÁ«ß¤ŸÝc~–;ók¯Þ¸\¯ñ‡õýRÜÌ+E8Žpa\ƽ¡ú¦Ý¶¶×ý;};ÿàÿÁ®{”äss\GF0ý)i/Üõ™e!Þß'êë-³q ˜úþkéØ*­—a¾èÿGDzm?ñ—Ø×ÖWEõWëVWYÄõ³1™Žòí•Ü\-§ck{wTÆ¿ôÎY½p\zŸí?¬¹—4Í4‹Oõi–ÙþvK¯rµð¾RC1Èôk”€Xz£ýo_øœ½:uqƒ\âߤâ߉Ð.ïêÖÞÆ´{XGÀh¸î˜Æ;-®{ƒ[XÝ. {µ¼¯Eú»wM¢°ërñØ•kÿ«S|o$¥’¢ R¡úy?ïaÿ¥â[ÖPÍ•€ˆªSÕ:eÖ6šrè²ÇèÊÙcãwµ­vç{Z­ Ä1#pG›+ÿÑï>¶t?ÛÜ&–²ð[n3Ý;E¬Õ›£ó,÷RÿøÅã™xùYÅÍ©ØÙ 0ê¬~-?FÆ~í•û½‘!fu>Fk6ØƼvk€pÿ¤´y‰Ë•‰Æaîc'Š¯†P—õO«üU“‡»>-NNF;‹ñﲇMOs'ã±ÍLç[•v÷ºÌ«øqu¯ë;{פ[õ3:YEcàÆÿr%_U¶èÖøðW¥ñÜbÌ0#ÖRÿ£¾Ñîð8Ý*ïç¿BÓù£Üóÿ|bî~®ôǵíyn؈ò…¯‰õršÈ. cº@ ²ù¾{/2AÈEFøaQëãŸ)úéõs'¤õ;ók­Îé¹o72Ñ«k{Î먺?šý!ßSìÙýEÎ5ÐA5ïy XZ{ˆ\ÆwÔü+^^1ê$÷ØßîZ·Ç 1Æq™˜Ž8Ëæ÷£ûßá-8¬Ø/–9ÛÞ ÜlxÑ¥î/pònòç+ø]"ûÜ{Mu~çwþ“gý5Ý×õIµŸÑ±¬þ«@ü‹GêÝu\%cã“”LpÃÚ½8ÉâŸø¸¡ˆuÕÁ­Ïé''©¾ÜJ¢Þóú,jÛÿ]sŸ²ÊàP8ŽL‚Iîïí/y¯–W°±®4ø¬®¥Ñ’í+`Mhþ CâQåc0q’É+2ãáôÇåÉ?ë¦pâ­v|t¹‡’Ü¢[Aä0ü@^§ÿ4Ùûû‚_óMŸº>à®ÿÊÿ˜?øgþ»[íx¼WÔÏGª?=¬nêXk¨€4}º=ßÙ§Ûÿ^^­Ó/}Õ9aãýXmo4†‹£ÄÇV;,ž{š<Öc”ŽcâጭýïRøÇ„SÿÒõT—Ê©$§ê¤—Ê©$§ê¤—Ê©$§ê¤—Ê©$§ê¤—Ê©$§ê¤—Ê©$§ê¤—Ê©$§ê¤—Ê©$§ÿÙ8BIMÿþ'File written by Adobe Photoshop¨ 4.0ÿîAdobed@ÿÛ„      ÿÀ¶ºÿÝ8ÿÄ¢  s!1AQa"q2‘¡±B#ÁRÑá3bð$r‚ñ%C4S’¢²csÂ5D'“£³6TdtÃÒâ&ƒ „”EF¤´VÓU(òãóÄÔäôeu…•¥µÅÕåõfv†–¦¶ÆÖæö7GWgw‡—§·Ç×ç÷8HXhxˆ˜¨¸ÈØèø)9IYiy‰™©¹ÉÙéù*:JZjzŠšªºÊÚêúm!1AQa"q‘2¡±ðÁÑá#BRbrñ3$4C‚’S%¢c²ÂsÒ5âDƒT“ &6E'dtU7ò£³Ã()Óã󄔤´ÄÔäôeu…•¥µÅÕåõFVfv†–¦¶ÆÖæöGWgw‡—§·Ç×ç÷8HXhxˆ˜¨¸ÈØèø9IYiy‰™©¹ÉÙéù*:JZjzŠšªºÊÚêúÿÚ ?ûùŠ»v*ìUØ«±Wb®Å]Š»j b­Xd8ªÃ0ñU¦uñÅVúë㊻×_UÞºøâ•âa㊉Ž*¼88ªàAÅ[Å]Š»v*ìUØ«±Vª1U¥ÀÅVGŽ*°ÌùËô‡ÿ¡Úÿœˆÿ©¶Ïþáv?õGåýgó‡È3ÿ“EìïúŒ¿ådÿZ>×þs—óúÜGëjÚEÿ«ô؇1Zѽ#ß*d£í¬uàÑ—þ¾ÏÎê#î™ý6Í´Ÿùø?楻 Ö|©å­R%§#n—v’°ïV7-~IôfD=¦Î>¨ÄüÇé.ŸUÿîÊŸ÷9ó@ùðȹ‰û^ãåùø?’õŠ8ùGSòÿÂ×–R¦¥n§ùŸá‚P?ÕF?¯68=¦Å-²DÇݸýã{Wþý¡„i3Ã/”Ç/‡Õœ¢û#É¿šžMóîœ5_(yŽÏ^²µ³þò"z,±7#ogPs}ƒS‹÷oÙ]ƒ¯íIpé0Ï!þˆ4=òä>%ñÿ›ÿçá”z;É•´}oÎR¥x]$K§Ú7Éî¬>˜sK›ÚM<6€2ûÛ¿ØúofÀOµõDñá×Ç/”}?ìߨ䗾gýèŠRç6ÿç"ý5¶÷ ±ÿª9åýgó‡È9?òh½ÿQ—ü¬ŸëLìç:?- }cQÑuN5¨ºÓQyWÇêíOlœ}¢ÕŽd‡ê§7üýŸÉôÇ$=Ó?ï„ž ÏÄ<ã óOåþ‘ª!4‘ô«™ì!gúÝiáQ_™x½§È>¸î$}öóšïøhä?ÁµS‡õãÿ¹ðßPy þsWòƒÎrÁc}¨Üù/S˜„K}m(òÝÆÏòÍΛ·´ÙÂ|ÿ_/>oÛŸð&í¾Í‰œ 3ÀuÆn_éÿJ$ú¦Û]·¸Ž9¡%†e¨Á••…C6 Ž™¹ß4” IQ ´:’µ>,,i3ŽéZ›â„jH|U\â­â¯?:ÿç3|Ÿù3ç«Ÿ!Ýù_Qó¡aimq¨ÜÚO I —+ê¬$=I>™G¯ùY£×öæ=&_ Ä’Þú—²Ÿð,Övþ„k#–8ã)$ˆìNßÒ±ðyÏÇü–z~[ëô—mý3ýcþaù‡¤ÿ“­ÿ”¬éd¢ßóñ¿'Ÿ—:Ðÿ£»éú(ÇüÃó ÿ&+[ÿ)XÿÒÉHÿÏÆ<¡ÿ–ïZÿ¤»éú'ÇüÃó ÿ&+[ÿ)XÿÒɯú(¿”òÝë_ô•oý1ÿDøÿ˜~aäÅkå+úY>²üœüäƒówɱyÎÛBºòõ•ÕäöÖ6×r$2[0)°§$§ŠœÝè5ƒW‹Ä _WËý¬ön^Ï뎎Yc’B “@[ˆïÖ¨ü^½¢­ûYšóI„W!»â¨ôzâ…`kŠ·Š»v*ìUÿÑûùŠ»v*ìUØ«±Wb©^±¬éZ›y¬kz•¶‘¤éÑ™¯õ;ÉR!Œui$rG¹9Î0R4RߦÓeÔäŽ,13œÄIòrüàüåÿŸé:k\蟓Zbk·hLry¿TÒÉOsmmT–_f“€¨û,3˜×{Iúp =ç—À>éì·üsf7jÏÃúœ3ÿ:[Æ>èñ8—æ·Ÿ?40?3µ©yëÍwþa˜9x-ç“´×û‹høÅ_ØQœ¶£W—Po$‰û¾\Ÿyìog»?±ñøz<1Æ:=GúÒ7)|I`9Œî]Š»v*ìUØ«±Wb¬—Ê~qó/‘µ›}ÊšÅƪ[ì'¨+S¨j®†›«2쌘'ÇŒÑu½­ØúNÕÀtú¬c$CÐ÷ƒÎ'ÌnýjüŒÿœ‡´üÐЋ^¬Zoš4°©­é‘“ÀòÙgƒ‘'Ór:J‰;ßö_iÇY ö˜æ?Hò~DöóØŒ¾Íꀉ3Á’ø&yùÂU·ø ÇP=9§y$ãûÊæÕàˆg:¢ÈÅ…2X' øª=Z¸¡~*êÓyæ¿çåÏäÖ–º‡õÔµ¹¸BúfƒlÚå*?sn4¨¡v*€ìXf³_‡KÈ}éø~Ò{9ìŸhöþ^ &;ê™Úþ´¿Þ‹‘è•?›_óÿ™Þu’ëMò/å×—¤åOnÂmVT¯Ú{¢) 4­!PËÓ›g!¬ö‡6]±ú#öüú|>oÑ~ÍÀw³;< šÏðŒ½ÇlcÝâÿ<šjŽ¡«^O¨j—וýÓs¹¾º•æšF?´ò9,ÇÜœÐÊFFɲúÎð@CDb9ÜÈ<‹k±Wb®Å]Š»v*÷ßÉŸùÈ?9~Rß[Ú%ÜÚÇ“d~òÜÏÉcV?–ŒÇ÷N:Ð|-ûB´aµìîÖˤáÔ~®çöÏþÚhqÐÇ©Ó~Y+êŸÕ‡˜?[ü›ù›£y·FÓõíýo4ÝF1%¼£b;2ºÕ”‚=wø3Ã4àläNÕì­Gfjg¦ÔLJ$ ÷ÞÜ¡êšv¼’qøúåκ™•¥úÉMð±O"”0â…·×öºm•Þ£}:ÛYXA%ÍåÃý˜â‰K»·²¨$à”„A'lÅŠYg@\¤@¼€5?™>rºüÂó÷›üíwÉeó.«s{MÖ(]Ï£}£Œ*až[ªÎså–CüFß¼û²ãÙz :HòÅyÔ~2³ña9ŽíŠ»V··šîâ [hÌ×2,PD½YÜ…U2pÆ&D̵åËP”æj1“Üä¿n?.$³òG“<±åIÓЬ!¶‘Óa$ÀršJÅ’o§=CI€`Åc þ×á?h;R]«Úµrÿ)2G”„›¬éþcYJüy’éˆgºv¤$òß,ºÚn`{áBh†¸¡Sv*ìUØ«ÿÒûùŠ»v*ìUØ«±W‡þvþ}ùò7A—™®¾·¬^£þ€òµ³/Öï]v¨¾œ`ý©PväÔS¯íZ8\ùžC©üw½g²~Çk½£ÏáéÅB?^CôÃõ˺#sä7~"~sÿÎ@~a~wêÆë͇Õ4+iKèþS³fKQ¸V*Me’‡y§¯+ðç®í,º¹\ÎÝä?ïÖžÊûÙþÎâáÓÆòêÉ/®_ñ1þˆÛ¾ÎïÌ­v*ìUØ«±Wb®Å]Š»v*ìUœþ[ùÆëȾpÒuûyZ8#A©¢“I-e J¤w¦Ì󙽫:lñŸNGÜyþ·˜öÇ°#Û}——JEθ¡å’;ÇçôŸè’ýWò÷œÄž&¨4 ×=,âFžé yˆJãëï’k§­é—âUSË%–Á' 0±EòÛøâ¯ÏïùÉùÍ=3òúMCÈÿ•ò[ë¾v‹¾«¯°Ylt©*È«¸žu ÕOÀ‡ír<“9ÎÕíØà¼x·—SÐ~³ö>Ñìü rö Ž¯´/¼aÊyô`{þ©T*OÈ/0ù^óf±{¯ù—Wº×5­EÌ—º•ä­,®{LvlØ €8¼¹e–FS6O{ôÞ‹CƒE†8tðÇQˆ ?O3Õ&Êܧb®Å]Š»v*ìUØ«±Wb¯¥?ç¿2nü¯¯Ëå{›†ý®’ö¨ÇáŠñµ¢Ž'ą΋ÙíiÇ—Â?L¹{ÿoê|gþ ^ÌGY¡¡Œ~÷Òþ–2Þ~Q2~‘y{ÍâBŸ½üs·~^!íÚº²„øúá`CÓ,/DŠ»ábù›þsKóù'ò+^³µŸÑÕ<ï4~_±¡<½+ŠÉvh7¡·ÐžÅ‡Ë4Ý»©ðt¤rÛõý¥À£±”{w¤.È}ñÚìÈ?ü(Ï=~Âv*ìUØ«Ñ*ìãŸÎš]äê ¾ŒÆýê6ç=/¤HTý·ì=?©‰<£¿Ë—Úùßü»cù;°òÆ&§š±t¾¿öCâyé¾ri{øç Ûò ×ü¹æ&”ÇñÖ´ï…~òíù”'Å× õ½6Bʧ IlP­Š»v*ìUÿÓûùŠ»v*ìUØ«æŸùÉùÈÍòËHá#Õüï®G ò¿—‹?Ân®¸V'عøWö™u}©ÚqÑC¾gý'Ëï{Ïa=‡Ïí.¦·†žx“ÿyù”Fç ?üççO3þ`ùQóg›õiµ­wT~WW’ÐËh *" •TAž}Ÿ<óÌÎfÉ~Áì®ÊÓv^š:m,1Çy<É=Iܱ|¥Ø;v*ìUr#»E.Ç¢¨©û†J124–¼Ù¡†&y$#Ôš2Ž]'RqQe0å)_×LÌfêe˾U÷¼Þm»©jñ_”„¿ÜÚœºuô ™-%U[‰#ï š F1r„€÷7èý¬ì\„qj±HžCŒò$b= ±Wb®Å]Š»}­ùwæÉdÑôfyIqkÈkÕ‘B“÷Œô¾ÏÉâiá/è‡âkôCIÛ¬C`2νĒ>ÂúËÉþb2z_‡|Íy’LùoSõ?‹Ã$ÖCÕìg䫾ÍÏùËïùˉ,Uü¥ü®ÔLwËÎÓÎ~m·jOÙ’ÊÍ×£ö–Aö~ÊüU+Éö×lðÞ'â? ~’ýÿø ¢¥Ú1ôóÇŒõîœÇwXǯÔv ~Ug ýìUØ«±Wb®Å]Š»v*ìUØ«±TUäÚ}í¥ý»p¸²™'…¼6 ?–bÈqÌHsþN.»G fŸ& ›Ç$LOºB‹ôÊoõÒÚd–©*«©¯fê0˜”D‡"üªÓËYbŸÕA÷ƒEõ”|Åê¾? ±Å!ôF…©zˆŸpµ—åÇüç×æøƒó@ò=¥Ç©eä;Õ¾[a¨ñ‘Ãü°$DW§#ôñÒjxó c”GÚe?QÀO±-Ù™5’¬ò¡ýLvÎf ø39ÇÚŠ»v*ô%Mú> îÒ]°PÈJÿs´ösOÁ„ä<ä~Áûmù›þ ݳùžÐÇ£‰ôàŸëä£öDGæ^á j²;§ÄzçDøÉ¥<™pîbßÃ$äú¿Ê|ŠG_…¨½ËK‚á`YD]*Ø«±Wb®Å_ÿÔûùŠ»v*ìUä›þ^ü•ò&¥çt‹‰ÓýAÑ•‚Ë|à˜¡CØlYÚŸ ‚hMÃ×ka¤Äg/€ï/I짳:h5ÑÒáØsœºBœÜY6æþ|<ùç¯2~dù¯Wó—›/ÛPÖµ‰yÌý#‰ÑÃtXãZ*zœó}F¢zŒ†s6Kö·cv>›²t°Òé£Ã‰=dORNä± ¡Ù»v*à $“@Rp{JBÊF€æYvå±ÅgÔØ ;­¢š1ÿXöù ó¦ìÿgÌ€ž}‡ózü{½Üýφû]ÿè`”´ý–ä69NñÔÅýcé#†ôí HÁ ùž§éΣŸPˆÉðŽÓíoiäñ5Ye’_Ò;på€ „6’ÌFÇ.u‰Ä$¯O€á[I|Åäg¸²žöÒ—–èd*£ûТ¤ãN‡4]¯ÙPÍ’¦7þ·í}Wþ^ßj;3UI©™–šdGÔº'`bzFþ¨òq¿>3œ3õC±Wb®ÅW¤RÊio!ðPOêË1ážO¦$û…¸z¾ÒÒéçË cúRûÈ{÷‘åžÚÆÆ'V‘(v#|ôNÍ„¡¦„d(€ükí¶§«¶u9pÈN™ ƒ`Š‹êÿ$_IXªOlÏ%'×^P»b‘Tødš‹Æ¿ç,ç#%üµòÚùÊÞ—ž|ÍnMÝôMñévU2†fi·Xû¨«ìxWAÛ©ùxxp>¹}ƒõžŸØúßü =„±¨üîª?àøŽÀòÉ1Óú±ç.óQßÕ_‰$’MIÜ“œ+õk±Wb®ÅWÇ“:Ç$sEE''²HF"Éqõz¼:LRÍšBˆ²I *³òôHßÉÍÿåž3@?ÖnÿGßV‹ÙÐ=YÏÀ~“ú¾o‚{MÿIÈœ]— ê“ŸêÀì=ó¿8„ú Kxö‚Ö8ýŠýýs‹G‡ô@‡é|‡´=¥í=|‰Ôj2Nú„ED|i„“Š2r¨"£2 D…Ý><ÓÅ.(Þ 5ç’Òò6kxŽÅ*Œ¢ŠOƒúÆiõ݉‡qB`J'¼Æ㢎Vå;v*ìUô—õi†˜ îÆ„ÿªþé].-63ý÷?{g€aí­d@¡ãLÿ¦‘—éÛÉõ×’5f>ˆåá™Áå$ShÚõ®›¦]j—óˆ,tëy.¯'n‰(]Øûã)ˆDÈò Á§ž|±ÅŒ\¦D@ï$Ð7á¯üÑyço7ù—Í×ü…Ϙµ‹ç}5šBÉ>´Qì3ËuŽl’™þ"K÷cvl;7E‡KX¡ûèn~'sïbùK²v*ìUÀ@“°ÉF&D̵æÍ 0–IšŒA$÷¹gšePEý”g¦é°Œ8ãÐSðßmv”ûK[›U>y&eîì>‡Áì¾U…ãùŒ½ÔÖÞE²cèíá’ R}såKR*ŽÃ$Ô^ͧGÅW @ƒlP©Š»v*ìUÿÕûùŠ»v*†¼»¶±µ¸¼¼ž;[KHž{«©X$qÇ,îìhP $ôÀHÏ&xñË$„ ‘4æIäùûÿœœüó¼üðüúÔm¦‘<›åö’ÇÉ– UCÔºe4¤—Cî*þÎyÏjöÖf±ô‡ëø¿hÀÿÙ{;ÙâÇÉRÈ|úCÝ ¯3rêùË5otìUØ«±Vg£ééf‹w:ÖíÅcSþëøœí;²†2ä³È7öýÏÌ¿ðKÿ‚»G$´9Vž&§!þVC¥ÿ0tþqßqL‚%yØu9о:Ë´½ç+ðÖ¸X’ôýÊO'ÝõöÂÆÞ•§y°_Ý~±%‘/‘>î 4Ž'ÉòÿÎ7yÑ®®¥šãOÓìÌÒtç$’ù? ƧùYÅÿ¡Ìò‘7/Ïõ?Mø4öf0ˆÇ—$ÄEšŒcu¾æWÏú*rþD=€­æ¯-Éia„Eø³?ê̼~ÌÀ}s'Ü+õ¼î³þ:‰_åô°œägöDCïø¤w?—Vd ³ûR9ÿxŒÎÇØ:Xs‰>òE<®³þ =¿¨úrÇþ„#÷ÏŒý©wø^(Õøï÷æv= L">åužÕv¶³ûíVYî9WúPkìL­tû³( tR‘‘³Íè:‰(tø¾Šò~›"4_†I¬—ºk~tÓ,ü“¬yÇW£A¤ÛÖÚÓ—¹¹†®îä ÓaVècêõQÓb–ItûO@í½ì<Ý·¯Ç£ÅÎgsüØå#î3C™~:y³Í:Ï|Ç«ù§ÌFóWÖ®âîSÐWeD²ˆ *ŽÀžiŸ4³LÎfÉ~Ýì®ÌÁÙš\z\áÇŒPý$÷’w'©,{*vÅ]Š®Ž7•Ö8Ô³¹¢¨îNO9dŒE’ãë5x´˜g›4„aL‰è7°³‹OŽ‹G¹qûÙãUöÎÿ³;2HwÌó? y}ïÈÞÛûo¨ö‡P@&xŸD;ÿ§>ù”Fé'6Öï3 «\Ù¼#5Òô˜¯ÀMp±%éZ_“Ú@¿ºü0±%›[yŠÜþÒ8Ÿ/þxyq|¿æ{XÌcR±YdÚž7d&¿ê…Î#Ú½=GÍîšE°kÑ“ãº4ð1)Cþ°Í?oj|1œ¶ýgÞú?ü ûùC·!’BဇúÃh|xˆ—ù¥ùuœõÛ±Wb®ÅQvQóOdøðÍÇaéü]H'”wý_kçðSíŸäþÅœ"}yφ=Çyÿ±œî“ynùÞ¿%Ð~LÓË<_†²ûȺe_†H5Iõ7—-8F›xdš‹Óm#⣠ÍFØ¡v*ìUØ«±WÿÖûùŠ»v*üøÿœøüå>RòU§åv‹uéëÞ|ÖÖÙÅŽŒU—Ûë/uYëœç´Zï Ãrçý_Ûúßiÿ€×²ßžÖË´r‹Ç€Ô|ò‘þò&ÿ¬b_™Ã¿R;v*ìU7Ò-D³zò Ũ¡nÃèë›ÞÂÐxù|IL~ÓøßäùWü}«=•¡L2¬ÙÁsŽ?â>F_Hÿ8Ã0…ZgÜ?,3ÝGi™>× ^óå*™=2cðí…/ <½äÑÅ+á…¬—­i¾P@«XÇÝ…‰,„yV0¿Ý»[Ô¼«VýØû±M¼£^ò’žtðÀÈj¾N«7î¿ ÁbäÏ‹û¯ÃÚ6×É{Ý~­³'ɼYO¥øabKÙ<½åŸH§îéÓ¶¾ ÿœºüÃý/æ‹?ËÍ2ඓå%Õ‚]JUèi±ô#Ôö—eaž&cŽ37.²FßUq &ÿò×GÒ"x´ÓMŒ pµ"ÿ`Y<{B {…8:ÎÕÕëO£,òéHËï%ãž`òéá–8€¼ÂóÊOÌþëðÀÊÔmü¢ü‡îÝŠÛ=Ñ<©"²~ëðÂÄ—½ùWËïàéNØXùþrÏÌÿ¤|ó¦ùR 9ZùBÅDéØ]Þ…šNŸñPˆ{çí£8Æ9@}§ºŸ¨ÿà1Øß•ì©êä=Z‰íýLwþËì|­œóì.Å]Š»NôȾ}ÜíòÚû;§àÂrr?`ý¶üÇÿNØüÏiÃIéÁÿ¯’¤Øð}¯Nòõ§9nã:Ç‹ê/#i•h¾ !ªEöG’ôÞ)Ãá’ R/¢4[`‘¦Ý°µ–i Ð ,Qx«±Wb®Å]Š¿ÿ×ûùŠ»CÝ\Ck×72¤öñ´³Ï! ˆˆ*ÌÄì§ ,¡ NB1NÀy¿œoÏÌ«¯Í¯Í5ùÚi¬oîÚ ¨ôtëÝÚ SN$  Û}¢Ç¾yhjŽ§<²t'owGîd{=‡Ùxt€z£™ïÉ-æ~{ ɳ 銻w\ Z%!g`}”>”QÂ:Üÿ”zç£ö~”i°FzûÏ7â¿l;z]µÚ™µ7é'†PŽÑùýGÌ–s¢éægO‡3ž\¾ƒò—½Cáá…¬—¬y¿ÌŸ•žI¹ó\ö+SsœŒ‰ï$Ùz/—ô³+§Ã]òǾò‡—9úDÇáÛ Y/¨ü«åp:ÇáÛ$ÔKÝ´.¢*|†²Y¤:2(µ­ Ÿƒ·Ÿk^\Wû¿Ã@¼{Zò€·îºû`f Ïî|ŒÏî{ø`emÛùâ¹ü1¤q33É! þëðÆdοFXù{JÔ5­E…¾£ÚM{=6Hmã2HßB©8'1™@[v—O“Ušq‹œä#Þdh}¥ø‡æ¯0]y¯Ìº÷™ovþ{Ù#­BzÎX öPBaž]Ÿ1Í’S<äI~ðìžÎ‡ghñiaôâ„b<øE_Ç™H2—`ìUØ«€$€:“A’„ ä"9šu:ˆiñK.CQ€2'¸DYûŽ=4ì€3Ó°aqÆü5ÚÝ£>ÑÕåÕdú²HËÝgað²ùRÛǷq—:Â_]yKþçáðÉ4’úïÊvR/‡Ã$Ô^Õ§CÅl, ŒP P«Š»v*ìUØ«ÿÐûùŠ»|™ÿ9¡ù„ÞCüŠó6³ú:·]<¹§ÐŽ\.Ã5Ù§Z}Y$Zö,3OÛšŸK*ç/OÏŸÙo£ÿÀ¯±?”ûw¸a¼§ß£ý™‰÷üÏ<~Æv*ìUت*Ê?Rá**â?GOÇ6½§ñµ1¾QÜü9}´ð_ðJíäÞÄÊbjywóþ¯ö_o§ÂduÏ@~@{O•4¯Qãø|0°%õ’´H¾Ù Õ"ùÓþs ÌÃô·•¼‡k'ît›Sªê‘¯CqsXáV÷HÔ‘ìùÇûK©¹Çè,ûÏ/³ï~ÿ€bøzlúù òK‚?ÕŽò¯#"ù‹ó—}ÕØ«±Wb®Å]Š»~­~LéÐù7òÿËZ(ŽóêâëSQ¾±r}Y½Ó—’ç¥vfŸòúx@ó«>ó¿ì~&ö綕ûgQ¨áÅÃêCÒþµq|_@izœnV„f{Èù+þsoϦ-ùSÈ6sRMfáõm]ïõ{_ÝÀ¬<FfùÇœ¿´Úš„q»Ÿ‡/Ç“îßðìOSŸ_1¶0!ëKyxˆÝ7æÖqÏÒNÅ]Š»LôÈë#ÈGÙ_™Î—ÙÍ?Ie?Â({ÏìûßÿƒGlø:<:òËŠ_Õ‡ }ò7þc:ÒmL’.Ýs°~o/|ò~ê4_†I¬—ÖÞJÐ"<<0†©Óþ\ÑÕ?ƒÃ$ÔKÕ,l•vÂÅ:H1U)mö*ÞiË%~Vؕ怒V¨02´ü¯úCîÅ6«•ãSýØû±E§Vþ^)û±ŠÛåÏùÍ4ÇäŸÉ‹½"ÚA§ç›È´ˆ}±l¿¿ºqìR1ÿ_4žÐj<-1ˆç3_gõ|_Qÿc~¶ã–Cѧ‰™þ·Óó&²ûÈÚe?†Õ'Ô¾\³à‰·A’j/LµŠŒ,S%¡v*ìUØ«±Wb¯ÿÑûùŠ´zb¯È/ùøÇœšûÎÞGò4VßËúTº­ìjvúÆ¡)ŽÜìþùÅûOžòCp¿Ÿö?LÿÀ7²ü=£XFù& ?«gægþÅùÇœÃîŽÅ]Š»N4¸ëÍéöˆQôg]ìÖ„òwšùoú_¿àÙÚ|z>Œ¡3ï‘áÈDÿ¦z>ƒkêH›wÎð²ú_É:W&‹áðÉ5—×¾PÓc‚–R±Eó’F *¨$“Ð <šèÈÐÜ—ä?æw›[Ï^ó_š‹3A«j5€jÕm"¤VÊkü±"Œón£ó哼ý>Çîeû vGf`Òu„õϪgã"X&b»çb®Å]Š»v*ɼa£æ]" Ô5´s¬÷JEAŽ”û58ý9ŸÙšQô»>á¿ìy?n;cù+±µÁ©pðÇúÓô‚?«|_ÞZo›K²þóñÏH~)§®ùw_iJ|~Xüúÿœ‰óKù«ó[Ìú…í´1f ¯h)(ÿ‘Í!Ï=í¼þ.ª]ÑÛåÏí·ì_øvWä;V[ÈÏúؼ?5/ ;v*ìU‘é‘R$ñsÈý?Ùÿb`ð´±ï–ÿ>_e?#ÁCµ?=Û¹@7@cæï/öfORòå‘‘ã۸ͻçeõ7‘ôŠ˜~ -D¾Àòv’"ø|2M$¾ÑìÂ"í…f0ÆX¢v¦*¤ì1T#…8¥ Ð#vÅV}QlUUlÓÃD e¦*ü]ÿœöóðó/æ姓­%ç§~_X-¼ª Tß߸¸aÛhý>OÈpžÑê|M@€åöÏè~­ÿ€Çb~O²%ªõj%æBã·Œûˆ|7œûëîÅ]Š»O4¸~TÞCø í½žÓøx Ï9°múß—ÿàÃÛ?›íXéb}8#_çÎ¥/ö<Þ Óü½iÎHöî3 |ˆ¾£ò.™Sãá„5ȾÇò^Å"ø|2A¦EôFmÂ4Û YfP­ÂÅŠ»v*ìUØ«±WÿÒûùŠ¬s¶*þ}ÿç.5÷óüä7æMË?(´ëè´»t¢-…¼Vì|]ŸsžqÛ98õs=ƾBŸ´¿ài¢_g´±ë(™Ÿóäe÷8f­îÝŠ»v*É4”¬qû’OßÿaÇI;?i~Eÿ‚–¤æöƒ8é„"OÚKؼ¯iÎHöðÍ»çeõ§‘4áûŸ‡Ã$¤^Áù“iæ‘ùQæ›/%iZÇ™5‹OѶ6¶c÷Š—DE<•¨ãÂ"äfixŸ—Æ ‘·Ÿ?±é½‰1Û'­œa‡¸É—+†ñw*ø[óHÿÎ7þySùg¬ãÁ?æ¼á’uêeú¯þN³ÿò™æR]qù ùÃh ¹ü¿Õa¯$Où«ä_ú™OüœÀÿ”¼3ú˜íçå—Ÿtõw½ò½í²Æ vp :“ñ`=•ªœeœ=¾ì)‘êàI÷þ¦ š÷®v*ìUØ«4ò{ýR[‹ÎŽÀCöûMü3¬öoOõe>á÷ŸÐüÿÿÎÙ³ƒ³ây^I}±‡ûÿ˜{v…©ÈîŸëSà>†ò½ð†¹™¸Åm,¬{* “¿°ÄÈDYè¸ñK,Ä#ÎDï;?8õÙµ=BûR¸5¸Ô.%¹œÖµy\»oó9å™&g##Ì›~÷Òi£¦Ã 0úaƒÈ9Å]Š»³Éšé°üQ­6PÝž£‹‡àÉøC´5GW©ÉœóÉ9Ký1'ô½»Ê6\ž-»ŒµÀ/°<‰¦Üü> Õ"úßÊÖ!R=¼2M%ì…EÛ /4yŸDòW–õŸ5yŽõ4ýAµ’óQ»oÙŽ1Z(êÌÆŠª7f ÎW›,q@ÎF€s;;³óö†¢lâɈÄyŸ¸dô—á6»ÿ9mùÕwù‡æ<ùwΚ——íu{²ö>X2‹­>ÞÕ(CõYÄr¨äáfäÛW<û'lêNidŒˆ³Ë˜¯qÙûGÿ^ŇgâÑçÁ†ÞuÃ9Hï#Ç•_!dC£èï"ÿÏÄõÛFÓó#É6ú¤b‚MgAÛLîÖ³³£±ö‘¶m4ÞÓÈm–æ?Qýaàûgþ¸'rÐj ór!þž4@ÿ6Eö’ç*¿&<ýèÅ¥ùÊßKÔ¦â¬ÿ¸ûŽMÑÍH¤ohݳ}¦í}6¦t{Žßƒäݳÿ¾Üì«9tæpÅ÷‘÷ú}QÖˆ{ªjñ8 ®X¬ AÃ6OE#á¿Fý¡… ”w ÝñT¿¯éþ\ÐuŸ1j’ˆ4Í ÆãPÔ&Ûá‚Ú6–C½:*œ†LƒL /ääè´™5yჹäˆ÷ÈÐûKù©óg™/üáæ1y¯TnZ‡˜õJðT°W¹•¤*¤ö^T<³6S–r™æI?7ïnÍÐcÐiqi±ý8ãtE}½XþTæ»v*Ú‚Ä(êƃéÉÂrɦV¦l3ÍÔa"|¢,ýŒËOƒxÐ –€g¦àÄ1B0€§áŽÓ×Ï_ªË©Éõd‘‘ÿ8Ý|9=›Ê–Þ?‡Ã.uåõב4¿î~ j‘}wåK)݆I¤—´iñEÂÁ?ŒP P«Š»v*ìUØ«±WÿÓûùŠ©HvÅ_ÍçÔ—¿›_š“%ºónµ,k@^úb@©&‚»ož]­7¨È¤~òýãì¾1²t‘†cý„^u˜®ñØ«±Wb¬³C£‹Ø~üôÅ–’ÒþòüƒÿìÅí£‹ø¸d=Æý6>zò„¼[xfÙóâûÈv¢íá’ R}aå¸@‰(; “QfW H<1bò_4ÂÌ’mÖ¸‡Ã_óz‘òÿ“õ)Cúw:£®ŸiØ“5KÓå±ÍOmj<4«œ¶e¾‡ÿÆþSíÌ"BáŠòKüϧý™ÂßžYçØ®Å]Š»eúR˜Ò$»|Îç=#³´þC­oï;—â¯l»cù[µµn&UêGÓ˜ï/bòÄ,òGóœòÅïÓÅ%Ÿ‘¼ÛxƒãµÐµ “¶ém# þŒÇÖžtOÜ]dz8Æ^ÖÒ@ò–|cç8¿<3Ì_¹Š»v*áÔd h‚Õ¨ž9Ds ±èšBr‘>yêaø&@ƒEô?’­x¶î0µÙ~E´aÛÃ&dúŸË°…Ž?ÂÖ^ $Q‚")gv4 É$øab&ƒñ§þs'þrY?3õsùyä«âþBòõÉmGQ…MZú"@u*~("?c³7ÇÓ†p½¹Ú¿˜—…Œúû#úƒõ_ü =‚=‡óÚ¸ÿ„dyâéå9pôÿ9ð–sÏ°»v*õ"þoþhù[{o'y³Qµ€È«ˆ[ëV®ÌiÅmf -ÓáP}ó7K¯Ô`5ŽGÝÌ|žc·}’ì~Õ‰ž³ ­çôHó8Ñ¡æiû3ä5yŽ_,èMç)m™äµGÖ–É p¬Í¹ERﺂˆ4$(Ñ´ç'‡¸«z~0í˜èƳ(ÑqxDCˆÜŒG^CŸ0*À lîõÝ?ZY@øë—º¢.În~d7–?&eòåœá5/?ÞǦ YCIîÜ{){Iš/hu>›„s™¯‡3ú¾/«À{±?=ÛC<…ÃO?óϦí2Õ~.gýjìUØ«±TeŒ|çôA_§¶nûOâj8(‹øò¯àù‡ü»cò]ŒpÄú³ÈCüÑêŸÜ"¬Ïtˆ9È»wÎéùH¾…òe‡'‹áðÉ5—ؾFÓÀž>CTŸRyvÜ$qíá’j/Jµ¢¨ÂÅ2W¡¨1Wzƒo˜ÅWTb­â®Å_ÿÔûùŠ¨ËÐâ¯æëó·N}'óóSOeey³Xô¹XÄ÷’¼liAº09åúøðê2é½û³Ùã?chæ:áÇóàý¯0ÌG¡v*ìUتw¢_%µÀŽf †¡ÏE>ÿ<è;´£§‘Ç3Q—^ãû_!ÿ‚Ÿ±y{[uºXñfÄ(Äsœ9íß(’HA=h>”òs¯(ˆ ƒJí·åùÄÄÑ؇ؾD•@‡ h“ê¯.̾”{öÉ5–i#+ÇôbÅòæ¿üäåG‘¾³kyæ(µÍj*©Ðôr·s‡ìÈê}(ˆwØæ¯WÚúm>ÆV{†ÿ°=ß³ÿð:ížØ©CÇŒÿODkÈ}Rÿ6$y¿0¿7ÿ8µÍ[Û*éQèš>–Ò=•ŠHÓHÍ'^iU$Ø©ëœwiö¤µ¤ áˆä?[ô—°þÁ`öfÈråÈ”ˆ Ú#r9ïdÝOÍSß;v*¯m«2/jÔü†l;/Oãê#—gÜ?òÝöÏòWcg̬ǂ?ÖŸ¦ÿÍ/ƒ:Òà,ë·|ôWã'½y?Oäñ|>XÑWº$—^@ó•¬KûÛRŠ=«ñ=¬Š6ùœ£Y,|OÜ]·³y†ÖÒd<£›ùN%ùuž`ýÒìUØ«±Wb¬ßË7ð»Ço+„™H܇j{çoØý© ¸Æ9š˜ÛÞ?[òçü}„Ôv~¯&·O->BdkGy æÞñ—!ôžBýEä–PÑ}Ð>D_eyU ã¶H4ÉízŸæ/’ü¤WÎ>d±Ð,–ŒÝJ’•+ B²HÞȤå9õ8°G‹$€Dz»]Ú¹|-&)d—ØXòˆó$æ¿üägüæF³ù™kyä¯Ëô¹òß‘ç婨Hx_j±ô(ÁIôanè&l€JgÚ¹-@8ñza×¼þ¡øò~”öþx{QÕëˆÉ¨Ä áŒ÷ÿJcùÜ£ü;ÔŸ ç<û ±Wb®Å^÷ù'åÛxõh|ÝªÆ Z{×E…ÆÍ8Û֡쟳þVÿ³?`vw¼y‡Óïïø}þçÃ?à¹í˜ÁˆöVš^¹Þ‘ü0þg¾_Åý¿‰÷~‡æövOÞþ9ØÛóq‹Ü<½¯™B|}i…ÍÿùÌÏ>7š¿4-ü¿ÆM?É h¯Ö¸aþÄƇÝ3…ö‹Sâj8( øÏèù?VÿÀs±¿%ØçQ!êÔHËüÈúb>|RR|‹šÖŠ»v*˜YÜC<ÉäÇzÙÑö?hiô˜Ï8P¹Q⑹øD|†—æ*Ñ”ÎÒ:Ñ ÍÇú Ò÷Ÿ“ç'þ=½üÜéÃÙüµù¯ä½,Ænæºzñ€·ñÃþˆ4½çäÀÿÀƒ·¿›ý8ýO¡<¹ÿ9AùO¥¬bæëRi^6LŽôC¥ï?&³ÿîßþn?ôãõ={NÿœÖü‘µU^ëxiîãl?è‡IÞ~Lü= þn?ôãõ2Hÿç;?"Poµ¯û‡?üÕú"ÒwŸ’?äÎ{AüÜéÇêWóž‘þ?õ¯û†¿üÕú"ÒwŸ’ÿÉ›öƒù¸ÿÓÔ©üçoädÒ$Q]ë’K+Ž4Ó$ffc@ RIÂ=¡Òž§äÆ_ðíè‚Lq€?¦]Eª+ª6èXUºŠö9»|¸ŠFÇx­ß Ñ̾(E+W_Š¿ÿÕûùŠ¨ËÐâ¯ÂùÍÿ'ÉåÏgSH½;9ØÚk¥GÃÌGõYŘÉsþ°ñÏ?öƒ‡ª'¤€? ýÏ×ßð!íA¬ìc'Õ‚R÷_~2{Ÿ!f‘ô÷b®Å]Š»d:7šµÍ”é×¥cSQ€HŸ@jÓè¦gé»OQ§ mÜwsÉöç°ý‘Û23Ôagøãp—ÄƸ¿ÎìÚü䟜ôUUN‘tRœY’u&ž4›õfÎ>Òê8Äüÿ[Ãfÿ€—dÈÜ3fˆ÷Àÿ¼¥–Íÿ9™ù´"0é–º’BM¤²Ê:R¦yäCOõr3ö“S.B#àIr4ßðìLFç,Ù<Œ¢ûÄý¯óçoæ¿Ÿc’ßÍ>yÔïìe¯©¦E µ´jíF·¶FÔ*sY¨íF}§2Gw!òoÙÆö?e-6šþ"8§þš|RòÌÂzgb®Å]Š»N´˜9s”Ž§Šþ³o³zzÊzì>óúžÿà×ÛY0h"~rKÞn0ù?ôÁé™ylê_/¥ü‘¥òh !®Eõו4”hrFxºPA á«kâ1 Žaøïç¯,\ù/Î>fò­Ð"M QžÑ¿n$séH=ž2¬=Žyv«Á–XÏBC÷‡av¤{SA‡WY!{‰¡ð•ƒÊ«±Wb®Å]Š² ;Í~dÒB?Zº¶Uû*° Õ3qöŽ£¨ÎUïy­o±½¬‘ž].3#Ìðˆ“ï1«dù·ù–ñ´Iç]RÕ•ú¬ÆØì)³CÀ äçÚº©sÈ~}Î6ŸØ.ÁÀAŽ“¯ç?÷|LöþûS¹’óR½ŸP»—yn®dido›¹$ýùƒ)ÊFäl½N ><ÅŽB ò!2-®Å]Š»NôM'ôÀyª–P°õß¡oòWÜþ¶ì®Í–®vv€æ@ülðÞûo‹Ùí7 *ZœƒÑæÿN^C þ#·!";¶—©úK 0€‘F»Q°g}ˆŠùQŸ&£$²å‘”äI$ó$ó/dòÆ¡+´í“q‹è}7_ƒAÑu-výŠÙhös^Ýþœd`=È]²9r p3<€¿“~ƒE“[©Ç§Çõdˆ÷ÈÐ~KëšÅç˜u­[^Ô_Ô¿Öo'½¼~ÆIÜÈÔö©Û<».C’fræMüß»ô,z->=>1PÇ•ån[±Wb®Å]Š»v*ìUØ«±Wb¯lÿœxòÔ^eüÚòª]F$Óô9ÿLêî8Yñ‚;†›ÓRc›NÆÓøú¨ƒÈn~¶žþ =³ü™ØYçSÈ<8ûç±ùCˆü³öÞjG#÷•úsÑŸŒi–éúà–Ÿ\PC5²½æõÂĆA œ€Å¿éŠ¿ÿÖûùŠ¨ËÐ⯇?ç5¿(n?1ÿ.ã×ô[cqæo!4×Ö° «ÜXÈ£ë¨îÀ"È£¿ U³GÛÚ¨ÃŪü:þ·Õ?àOíL{´ü Æ°ê*$ôŒÇÑ/væ'úÖvÄìà®]Š»v*ìUØ«±Wb®Å]Š»v*ìU4¶Òn§£:˜#?´Ãsò¹Ñv&}FòôǼóøͽ¦ÿ‚fvEãÄ||Ãø`} ÿJ{îï–éÚxŒ$H Üõ9ÚitÑÓããÈ?2vÿmçínM^zl9 ¾ƒç»Ö¼±¤³IÃÜfK¥%õg‘ôcû¯ƒÃ$¤_WygMá|=†¢_ÿÎp~SÜYj:_涕l^ËPH´¿5_îî#mgz’ ô‰;¨:¶rÒhˆÏGcúèù?FÀWÚxÏ û+)õD™ãó‰úâ=ÇÕ]x¤z?>3•}ñØ«±Wb®Å]Š»v*ìUØ«±TßLÒe½a,•ŠÑOÅ'vö_ë›~Ìì™êÏÚýþïÖùç¶ÿð@Óv3‹dÔ‘´zBùK'pê#õKÈz™Ì¬h@"eAÖ0à ùO´{GQÚ:‰j53É3dŸÆÀrlÁ™è¶2Hé±Ë\_@ùGH˜¾ , _ÿ9®Ÿ,þXÇ¢Äþï›n’Ô/Fúµ½&‡ÒO³fÚG‡§àækà7?¡õOøö?ç{cóCÚ|¹®´Ü>>´ÂÀ‡¹h—†EC^¸ZËÐí²Œ(LÿæŒPÿÿ×ûùŠ©È6ÅXö£%lRüŽÿœžÿœY¼Óu=OÏ¿–ºq¸Ó.Ý®5Ï)Ú¡2[Èw’{DäŒwhÔUOÙvN;¶;‚rá:Ç»Ì~¯ÀúCþ?ðPÇÉÁ¦Ü —yülø_´ðAí^Û¸dŸ‡ˆÿ.1?Ö?T¾&»€MbÓ¤•‡Âsdñ ÇHòó»¯Àp±%îÞTòÃrŠ±øvÂÀ—ÔÞOÐ=1ÁáÛ$ÔKèNôãO‡¶²U<Ùå]#Í>_Õ<»®Ø¦¡¤jöïmi'FFPTЩ‚Œ¯.(å„…‚åö~¿>ƒQ F 丑ßúºÈ‹ðÿóÃò#ÌŸ“ºäâH¥Ôü¡y3 ÌJµ^'u†çŽÑÊÛìÔª÷Ï{K²òhåßÈþƒç÷¿bûíÖ“Ú<!¨ˆõãÿ}çGí)t'ƒæ­îŠ»v*ìUØ«±Wb«âŠIœGm#·EQS–cÅ<’á€$ù8ºÝvŸEˆæÔN8à9™Û׸s,¦Ã@T+-ñ ÝVÙNßìˆëòÔh=Ÿªžô¿¬þ§Á½®ÿ‚ùÈ%ƒ²‘ÊFÿòN'—õ¥¿tG6S 'Eâª(ªÃ:ˆÄDPØ>—,òÌÎdÊDÙ$Ù$õ$ó,§KÑ^W_‚µÉ5ö,ù]™£>™íÛ Y/¥<§årž‘ôü;ak%ð×üå?™†±ù—&m/;'ZÇ`ª§áúÌ€MpÃÜXÏú™ÁûA©ñu<#”|yŸÕð~±ÿc~G±Fy ž¢F~|#ÓîØÈYóVhßTv*ìUØ«±Wb®Å]Š»v*ìUÀ@¤ì/dJB Èšô–aeaQmã iüÇv?KsÓ4x< 1ÇÜ>Þ¿kðï´ª{W´³êÏ,“$TmðˆíYÔå‘ãølÊtD>¡òdîþ—^ØZ‹éÿ-Ô¤!’j/U²û+…‚mÿ4b¯ÿÐûùŠ­aQŠ¥·QòR)Š^w¯iþ¢?ÃZŒ ƒâÍßùÇï$ùÆâçR—M:Nµ!-&¯§Ò)$o’…$÷$rÿ+5ZÞÇÓêw"¥Þ?O{ß{5ÿnÖì01㟉ˆî@Tß}Àðù>óGüã×™´I$:f¡m«Û©³ò첪»[;Ò¼ îV±uöÂÄ—­h>J5Cé~Ó'»yoÊ"?O÷}=²Md½ã@ЄA> a`KÔll‚*í…‚.æÚ¨E1W“ùÇËÖZ½ÞŸ¨ÙC¨XÝ¡ŽæÎâ5–)þË#ùä'ÌT…‚äiµ9tùLR0œM‰DAò#püçüÊÿœTòÜ“Ü^ùJîo.Jì\éî Å¥zÑ0t©ÿ(Øg;ªösMñžÝÌ~·Ù;þ ý¡¤¶ã8Äü¤AKšÒé m*‘Ôaü2“§Ê9Äü‹²lhd.9ñ‘ýxþµ¿Wž´ô$©íÄÿLFŸ!þò+.ØÑDYÏŒëÇõª­…ëý›IO¿ÞF]ÏÔK–9|‹®Ô{]ØØ>½^åÇ~@’‹CÔd¥bÝØ~¡S™¸»U>`GÞU¼Æ¿þ ƒ¦ƒ$²‘Ò?|ø#ò)Í·–Tn$i?ÈAÄ}ûœÛéý›„wË"|†ß±ó¾ØÿƒV«(1ÐàŽ1üéž9|"*#ãÆÉmtÅ…x[Â"^üFçæzœßàÓcÀ+@’v¯më{S'‰«Ë,’ó;êÇéÀîÛG–B>¾^ê­ši^Y’F_Ýý±A/`ò÷“É)X¿ , }å'…Ö/ØZÉ{¾åç‚h`̨LQ1à€Ø¡¥Oza,cD‹4œ:×üáWçÆ»«jºî£{å¹oµ‹¹ï¯dúüÿ·ïmâÇ8ŒžÏêòHȘÙ7Ìõø?Qh¿à¿ìö“0cŽa qˆòˆ¡ü]ÁŠÞÿÎ~oØ‚ÓÜùzƒ¯Ùý‹Œ‡úÕwÇçû¯ù==…üÜßéüSÔ¿ç0t®_Y›I\Ô‡ì§üþ˜?Ðî§ú??Ø¿òy;»/úAÿ×øsRþXÿàôÇýê£óý‹ÿ'“±;²ÿ¤ñNÿj_ÊŸðGúcþ‡u?ÑùþÄÿÉäìNì¿éüSá½Kùcÿ‚?Óô;©þÏö#þO'bweÿJ?â›ÿ êËüþ˜ÿ¡ÝOô~±äòv'v_ôƒþ)ßá­OÂ?ø#ý1ÿCºžøüÿbäñö'órÿ¥ñNÿ j~ÿÁéúÔÿGçûþObweÿJ?â‘–>[¾Žê'Tô£nG‰$Ôn;xæ^‡°scÍä®ocÝ˧{ÏûQÿŽÎÖöf}>drG„qDRÚ[‰áºózn—c)uøO\럞 ܼ¥§IÎ*¯†¾µòNžÀDiÒ™ Ó'Ó¾^¶+m…¬½*Ñ(£ Ëúb‡ÿÑûùŠ»CÈ•c÷ö‚E;b——kÚ•^©^¸ð_2ùKÔõ¥Ö½°S`“Áõï%_÷_†E°•ê^Kp[÷_†,bW>Oû¯Ãm,)È÷†)µ£ÊÒÿ¾ÏÝŠÚ!<­/ûìýØ­¦0yNRGîÏÝŠ-=´òtŒGîÝ…Ëôÿ$9+ûŸÃGÐ4¯"š¯î 4ÄÉéú?‘ÀãûŸÃbdõM#Ê œuO£ ^›¥ùyb ðtöÂÄ–yc§,a~acl†8@lPéb¨;b¬[S±+ uÀÈù‹ËâPÿŽ,|ûæ_'ó2R/ÙÀ^­ù)¹?î¿ Áy½ÿ“û¯Ã;c“yF@OîÝŠm|© ?ÝŸ»¶×ʲ×û³÷b¶‡Êr?v~ìQiýŸ“¤b?t~ìQlãKòKµ‹ðÃH2z–‰ä}Ó÷_†bdö]ÉÁ8~맶`döMˉOƒðÂÀ—¢Ùi‹‡6‰¹·â„Š¼ËÌV¬Èà YÍþlÒ^_Sá¯\‹`|ý®yfIÿw×Û0X Ç“äf?º?v,­|˜çýÕø`¥âküÿï¯ÃO¿Áoþúü1¤q7þ ÷Ñû±¥âoüÿï£÷cIâwø1ÿßGîÆ—‰ßàÇÿ}»G´~Lzÿt~ìVÙF—ä翺ü0 —µy_ÊÌîü;a`Kéo*è¾’Çðt¦²^ë¤Zzh»tÂÀ²øV€abŠ§ê¦*ÿÿÒûùŠ»hŠâ¨Ib±V?}`$q­qM°=SËë(o‚¸ó=WÊ '/ÝuöÀÈžj>FV-ûŸÃd$Ä®¼„ ?¹ü0S.$šO ïýÏá/—øþ)ü1¥âWÈ[ÜþÒñ&ÖþB~çðÆ‘ÄȬüˆ?søa¤q2û$ªÓ÷_†(%›iþQD§î¿ ,m›XùmŸ»{b‹e–š: (´þ 5@(¸P™GZmŠ!iŠ´ËQŠ '€0;b–+¨i‹ o†µÀ—jÞZYy~ïðÅ•¼ÏUòb¹oÝ~)“¾ò %¿sø`¦\LfãÈB§÷?†4¼Isyî i?»ü0±¶§èI_ƒ6ËítõŒ .Zn€:b„-Ì5lRÂum?ÔðõÀògËž±ƒ0^s}äÁ#1ô¿ YZC'‘'÷?† O—ø¾ ixþïŸÃ^'€‡ûçðÆ—‰ßà!þùü1¥âwø¾ ixþïŸÃ^'€‡ûçðÆ—‰Q<†û§ðÆ—‰<²òB¡_Ý~iOBѼª±ýßá‹^¯¤i" ¿ )…,òÒ 0¡7E¦(TÅ_ÿÓûùŠ»v*ÑÅPÒDlU-žÍ^¿)Hît„züi Ç—ãjþìb¶“MåˆÚ¿»v)´yR2»ü1M¬ÿ Çþúü1¥µEò¤cýÖ>ìVѱyb1OÝ»Zk—cR?v>ìVÓˆ4TZ|îÅœC¦"Óá„Î+5^ت5!¶(WT^1VñWb«kŠ å€7lU)¸ÓÕÁøqJCs¢Fõø+6Üyr6¯îñM¥2ùZ3þëv+hSå8Ïû«ðÅ6áå8ÿßCîÅm•£~ì}Ø¢Óh<¹Ó÷cîÅm;·Ñ#Z|b‹NàÓQøp¢ÓX­•i¶*XÀíŠxâª2GQÓJ.m×lRÜi õø0&Òy|¾û­¡Ï–ãÿ}»Û_á¸ÿ߆+nÿ Çþûü1[wøn?÷ßáŠÛ¿Ãqÿ¾ÿ VÝþý÷øb¶ïðÜï¿Ã·†ãÿ}þ­¶<·ûì}Ø­¢¢òú)þìb‹Nm´„JQiŠÚ}oh›aBkS"¦*ìUÿÔûùŠ»v*ìUØ«\WÀb«}4=QOÐ1V½OXÿ±ªß«Ûž°Gÿ?¦*×Õ­¿åž?øý1W}VÛþYâÿ€ÓwÕ­¿åž?øý1Vþ¯oþøþLUw£ûé?àF*ߧé b­ñ_åv*Ý€Å[Å]Š»v*ìUØ«T«\TõQ÷b­zqž±©ú*·Ð„õ…ûŠµõk÷Äð#úb­}VÛþYâÿ€ÓwÕm¿åž/øý1Vþ­oþøþLU¿BÒìF*»ÓŒtGÐ1Vø¯ò»nƒÃov*êb«x©ê ý«^œg¬k÷ U¯F/÷ÒÀŒUÞŒ?ï¤ÿ«½ßIÿ1Wz0ÿ¾“þb®ôaÿ}'üÅ]èÃþúOøŠ»Ñ‡ýôŸð#w£ûé?àF*ïF÷ÒÀŒUÞŒ?ï¤ÿ«½¿ßIÿ1Vý8ÇDQô Uw²>ìU¼UØ«±WÿÕûùŠ»v*ìUØ«±Wb®Å]Š»v*ìUØ«±Wb®Å]Š»v*ìUØ«±Wb®Å]Š»v*ìUØ«±Wb®Å]Š»v*ìUØ«±Wb®Å]Š»v*ìUØ«±Wb®Å]Š»v*ìUØ«±Wb®Å_ÿÙgcl27-2.7.0/gcl.png000066400000000000000000000302251454061450500137170ustar00rootroot00000000000000‰PNG  IHDR,|äZ}ðPLTEÖÒÒoccàèæãÛÛ©¢¢çæ))œfgâèùûúéìííÄ¿¿æšojhµ¦¦ã••þþþýüýxijúúúôôôùþüÚÖ×ç弶¶¿¼¼ä÷õöõ÷÷¼’‘äãã{trÛÛÚÊÇƸ±±çýþûôòòëÒÊÊ÷øøm_`æ„„óïðäÿÿÿýýýüûü•Žéåævvãßàynn¤FFujjÑÏΦ³­­èÔ36þþýûúú†{zÒ¿¾ùøø’‰‰ëðîïŠìêëÿÿ÷éèècy93tEXtSoftwaregif2png 2.2.59·® IDATxÚí}mCâH³6‚Ä`ÔHƒ/Èd *:vd` ÿÿ߬‡K`&PO H¬Iò€­¬s æŸ4›8´ÀäÝù $ >'ž¬ý+~÷}´2_ƒŠ“hR*ã&ÊÍ^oܨ·XT»ðßÏÏÏ›ÍjµÚlviÌŽÅ#}.Á%ÔN»¯¯Öy¯·ˆÖ€húª˜¿ù÷ùùl »|tŘq¸-ßçü/‚…“‚9ïÏÓ©mÛAäãà€ÿ8½5»çN§ZˆÁ#qâ,x!ýá ’EøÓÜðŠæ¯69ZïÌMI:P`¶ XÁ£ÍŽ/üö,‹Ü€~Ûïf×ê#N9Ø@Þ©)0êkC¡a®ìé¨S-‹f6ÕmÎvá¡hCý‡r o¬µ‡/eP…ðoýÞ”Q6_=œ?·<‡ùçóy§Ú«žƒT ÄÏ ZÏz±ß9À»Ûí4k¾Ç[™³Ó ˜nxü~¹oµgT¾®ÕTU¯ÕÜP×uY øW= #TUUÓ´â5_,Ë^§Ø9ïÌè‘ÐÛx¦Rä*‰ë—‡°P©=šyµ®huÕgµl§ëÔjÌ—IIßêRš¢á$’$‡2Ÿ»?q74ðyu%oçËVq4ê‹ÝfµÉ¥=âpiÛV4&FDTÃ5LSò”`Q-zÀš½Nµ)мÖÇŃðžÛ¯° ESuO5Ç—pF#z9ÂK2Ãz]’üºë)ŽYÜFóѢ؛ã3ucæZ·°``!\G᤯PÉc®‹ óÙ}?"‡çÁº¾Ã͸ÑØ·È÷ ›æóÃs¿–^:â—ØÊCx8£^³—­Qk±„Gƒ¯‚utüW1ì—¬r{6¦Ò<‰nM–a¾ìÈÎ*XÄ`ºêøPÀH¿i+wߺ_Žp;ÈñHÁ Iä‚ØG/2Öñ§ìo%ÃǬËৠñ`þ›Öý}k´l-P{E,ÂÁ*¿äXÝõ6†áªŽìiù›ûKø«ßů¢®çtü'°@‹ìÁVWYÍqBæH*È„$7TÅC^(,F „öŠòÓËËËûœx¦j3ÍïˆU˜·ÜžJÝXXSà ÃP¯»B+ H¦ zÀsuxGQ‡ù[|~d.´#4}éuR¨‚økÃñL&kµ s’¹Ìå.s0W‡sý¬õa°ÚM@¦IÌQ%C•83; ð²ãȼåº5اçÕT$UuƒéÉÓåÉe«Õâ$Ü¤à€Ÿa û¹ ®è¡çâôõºaø¦éè®+p–"ï†8dßkÀç äÝLæääòžÃU7]:.Í‚FØ06†Œ¦HöÓÍÓS&“ɉov"½õO`•û9ÛWBÓ AW6×4=uI IÞ³k †i€üù” ŠØñe-˜>Ýˆí «¤·J’>œÛ’‚>d¦ê™€3Ød(&ø*Z ˆ#I,ˆ(ð—ëHLÁùO29Æ%¨Æˆ%sЕ68_f†Á$ áÕÞÕÕÕÍS†?Áüu°Êf”ÚÖ«W<§[½ÏY)\]M£‡*vP=ãCYh6ðü¼·ö4_çöîÓë0 ÆÍ•˜Yì‘$Âüe ¤Pj蛟÷˜ç¸Jáìôìlðâ_DÖª¢uØ®´þ Ön ÏóÚ¹(®6˜ôU°˜—·á±† ê—\= ­áðÝ7ðû=»Þ¨ ‘þìüjC²Kâù#Þ*ïö‚ºÏŒm`É̾~¾¾>E¸n­ÑXëÀÊ´ûÖ4¯¸¡ÉX¨~,%8==› rI„Ý€ŠQÁ¤\m¥è^ä{|v~p;ó‡{§W|×D œRîO™ê’n]K6t5ô¼søüŒpá÷À>çUâø¯þU¹c7ê’‚ êç‹£k=_ãS=! E®&/Ö.€ZÖ”)Žé9‘×ùYb8’[8Mæ'IDÿ´RÖR`¡äû cgçùÑzÊàc!Ǭö°< ÅÉ×]ØŠî~Yg…žVx>äu‹8~báq1èDž ¿ÂUœs-ÿ3ÙvkAîï¬Û 4Ç«³'†àeŽöŽ.|,`-úÈá×9 Ô•bèàÂ9õ:: _‹yZpDŠ+æø™eMÐÙ'[“¤œOaï> Skijt_¦ 5ô²ÛÀ2ó?~ÿ¾E¸v@é[­¥kð5Îu¥7˜g¨¾ƒžôWÁ‚çuƒ@ENÄAÄÙÄj÷‡m`^•é«™ÎÁRCP@uÚ7Qcb+¦®ê©ù` oüçÏŸª °XC—ÝwLíËbè…’YÿÁŸkXž³V¹ÙŸX€•${²†Žà,çó ¾!)ùÄ%À»H T[Ý9Z –ž6¥~ýú…hÁ—¯ÿ,—RéuŠAòúC9&ü'WRag¦1¢œ­ÕÀ;ÅÀ†™.xu5ئ“*…a-ßÏ"Z VZËÞ¼Ùœ »í`•Ú>><X0*cœ ˜ol‚z’áÈôœµ@©Œæó*`å5T5í’ÔÔDÔ®&ãÊ•Jw·Ì´sìë5ÇËßýúq+1sÒjÁš:(‡ÔçkîøàÛc‘ƒEÌŽþÅŸÖY *ê5¬Yò]ÔT.BõP°*0Pú/@<Zx ,É›`ž©X‚Ž{7'—àÆŸO™fx`ÉR{Óè5X~ŒÂR©T*D—LJq^â4XÌõ=¿ÀU•¹_½;Ý-`¹’+þY説‰HCù¸ë€.5\›‘šÌÞ°‰ Çê`º¸û…ã._©*~,ß•Üp|Á)/ÔéhTÍå¥Á|f:v“¤Š<<~C¤¹>¾ç몓ËðaO-D œÂ÷Ëi]ó%1H»Á÷ïß ,`Åk+«¬Ož”ZSÏc¤ozˆf6 *R•Güƒx›øõÇ‚º‰ÕR:K°ô,NÈѬ|ƒùi䩪 A¨uÄ:°ro¸¬P Í‚Øü3„ÔO—K[q™T¢§9+8°@ÁÿøÍ©©,ÂÒÁ*[“¶UšX¹¼N“o:Ô9j -|7¨\Ð*œ­©;à4™A,áàÝžÁ‡®›¹]@ Aφ\ÿôtÒš£rßpåCƒ˜Hy H g*„Šx÷ÏŸ_DFx“€ oÇp)8Hcã»DŸ.3ùt˜ã:p­Ç¾g ˆz‰Ê¢ bðQÎ*Y¥6Ķà'† H+¢ ¿ºªÙ”T‡ Ú‡q´ÿ³ eÁX©à§òk,´d…ïß¾!/ÐP )¼œæë)Õc:a]õu‹a.ë¹-0Hàsº`2}]ÛìcÆÁÂÝ«\ÚR65¿çû๡Xà:€ý)TXOa ?Ö``µÛVÙ×Çc>[‹¦3ÖƒÊéuŽ'Œß!ö+À6ÅÕt2ø… 7e´ã;á"Xøp ~Ó΢ÌdÕ ÁÖ‚Fˆ¿=â2œ"ÇÁJ·ÄZ  Š‡'ý@×Á+hÝ„V|º,(á°XÍÝ1‹KíŠv¹ÊúX˜zøRšª`‡CgEÖ#5/ >V`óAoä*~б³sx¸ólûuä¦B¡* 4>9a•Š#\ WÖЮ{iOÃ0·€ü­‚(ÇùMA’nía ¦.tÀU!1G…}±ÊYÓ ¾Å…àÃs1ê÷Ê…Âkô4Ðq ãÕ_²–Ê¥a ƒ5³æ4˜á­ñ*^ä«o•ÇdüOŸ¯aÚ¶}:Ú¿ý-ÐB쎔3a%béË›|¨¦¬T–©YCmä¿WÀ²ã:\xùY Qdçy¬™ºoúàÀ¸ª”œ@`#æM—'Ûh¤ÿDIáñáªö¢Í^²¶Ë/¶QK('SF\¬ønáÔ°V%ÚBuxˆgÙ§ggg{g§g×€ÛÎÏ££ýß?~ýùä<OQ2—à0¦]¬C˜ÍÑ¿ŽD0Ž(òü|ZP'rí pðÐ7>@ö½¸ˆx}ø@QÓž¾Žws>2Ö7Tïè$G±ÙÂã7/¤·€eµ!Ì ÍPsÁ$mÄ·ÀöàN#V•+Üü¡8õÇ[¥)üczzhsýøñG T9YL™§¦cB=„šQ_> \ýPÑiù)’¤ åŸ ö>.ð˜—dýaå‘WÀ|¤ÅBqKâR¸b ù™rµùöë°ðºÛ®« ¯tUUWM¯Ž±Ž|õ¸ÂW+<žÄë·§§›§›««³½ÓççCb®Û[°_Ü­¸MÎpQE ¸飖† 1ä÷Ôí`#¬bŠœM¯¦WvÁ¾‚ìÀ „Ö¯;>øa?žÚ»¿d X!Ä–®Iá¯Ä}oðØþ`vµ¦nhÖÒ§w F]§Â-šîБ,]àÅîÉ ü@¸@i3ˆÐ?²–ü^ÚaÕ¢-ü½æ‘b\ø°úC`¬,Këð³ãxwâàˆœÜfüàhµ®“ Eâ.Ït÷{:ÝãŸoŠ§£D¤b6¦$$Ñ*Vļ°L —@z\§Ä\?ÄàrÎyt"Dã©XSö=— )û¯I\ø°¬Ȇ§¦Á2C3W%Ü@óãôžà´ÄlH°Ü 2áEƒ¬Ì<Ÿ2:÷ri°¤ïˆ²oä3qŠp‚àË_B;g^”rb^!çWy$.}:á2O|çó#X+¶°;{37k+Xí@1@â¤- >]òý[t„Ëà:,ÁW‚³rœðÖÙ©×°…½éh§Ü} |,¼Dж\i߾ǫˆ#Š3~ÍŒIAÅù¼X\\D"GĽä“ù@9·5 zZ'!ó$Há¯u)Dô=ÆJƒ•cu?ÛHƒ%ûàUFDœÃ2Óࣣä‚?¡ÚÝàIÆ–‹•c!ü#N=é¢ñ3»ŠóŽ9À…²H¢xq¯`^„ 8 ˆ¿Åu0u&'qᦾã‘nËV@ÃJi1t!($°8ûþ>¢oj+›³€5ü¡høïô/€É§m\æZ#[KÕ€° %†¹@x,w'Ï /["ÅSê«Þ|!˜ àB>BÎ sî>“×d‹µ…0É`q[xÛÂλNÖ*X%Ìn—z˜ %;rjµÐGIONb¢5 òû©xÏB¼'‚¿šÁ„ ÜwÎÆñ$ÝÃCS¾“!êä^^eø3¦‹RY ÆÑÊ]r·N ôŠÁØä.[E»!{®TK_®¢~ç4ßf ?V»Sj÷­riZ¯;NcK.™Y#I§# øRàišoüå¶Ýe#Ëxâß zI`Ñ–Ó| ,æ‚s’õ=TïßQ W®0n£¬¼*UŽÌfÝfµÚ™ Íu‚n tŠOrdmæƒ?¥§üEæ{±-¤Ó™ç•¸pòQ°†íR© ~Cc;Ÿx5ZC,ÂÅcš±ë<Ùöm´Â°ÁdYWl ÿùc¹û¥­¤og\Ÿ†Ëz|‘ÀÓ[F<)FT%w.Ô\£÷ëh€€c–d Ír.ïš’ÜHê—óÊ–¸ðc¿M°ÚíR¿4ʃ¡?©M«¤K¢EÄ lÞ+¦ý3ˆéú6‰ ê÷Üe.ÐÒ§ÀYäÊ‘¥zŒÏƹFá7żÖÆäxÖE½EÌÕŠ¼arÁ0b¼©ª’\3RëH—‡ tN¶ðý¿LröÞXS¥êªž–C—KáãÃêÕßÔ©ÿ , |O Àùáþ(8¤Ózú´AâçL\½WVWáñ+^Sˆhsu.À t[¥æE¬L©‚Ô bªi?k,ÀÚv:óA°^¬~»ÿŠœÒp-Îâxõ„Ÿ_*_ÚŠ±y ›>Æ°4µpvöŠÌ:8YFJ—Hž`†A¾ü¸7¾ÎkRf;¯4pæj6‘»Š 1¨à©7ïôªç¹¼§Ê¬f˜[ìH:.Œ˜ ß/WË$G~åWºP×)°¤qŠä™LPwþ£äü¼MgQèZ …[ò¼<Ü"´…•DcqÆâ—êÑ^x1*G‹„QŒ–ÓuΛͮek&¥=Áº{ ¦Ï£ŠTQÌ:³š“ck”OÇQ!¨E‘#–Âka {9pØpJ_¥Ù–«)CvtL›'~C¤KN9›Õ`é(_÷5©ptž\᱆¼ÅSu&ôÉzÔÆCÜÝ~·Tî[Ö <é—fe YíøxÖí&¼T» šÇ²ašÃÁÎÈLÜF§3×±~¬~Ém t0ŒLÆã²o›‡ÖSÉ×+v¶€¥: I ~ßÞŠcôÓ½SÀ¸¦§ý< :oˆ‘ä³Ú´ÛƒÒðÅzm—†åÒäu8™¼ÎšÝòLŒ¸¢¼Ô.[[ˆîÐ}!‹î ï6î «o'GnkØßÖ·U3“Ò(øÕQLr0j’ëÿÍu0œÈðoqˆ‰®¬Íd¶%cˆ…RMâç ´ÊŠ¿ˆ«lµ­~y‚U/“ãV„Ïf“ãó,ŽYÊåÓ©Üâ¾P¸&)æÌO>–5ì·m×Mm"“ß³qùˆÓ(2׫µµ¢í^)óX!N Ö²5'«úé›èЯ‰ý\IÆC×”Tið:Ž^¹ÂNf‰FåàÃaßÚíÛJ:ËF6Г†DD?K¤R>Ø^¸û5ÐÜÔ&ÀD!Xã(AgE e³æ¤R‹ÒW[¹ÞEwÑÈZ …^,NV] Ÿ¨|“ü²6諲•Ë+=íu-ë ßyµ)!Råý°Ô sK†Ê'k…èÂ3y³`g+Xýr/ÐÒVJ–ܬ‡‡»•Ì/¼#eµ¤¨ò7}f({ã‹8%Áò˜¹íVÁŠ€b)ä‡rX„cuÑif5EÉÛÓÜëy«y•:4yíü1õsDëi×b©¬Ca:S«+ÜãØû7)°¬>Ÿjm XF çÞCž©( «kQ1{CJ§/ aá¡ß«?‚1µmW` Vd i•ˆì“Á.ž‰À“x¦ê**à5ªž7{E^ ¾Ò7b1›”¾C  Vé¥lMÍF:C«+<“Œ!ÙÛ(YõfºÞ¡P(€ªHûO¡àýu|–g³,xT)°BÉsØ÷¬•Ì%xš»“r´¸O,*gU´|0Í«åÌ=¬ômòó²…éUI%æ®ÜÚ¯ÙBRïŸë("§-®¬Xµ¬„{—ËâÄ—­ËÌÓÕÙóÎNA‚ÇÙ’ê9Nn¬âÛ­`ñ«ŠÇõ³“VýBpm,‰á]C•M l»U,—ò²ûîlq¡»%/ ÀÊJk®ÉzÛðï}L2Iøïµ4gøû£´î8à"øŒ£Vî郎@m¤Ù}fá¡ñ/\ɯ¥]+”øIìZf 0Vqb3.»Î˜÷UÉó4ˆ:§'£8®t8Xm—í:¸…zÚ¹ç8XqM62Ø>VÀ å´I °ÖN5ÀLáRëòä‰.ðlÉ“õ ø„X¨àO h”4XÌ7,nÖÑ)‚Ù;/‡¨·Y¨FfÄ—³XL*u7°ñn ëÔ®s°…ಥÀÒgmœvM")Ükr™ä¬ `ùéM€és°ÖÉVóå²uòtƒWéÍsj©ó#Ý]õýžaMS¸åÚÞ7™”Þ fwv±)æêÖe–adC,ÐÏ3M±éòëÔçs¼÷¬É[r ßGrÉ}¡pM’>©Îmop€•UÓüYËÇÌd¸H«Eš¢ˆbøtsuvú¸>K×P‹„•¡ï,Ó÷Ò ØÄ¿Æ—û-¼,qœ\š[=p§îE‡’Q«™’¡«`âž° Õƒç綢²-µ@&sÌä¦âG\¹p¿ŒÎ†Q‡¶dlàƒµ‹:ËIƒ%{¾Êè,:‘ãÕ 9x´^t+Wð{gvžIÙt2?E®‰µ°<ËMq ±6NéwôfX8†Çö¡ÊÌÈ÷ õlȳI%;é5°\,‚ºì¸Î°˜·vFÑEÞÌáx2ÜlØ6Øèmƒ5|Î2Òbhz€¥HñEÛϨ–«rØÖ‹t[°ÞP·ž°$‘ë^ Xž›¾¶Ã4XXئʬ)Ì:QÐ%ÉGcJጟ)ò&'ºÉÔP•Ò—·Ìû¾©²nø;³¤YÛ$î»5ÆÛkжlÅ•ý·âñ÷ô+’m ‡`‰»Îi ™SÍNÅdê,b}îuXà2n9(õÀùÅ$¶•ƒ î0.š¬Ëßü¼ÆÀ|†X5xx}}F)xsT´.e§­­8#}|X«ò@;Q@ó¿“œtá·$6OºÀ$ Þ‚ø3tÞK`°ƒ$Á4 °"#òž—‹QîòrjЀ + Õ‹3]Á'|æ+0VÌÛRñ K¦Ç­Uþ3²ìœ[Ó@ÑÓè6$°ÊÛ;<ï ê2wh¡©7ü-ñ<–`Bó¼Oç•iT|~.:ybO¾™eÍšç“8àä=sÖÁ*ï–¦J]}ó¨Å ¾]ÜÝÎ">“Ë‘Ÿ~鲸˜Ú˜±²ÅZÂö† aa8æFRõak ®,V…’Ýø£H΃À, ìç9t·íl_v)%iF™ÌýTrälj~¢xp¼Ù«mj/xo<LDsÚ5ס?eZ:_*¦<–áÉA”ñ~`g¾¬ÞOƒ|Ô¬©…+Å` PM“Õ\):¾?€Ú×K·;‘B_†¸až€Yÿ­eÆÆB>ŸmÉã2AƒÛ}ž«ÉÓ’îA:LIfi°«|x-2IDATBÓ•™kºÙl¶V«É &jÍÖ©†m¡’ F= (†ZéÖƒ5iryEz³`øFßý¹å`q®vr šâ‚' Z–V:Š˜Ž—Åͬßḃà^xu=] ÿ=k„n>(üúÍ3)¦S»¯ck(-‡1×3,Ƽ¥s2ʉx‹#Ôûib€sŦ®ëÞ{Ãô<Å.ö¸BîtâÞv¨·’Øp0WÆ©½yÿ'…š›„Ÿ‡[<ªJÝ4I£‚qžW+e¸ÁDhwÉÑýM“Ób"û>ö2 ¥·…BäY£ΞcélÆ”|áÇ/̹ݧ{{O˜.Θì¨[*7Bjäåó&VþJ?­¤ƒ×S§KŠ‹¤·¢&:Ëšíöf¯¦ª¡§(|ÜJo€ø…5Cwݬ®R¾š˜læx!3$¸®Þ á•¿ÇRXÂcB,óþª×WQ4W•ÐqñIM÷“PÑ{S’2¥É‹š Í𙤻ipQf=Sf‡#(ªŠm¿bÈuP2÷`)Z¼ýf£I\ñ³Êåf½–4͸ž`¹´Mó ÃÍ2l”eÈÞa Mð‚ï«'TÜé°_OW®Ê¦««Y]Ïb§5æKNƒ1_Ö±ÂÙņ])Ä‹BG:U¤dÊ@q±HRK_ûØHA2¨Ñ"F¼å˜^[;C¢§{L2¡ôUѸŒ7Å[å,«œ L—ˆµ¯6»Ð ê1&K~ˆÆ->IîL§y¯î|¹M xs˜Œª1%?\ðê):°u~¹±P\ø®»‡Xú€éK9ÑQ‹®VÁê[ÃI'P|5­šVÀîÜáë¡ë†ž ¸»?VV‹¶©pNßÂ*î9Þœª"VX<ý…œuµ-•é“`9ZpzEiÂIÿ1ÎZ+`µ‡å&VÂ;†^—¤†ùåÍ0<:QU<É¢d«ÇÇ$mŒÎÁ`ÞUçËÄ}#Ä’1–ý?&űȷÛî ? –‰áÓéÞJ·6Œgt8ƒÕ o l(7Ø×w£cÛB¨%Í Æ¼#º­A+ ¬}’WÔðË=m$ $øªr€åìwqNóÞ¡ëý3X®oŸ&9,ØI4ZkrØÖ ±Þ±ñõÖO¦úˆ9š)¬øŒ”˜ûܲ«|¹áÖ ¸Ï_UxÁŠ¸Ù¹F)4ü+Ø9äéô¼[±冭€U¶v‡Õê(pC°Ê[üšŽšÆ ¥Dlup$‚‹À¤-qñLJŸ…ÉÇXM{ °ŠrO§”Íý`i¬žù)zÛÑ%¯8J]k·<<¯–¦’Â$Ó”j_ÖYŽ§¡[9 *‚ô?Ö’øZ‹ª-_( ¾1ö/8 š|¼¼åiWvÞûr³Ë¤ÿÄ#*âýÇnâÖvkbØŸ”»»çs؇+×BãËÖÉÔÛ1<_­µ"ó²X~µtP…TÐN÷kXÈU¨ƒ:5ý_ÁÊÿNºµ%Ok`õKƒá¬ÛìÌ‹6 a>x†àÞ[×ò+~‰ëʾ^±id³¦ê2u^‰°â»! °X{Å\P¯C¼â;"‡h<õ·æ—ÀqÄæSLÂù†êê BM]Ö Wy0²lóyåð©A(X}•®GÉ¿ÔŒ©¹¦³ú¥Òð¸Û­Î{èIÕÉÔ-[+ï*îbšØ¨Ø3ÌvÇ8ø‘š>D þ¬¤³cïãžë,¦àûR—fè…:óý7.µ%³`[`°°8¹ÐWÜ¥ª±§C¼Yù4Hñðjód©p÷+*‡Rð—[ÀLŽ»ÕÞbžoËu\ÝWõ—ú¿ËYÀ„*žeé°c…:<Š5q†C$„àµÌ«ÅâršW٩ˆ‰¿ó&X& ˆMl?ƒPa÷‚.‚«|µws‰½stõo‰*oÚ 34YÍ °&æý)nÞ“Ök` gÕÎbÞº´ëØl¹… ñXžGÍÆ!Ó@þ@4¨oLÔK$*YŽˆ´è`61€µœâÍ…ÃN‡é[×d~Oõdºêõ$‚ê‘÷zXÇ ³Áq¨™òW‡Ç°r|qñÅÏ+ißi°&³fµ¸Zªª²Žþ7΂-€Úq½È Eí.D“âçýÕÆ–tÞÝéõæ½E«…•aškJj#|,ˆ1CtÜB`ÛÂÁC…w â 5~‹‚Ts=õêºoêŸå¨$·Êñü8‘“vü–œÒþ:X ‡çÅQ.—™ÚùºæÖ€šUð8U2Ø¿‚é!n²“´q8­öæ³jµÙ+.÷÷ ‰ì¹ö÷fo‹¹LɵªÄͺîâ6¢1é=¶ØôŒ7­Üß¼ä™aðbÅÙI­å”Z]¬¢»­S;ÐOfxûXš‹­M Ò…hÐvq·Òñâ0Á ƒÒóIõ|ÖœߟM _»°¥3[Ò¤ÌsCpÛ(ìé²Ò+HåSĉá¹Só²_ìa0¼¨Î:J2’Š¼Ð¼´ZoÈå° úd„é g×ö80µGëMŠÔ:-ÔG%i’P½^¬ Ÿ£!iå(ûÆ.¾ë¥ûŸÆbžZ|'_4ü}±UÌ´T¹9U4¹ŽEs#ûÁQ3±ø;œI+&0±¤ß{ÛÁ:ž«µÝ_fnöÎΞwl<•šÑ Ø–Ë+êSX*ê:õ ¹Üœ¯DÿÞ¾C©ZÖ‚UNíÂ8ÈçYk8=¾Œ«cóHŸúIUEñXÀy¯ hv~8›Fã0΋ÆxË(lÜy‹¤p%qd¶vžE`¡=l‚BY¢ RßlÉñƒ–KêwÅbÔëéá"ÆI´M£ÎM¿ãžQ‹ÞÆŸ^Áë1ÿ&Gù7Ô·æwwï\[…¯LõP‰­-°¿¿Ê´(ás–e‹‘T<ïíßòÎ+B…Äý;ãdém`MŽ›ÈZËû\†§Æðž?¨]Ñ]<'Âô´zŠŠ™jªËøÈ‘ÞçuL±2°ÈVBšÜþ¦–Hwwol#¢ÅïªHE pk,ׇëW.âq÷ƈ1E–ãy­si ,B+Ú•¶óEy ÒÝÊb H'Ñ7-êÜt(*uDm>86EÁ ¡ÕCA„M·h•Û•U.„­Î½»HÖýÆŽâîV2ŸòŠËïêó‹ãµZz ¬èQ‡–gŸEIƒM°°4 d¤Ú›“ "oFýwh'’墹9LDoê85]Q‡ß  Šwp`)*‘„Ô6g >=‘h_»àKÄLËÛ­ˆw0,¨ =8˜’s+o¼rKWþ|füŽlxìFó"« °8ZǸ·ìOQ“ ÜÈíö•E^oÂyêðYtWØïÂéŠLõ%üW9Z—O´ oü±/¶«j~ÅËü´ˆ :[ÁNµŠ‰U®³24!uðâý‘q‹c_4Šºéó#QÖSÚhU€"§:0ôåeÜðE´0Á¹¶­’ô0¢ˆ7hPç˜ûûQtûÖnvdI-ÚÛSܶ†/"ºH‰ö”&ÑÁn‡·†âóó6Aˆã.‚U$¥÷]I:¯DCÌD{Ù~Áß“-Ô^ˆZüó¼‘øA›}8ÕIÉ·îÁZñ<Ï¢…ÉÚ2û·ñRI#qzÍ¡Ê ¨6nÁ¹%Á#Ž9V„¯tù=‘èÙ÷WFD ÁT‰ÙE·Æà‘ðŠü¥m&Mˆ}tìììì$2~üEUùén’TÜ$ŽÆÌ+j2A-LÞZ;ZAô6áH‰–+ˈ«ºiŠtýÖ"ñ§1×Fi¤ÂÆb5<5h[ñÐ|ºç¨qЇ}žëÞÏûŠ‹>"¥m Qÿ YëÉ!Ö>¤&Ob$ $½Mø…›€*¡ûD°r\ŠJ›ëóOÔ(åšVÙº-qíeü¢+ñŽ>B+žKöÁ¹þÔ8Öˆ¯ÁªÕ$í;³å•àC<lv(o»õà‰šððIŸDq ˜¸· i*NõEò=®ÚãdµÏ¨~¾Hj;$‹œnÛCÜ#)#,lQ¼6Ž„‘²­öŠIÛœn/ê½ò‘Á?Î׸L^ð%2oKl„ú½saSl$s•¬Lø¬,!z›d"¤H™¨¢Wî½r.* '´D)Ñ(ee‘ÓôØ÷ç>QVMñ"Öhºê øôÌŸ7|Ñ{Ö¸ó.òJ3ÛÞ6/4 ßÈHt£ÅÅê{ ’P¹{ч‚^ÌפWçm{‹n¢·¨óGB”§¸µÌÚ"7QOAÞI¯‹§çͺqKÑN/j¼òÑ‘ÉÄôo³‹rÙÞèSJû@•Â»L—¢Û61Ù²:Ÿ?â¨)ñŽÓ«-¯ ¢ˆš†·þˆá„¡­ÁÛ§ÜsZ“W>FL+¼·&ñdlBH?5rÑ"sÎW+oiÍôßx?5EìÐM9¨‹ÉeÔöeuðƈ¸%€‰š#.Izt»¼Oº¼ îP´JÉ¥W-RpZôâ·c®d« ï·!¼V:¯|p´ZbÑRi6™¬P:óÖ;œIcRßÑ•ƒk½µÂ P¸‘æ,~©óF•Bi]Þ97;Ñ"Y4ë]fxòbT]¸òRñ‘9•ÃÅ'ÃŽwŸô Þz¤Gí§ŽWíÒ;/üDm&xWŽbqÁ÷Â{Õ Œ¢0|=^WÊ]…õ÷9¿ÍÁ‚«áµXrÄâ!6Y‹sÑmlÅoÛp¨'¢_T‡zˆqã|,þ2¢ÏE½Gh“õw¡fÞÙ g.Ò]È_ØÇdÛ¢+ó7£‚åä5ô}Õ9×\ÝhZ¤˜ÞILŠ•„ëÍ:.ì#r,ž'£Øúƒ£#F5~ŸzòÂë¿¿ð#òã­DkÏ“‘,Óƒª‰tüõí‚*1\|•ù|}¾n^cJlZX”ĈÀb¬t^ùРOv‡g[¡Ó{›¡‡ˆÐ[/›Z«ž]uJx³}šÁèï®0øK e4Ã{¥pïnuu_}íÿôø,ÂÿÛó}¬/pÊj³ÿG+ÿXÿ'›(½µÞ××-ýe|„3ÿ¯Åðÿ+ÎÙè2zÀLÿ¿ãN ÿ ÖÇÁúOÿ«àF¦`{¹©IEND®B`‚gcl27-2.7.0/gcl.spec000066400000000000000000000063561454061450500140750ustar00rootroot00000000000000Summary: GCL compiler Name: gcl Version: 2.5.3 Release: 1 Group: Development Source: ftp://ftp.gnu.org/pub/gnu/gcl/gcl-%{version}.tar.gz Copyright: GPL Buildroot: %{_tmppath}/%{name}-%{version}-%{release}-root BuildRequires: texinfo BuildRequires: readline-devel %description GCL compiler. %prep %setup -q %build %configure --enable-readline make %install rm -rf $RPM_BUILD_ROOT make install DESTDIR=$RPM_BUILD_ROOT INFO_DIR=%{_infodir} # installation is a bit dirty, clean up. rm -rf $RPM_BUILD_ROOT/%{_infodir}.. || true rm -f $RPM_BUILD_ROOT/%{_infodir}dir || true rm -rf $RPM_BUILD_ROOT/%{_libdir}/gcl-2.5.3/info %clean rm -r $RPM_BUILD_ROOT %files %defattr(-,root,root) %{_libdir}/%{name}-%{version}/unixport/saved_gcl %{_libdir}/%{name}-%{version}/unixport/init_gcl.lsp %{_libdir}/%{name}-%{version}/unixport/libgcl.a %{_libdir}/%{name}-%{version}/unixport/libgclp.a %{_libdir}/%{name}-%{version}/lsp/gprof.lsp %{_libdir}/%{name}-%{version}/lsp/info.o %{_libdir}/%{name}-%{version}/lsp/readline.o %{_libdir}/%{name}-%{version}/lsp/profile.lsp %{_libdir}/%{name}-%{version}/lsp/export.lsp %{_libdir}/%{name}-%{version}/lsp/autoload.lsp %{_libdir}/%{name}-%{version}/lsp/auto_new.lsp %{_libdir}/%{name}-%{version}/cmpnew/cmpmain.lsp %{_libdir}/%{name}-%{version}/cmpnew/cmpopt.lsp %{_libdir}/%{name}-%{version}/cmpnew/lfun_list.lsp %{_libdir}/%{name}-%{version}/cmpnew/collectfn.o %{_libdir}/%{name}-%{version}/h/cmpinclude.h %{_libdir}/%{name}-%{version}/gcl-tk/tk-package.lsp %{_libdir}/%{name}-%{version}/gcl-tk/decode.tcl %{_libdir}/%{name}-%{version}/gcl-tk/demos/gc-monitor.lisp %{_libdir}/%{name}-%{version}/gcl-tk/demos/mkBasic.lisp %{_libdir}/%{name}-%{version}/gcl-tk/demos/mkCanvText.lisp %{_libdir}/%{name}-%{version}/gcl-tk/demos/mkdialog.lisp %{_libdir}/%{name}-%{version}/gcl-tk/demos/mkEntry2.lisp %{_libdir}/%{name}-%{version}/gcl-tk/demos/mkEntry.lisp %{_libdir}/%{name}-%{version}/gcl-tk/demos/mkForm.lisp %{_libdir}/%{name}-%{version}/gcl-tk/demos/mkHScale.lisp %{_libdir}/%{name}-%{version}/gcl-tk/demos/mkItems.lisp %{_libdir}/%{name}-%{version}/gcl-tk/demos/mkLabel.lisp %{_libdir}/%{name}-%{version}/gcl-tk/demos/mkListbox.lisp %{_libdir}/%{name}-%{version}/gcl-tk/demos/mkPlot.lisp %{_libdir}/%{name}-%{version}/gcl-tk/demos/mkRadio.lisp %{_libdir}/%{name}-%{version}/gcl-tk/demos/mkRuler.lisp %{_libdir}/%{name}-%{version}/gcl-tk/demos/mkSearch.lisp %{_libdir}/%{name}-%{version}/gcl-tk/demos/mkStyles.lisp %{_libdir}/%{name}-%{version}/gcl-tk/demos/mkTextBind.lisp %{_libdir}/%{name}-%{version}/gcl-tk/demos/mkVScale.lisp %{_libdir}/%{name}-%{version}/gcl-tk/demos/nqthm-stack.lisp %{_libdir}/%{name}-%{version}/gcl-tk/demos/showVars.lisp %{_libdir}/%{name}-%{version}/gcl-tk/demos/widget.lisp %{_libdir}/%{name}-%{version}/gcl-tk/gcl.tcl %{_bindir}/gcl %{_datadir}/emacs/21.2/site-lisp/add-default.el %{_datadir}/emacs/21.2/site-lisp/ansi-doc.el %{_datadir}/emacs/21.2/site-lisp/dbl.el %{_datadir}/emacs/21.2/site-lisp/doc-to-texi.el %{_datadir}/emacs/21.2/site-lisp/gcl.el %{_datadir}/emacs/21.2/site-lisp/man1-to-texi.el %{_datadir}/emacs/21.2/site-lisp/smart-complete.el %{_datadir}/emacs/21.2/site-lisp/sshell.el %{_datadir}/emacs/21.2/site-lisp/default.el %{_infodir}/gcl* %changelog * Fri Jul 18 2003 Pawel Salek 2.5.3-1 - Initial setup. gcl27-2.7.0/gcl1.jpg000077500000000000000000000411561454061450500140040ustar00rootroot00000000000000ÿØÿàJFIFHHÿí ÆPhotoshop 3.08BIMíHH8BIMó8BIM 8BIM' 8BIMõH/fflff/ff¡™š2Z5-8BIMøpÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿèÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿèÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿèÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿè8BIM@@8BIM V€4€N :ÿØÿàJFIFHHÿþ'File written by Adobe Photoshop¨ 4.0ÿîAdobed€ÿÛ„            ÿÀ4€"ÿÝÿÄ?   3!1AQa"q2‘¡±B#$RÁb34r‚ÑC%’Sðáñcs5¢²ƒ&D“TdE£t6ÒUâeò³„ÃÓuãóF'”¤…´•ÄÔäô¥µÅÕåõVfv†–¦¶ÆÖæö7GWgw‡—§·Ç×ç÷5!1AQaq"2‘¡±B#ÁRÑð3$bár‚’CScs4ñ%¢²ƒ&5ÂÒD“T£dEU6teâò³„ÃÓuãóF”¤…´•ÄÔäô¥µÅÕåõVfv†–¦¶ÆÖæö'7GWgw‡—§·ÇÿÚ ?õT’^õ÷묺·Òí5¹šgd0Ã"~ËKÿ5Û¤XÏø¯ôŠ~W•ÉÌåáç)–ýâ‰HeÚëß_º7H{ñªÝŸ˜É¦’6°Í¿!ߣ¯úŒõnÿ‚\µÿãO®=ÇìøXµ0ð,u–8i¾ƒè®Gö½´PÑ'À»ü•µõm¶€ –=ÝËk~[ƒÜ¶åË|3“9¿Y‹õqJ_Þà‡¢þó嶎‹ƇÖ0}ØØocQ˦úµõ÷¬Øq2iûpisY»}v4}3MÇogçÔöýô‹Ï3ºQÄÊ42‹oah{lc Aü׿ù¶½»}K¦ôþ¥F~>G¤jôl%ÎÇÑÑÝùŽG™å¾>\Î9qâ"|&¸¢=¹Kô¿¸¨™Þ¶_jex–™Tú¿\é}duÅ-v•³W=ç÷j©›¬³Ÿì~zóëz?D³? zÊ)˜6ZïæëŸÍnž¥¯üÊ—™u üÎ¥™f~}¾¶Mš9ßšÖ[U-ÿK?ug|;ᇙ&s&8bkOŸ$¿v÷Ëç>7³Ïÿ¹Ž3§5¬Y”ýOýgvÏýˆTGøÐúÉ2qðÈýݶú^ªÁÂéd´>ÇzMv¬hâ?{ù }S¢]ÓñÛ”\]Apc‹„“ô?²å©  G/ÂY/‡ü¤î»î|œK ÉV÷_W¿Æ5G%˜]F‡“o¶›íô½ßè÷81ôØïð{÷²Ïô‹°®æX%¦W‚²¬‹u {,syµÍÑúKÓ°úûðúFOP¿œzM›OwÄW_ö®sX³¾)ÈâÅ—ÁþTðûWÅÃ?Oõ½|Ká"A¾Z=güeåaul¼,<:¯£ÏHZ÷¹¥Îh¯µ­wÑ·{Ÿ«?^óúÏP~6F%XôUY²ËZ÷8É;*`ÜÖý7Ô/4ζÖ8—=Þ.qÜ÷iåt_U«±.n†÷I?Éoµ¿÷åsŸä¹N[”$cç§grõOô§ó~äg5±”Œ·Ñõš®m¢ZŠ¨ô¶9´7w‚¼¹æWÿÐôO¬=Tt~‹—Ôcségè›È6<Š¨iþK®{7/.{œ_c‹ìy.±ç—9ÇsÞï뼯Lÿv=½ѶæÖ×ù]öþ{¼Èðº_â奓ô²Lÿ‹—þí‡)Ö»;ßWð‹Ø댓ü‘£ýýjõ_¬èÿ³ñ1iÈ}u±×¾ÒðCßïôÛéͯfä_ªU×ki{憴xð µ[úÅõ;¡SöŽ¯Ÿ›‘[ïs­y²ÚšÒâ=´ÒÓN÷}NªþšÎÇ—N{,¹¨ÊveãR— #éÿ7Bòˆáqlÿ}JÆíNÄë[ýêÿÕŽªþ³•xÈÅ£šÒ_Yy%ï>ÊÿHí¿A®{× ‰"'X<Šê~©ÕcaºzÏ;ÏóYÿA^ø§-Êrü´¥ QŽIe§éHüß¹°”‰Ôµþ¼çŒŽµöêý5¾ƒsÀ³%ÿùê¯úÚÅÁ de2· `÷¶t?ÛÜ&¹¬¼n3Ý;E¬Õ›ãó,nú_ÿ¼s+' ÷cfÔìl†uV:~ã¾…þ]kÞȳ:§G§5…¶1¯úKGøœ¹Xœfæ2xªøe Tú¿ÅY8qk³âÔädc’ì{ì žMOs'ã鹩ŸeÙWo{ìÊ¿Ïs­|xny{š½"ß©x¡ÒÊ+7û‘*ú¬[ G€¯Kã¸Å˜`%V3É,†Ìøø4Ë’×L¡ÅZÓã{ëýæýá4Ðy,ü©ÿÍ6~èû‚_óMŸº>åwý?óÿ ÿ×k}¯ŠúšjÇênÏkZ]K u>ÏkÝýš}¿õÕêÝ3!÷VîëêÃkx1º?& þjùR ÐÒÖ¿õS*üþ›ýR?0çÿ¡Ùÿ”<ßò®_©iùÑùS~Álÿ2|±rX•Pš­©©ÓûÌ1Öà—,‘ù†œ¾Ìv®/¯K˜É9~¦gcæ'SC.™©ÚjqS%¤ñΠ{˜Ù†dFb\ˆ>çS›O“ ¬‘”OôÞ¿ŒþÐÉ5+¥Ê·CŠ àâ«ñWb®Å]Š­,*—궥CõOP¶Ó`ß÷÷R¤)·_ŠBFRÜšmÃ&cÃŽ&G¸~æ{ùÑùM§?¥{ù›å{i+N«ZƒQ¿ûó1å­Áy#óã²ý­”\4™ˆÿ…Ëõ!­ÿ;ÿ(ï$Úþgy^âSJ"j¶¤îiþüÄk´ç–HüÃ,žÊö¾1rÒfþ/ÔÍì<Ťê±ô­NÓT„ušÎxî|Ú6a™œeô}Λ6Ÿ&Yc(é¼Áoã?´2MH„¹VèkŠ àâ«ñWb« S±ÅTšR?dýØ¢ÂϬ{¸â¶KZW Rª³\U¼UØ«±WÿÐûùŠ»v*ìUØ«Ç¿5ÿ=¿,ÿ&¬>µço0Çm}2Óü»kIõ+ª¾­ÔÔüîU?ÊÌ-ghaÒ‹É-ûºŸƒÓ{9ì‡iöþN&"b9ÌúqÇß/Ð.^OÌŸÌÏùø7æ7˜d¸²ü·Ñí<‰¥V=NéRÿSu"•ø‡¡zÐ#üÙÊ꽤Í=±ßÌþ§ß{þ¥zùË<ÿš.ÇË×/œ}ÏŒüÏù™ù‹çY^_6ùç\ósÈÅy}3Bù0†¯û£Ë«Í—ë™?Ôû?°;;³Åi´øñÿV"ÿÓ}GâX!Ž2ÅÊ)sÕˆŸ§1éÜñK¸¯ò»YhÇuE?01¤ñ~¨ê:<ñ]i…Ö•s å Å”Ò[ȇÅZ6R>Œ”'(‰#ÜѨÓâÔDÇ,c0y‰ ~ß[þSÎeþey&îÖÃηóùïÊ䄘Ýu+té΃C%?–RküÃ7ºßÍ„”ñÇý÷ÖùWµ_ð#ìÞÒ„²h¢4ùúW÷r=ÒðÿZ<»‹õWÊ™ú'šô7]Ñu¾ÒõHV{;•4䧳º²C¸;íðæŽX ÀØ/Ë£Ù¹û?Q=6¢&1š?ÁæQ»Õ4ýf+€´pk–¸É¢”8×"1U¬ÊŠYˆUQRNÀÜâ [âïÎ?ùÍÿÊßËinô_-üÅóM¹håµÓ%UÓíäg½£) õXƒžÇŽhõ½½ƒOé®^\¾©õOeÿàKÚ®\ÿàØOY\‡ôa±øÈÇÊßœÞÿœÐüøóÓÍ·™ÈúT¤ñÓ|»ÕÜ)Úvåç&HeÃ9Onê³r—îëæû—bÿÀ§°{4,^<Çñd<_ìCì>÷Ì:®¯«ë³Éu®j׺ÕÌ»Ëqq-ÌóiY‰ÍLç)›‘'ß»èm.4DpÂ0¤@ˆûKh»*(ù‘§#ˆ—C±@G­”ËKÕu] æ+ÍT¼Ñ®á<¡º°žKiø«DÊFJ” Ä|¶hÔépê¢ašœO1 $>Fß`~TÎiþcyBæ×NóåÄžzòß ’ÝÍÄj–éÓ”s ‚ÿ,‚§³ ßè} Íˆ—×öCõü_%ö§þýÚ–M|ÝþêG¸Çø/¾;æ—ê_”3ô?5éZ~¹¡êQj:^§–Òê3³)Ø‚:«)؃¸;ípæ†X ÀØ/Ì]£ÙºŽÏÔOO¨†H þ7˜#b7z¥†³ÀZ85Ë\ d‘L\Pø?þsûó6÷Ê–º”´MN}7Zó¶¨ií&hfK ;Œ²ÈCÒ´Kî+œï´z£‹„M°~ìŸðìk»K&§4¡‚ˆ±Ç=‡=¶ˆ‘ù?!?Æþuïç-xÿÛÎïþªçùŒŸÎ?2ý3ü‘¢ÿPÇþ’?©oø×Îõ8k¿÷ºÿª˜þc'ó̯òF‹ýCúHþ¤n›æ?>ë–Ÿ¤Xù·]{ÝVæ+KU×÷“8Eÿvxœ–<™²HDJVMs.>¯GÙÚL3Ï“1 q2>ˆòˆ³Ñû±å-zÓBд?/[ݽÄ:-½Š\Jåä“ÐP»³Ib 59éØ¡áÀG¸SðÆ¿RušŒ™Èä‘• €â7B»¹=OKÖÒçÅZåŽ3&æÂÅŠ»v*ÿÿÑûùŠ»v*ìUùÏÿ99ÿ9±kä¹µ þQÏoªù®Ðk>m!g³Ó_£En7Y§^äÕìy5@æ{W·F+LJyu=»¼¾áìü 'Ú:ÎÓNñÇÊY<åÖ0ÿe/!¹ù¬k:¿˜uKÝo^ÔîµcRͪ^ÊÓO3žîîI>àíœlç)ÈÊFÉê_¥´º\:\Qƈ¡ŠÜ[ov*ìUØ«±Wb®Å_XÎ4~cÞè3j¾Všå¾£!†Ÿ1¤rT$Ê£°j©ùüó«ökTnXO/¨~—À?àßØPáÁÚ0«ðçæ+ŠûªCÝ]ÏÒß%ùÝnÄ_½­iß:ë~v!ôf¨‹ˆÑƒV£$ÖQþcóNƒäýSó?™õH4m G®5Jᨑ¢ýä’vU’vœ¯.X≜Íåè;?>¿<4úx䙨Äs'ñÌòrüXÿœŒÿœÄóoæÝÅ÷–|›5×”.94FØŪ ÛÛ¡ªFÝ¡SJ}²Ý Ú}·“RL!é‡Ú}ÿ©ú·Øoøi;1Ôj€Íªç|áÊóþyÿ6ºø´P €¢}U¼PìUØ«±Wb®Å_OÿÎ6~f_y_X»ò¬÷Mú+UêÆ&m¢ºŽœøøz‰×Ü é½œÖä8O)n=ãõ‡Ä?àÓìä3èáÚP¼DFg¿¾’«/²G¹úyäÏ<­ÐˆkZwÎÍù˜‡Ñz6¨.cB¤Œ“Y~'Îk~`Ž=uÛ+yým+È°Eåû WÖ‹÷·Œ?糕ÿb3Ï{{Sãjˆ£·ëû_°àMØ¿ÉÝ…Žr<ää>ã´?Ø‹ÿ9òViŸKv*ôŸÊJÛÎZÄÀÑ®b¯ûøŽýÕ'èÍç³úSÄy@_Ç|·þ ½±ù.Å8"jZ‰š=Sû„Î}õåo=Ís,cÖ&´ïå¿'¾¸òF¯%ÒDKZa 2}¦1hÔŸ “ðt¡Ø«±WÿÒûùŠ»v*ü×ÿœÔÿœ¤ŸË {ù?ùw©|Ãu_:y†ÙÈ{eúœ½&‘M]†è¦ƒâ?/Û½¬qÞ GÕüG»ËÞû¿ü à{ajk£xýÔ)‘ürÌéÄ|†ÿ#¦Ã8ÇévñCj¬ì¨Š]ØÑT ’O`0€dhnK ™!Šs"1ˆ²I êO@Êlü³#({ù¾¯]żtgúOAøçG¤övsYçú‡Úø¿´_ðeÒé¤qvv?ã•Çù£ê—¿Ò=éä>XÓ䢭¼Ž™œÿ fâ=¤pOÅó¬ÿð]öƒ$®3ÇÜ ?M¯¹ò’ÄÏaÍ%«†ªÇ½Fbj½œÆcxI¸îêzÁÿƒF³QÑ„gŒåÃ8ùðò•uçœIÅ#Å*䉊H‡¨e4 üŽr‰‰ ìCôfÐÍäÆx£ #‘p~!nE±¬RÌ<‹w%—˜íg‰ŠŸNE$xý™ºö|ÿ…q|Çþ ÑÙùßL˜ëçú‹ôòÏÌ3–€=»ç|’dvyS[·¶Ó¤¾¿ºŽÒÊΞòîf QF¥ÝŽÀ*‚IÂd³° !ŠY&!e)É;<É~EÎQÎHjÞem'F¸šÏòÓËó‘ éÕ(o¥J©¿¹^ìÛúj~Âÿ”Ny÷kö¡ÖN£¶1ËÏÌþ‡ëÿøû ÙÝ/‰˜ j²Yþ`ÿS»øñ *fôwbª°A5Ì‚(#2ÈÝYðËpážipÀY.höž›³°úœƒ8ó'îIîË"ƒËl@77!XõŽ!ÊŸìŽÙÑiýš‘–uä7û_íoø6`Ç#œäø¦x÷D~d#Ç”„£÷ʱ`ü)™3ögzfoÌØé4ßðoÖ‰þûKŒÇú2”OÎ\Cìc:–—y¥N »‰qÊ)ÙqâsZÝM$ø'ð= í¾Í{O£öƒMù);”OÕ wKô±Kóè]Š¦þ_¼}?\Ò¯#b­Ôgð'‰üfv|ø58Ïô‡Û³Íûc¥®ÅÕã=qLüb8‡ÚôòßÍr³À ‡¨ïž–ˆddIù‡oäï"ù“Î7Ž >[Òç¿ß·$hLIþÍø¯Ó•ê3Œ¥ÿ·3±».}§®Ã¤‡<³÷w?eøGy«_ßjº„¦}CT¹–òþvêóNæIüÙ‰Ï.”Œ‰‘æw~òÁ‚1ÇFD(Šb"ØìUšù]ÚÝ MšáêÇØl?ŽwÏéü=?ç3°ý/Ë_ð`íÎv¸ÓDútñÿ>^©}œ#àú¯òå&šhkSR3~$“ô/òêÍÄ0A’<ŸJ鱕‰~Y&´ë;v*ÿÿÓûùŠ»|éÿ9;ùÛäå­öµhñÉæÍq›Mòu›Ñ»u%®OT·_Œøž+ûY¬í]xÒa2QØ{ûþqì²rö‹´£ŠWàÃÕÿGù£Îgañ=ÏÍííæ¥{y¨ê7Rßj„ò\ßÞÎÅåšiX¼’;Éf$“žq)Nä¿ibÅ 0Ž8ÄäØîC`fìTšÜ³m"Ål‘eeå{ ÜŸ÷X?²=üsºì~ËhŒ“³þÇËßÞü«ÿo2vÖyi4Ò­, mþVCøô˜?Î;òžèú4÷ο 5Íã儽ËË—’Ü&×Û 02zý‡åQ1ŠÛöðÃL ž)æ¯ùÆ íC_Õµ“­‹++é½X¬a¶äëð€Õvp7 —9ÍW³ã>yd3¡#tìý‡ÿ vOfaÑÇMâOxx¥:s[{ ¹¼óRüŽ³ÒA[»Æ_ÚvР~¼³³šhýFRø×Üâk?àÍÛYÿºŽ,CÊ&Gç"GØÅÈÂä%˜ ; ƹ²´¸ùcþ÷–Ö{{Ûº¿ï5y+º$@°“hÞMš9„E{  ͆8Çh€=Ï/¨ÕåÎx²ÎS=ò&Gí%õåï—® ’PŽ²ÀâH±ŸùÊÿÍ™ô]ÓòBº1ÝëPGwç)£?ZX- =R9¸þP££g/íhp's¼½ÝÅ÷Oø {"3ä=­ž>˜@õŸñOüߦ?Ò¾çç¦qïÑîÅU!…ç•!ŒUÜÐx~Yv Ï1s.¿µ»Seérjµ±ã{Ïpä€ïgz}¢[ ‚ÜU›ûÙ{¹þž= C Ç¤‡ yõ=Oìò~:ö«Ú½_´:£›9¨¢é€ý2?Å.gÝAèz–g½tø W3žX—·h_–²Ì¨L×Û 02c_œß•÷–¾O‡P±Óf»¾¶¿!ŠÞ&’B³rFTGLÑûA€äÓ‚‘!Uæú§ü;Z:>Ø”rLCLRââ FãR‰³¶Ûüß9Aù[çùK'–.ìb"¾¥àû«! øg/‹±õy9@~ß{îÚÿø${?£±-TfGH“ýÈáûT¦ò±jivñÆê¥\ýô68½šÊ~¹îßõ<^¿þ ºm¦ÓäÉç" ?ß°"tÿ'‘Åÿ^ÅüÏiäÖÈzpF‡õòXû"%ó~zçý>ìUµR̪:±}9vµz׫Üÿ°-hÿÕÈþ¦cþ^ÒÊ$¿ÓCþ)€Éçïɧ·øÂׯûâãþ©`þZÑÿª‘ýL¿äÙûGÿ(’ÿMø§µùCËZ'˜tË oF•ot½E=K+°Œ‚D WÒª{fÇX倜 ƒÉã»GCŸ³õÓê#Ã’¤,5ubÇW¯?Hò_—õ4jäC¥ùzÊkûçèLp!r£Ý©AîpåËP3—(‹aÙú½¡©Ç¦Â.y$"=ò5ös/Åÿ5ù—Ró—™5¿5jî_P׮仜v@çà|5G°Ï0ÏžYòK$¹ÈÛ÷_döfÌÒbÒa QuÌŸ9'̤K°v*È4x(¦j|rü)죯Þs°öwGØó–ÃÝ×æ~ççø2ûFsêaٸϣN~sôƒýXïï—“Öü«¡=äÑüªFtψûÈBˆKC^²@4ÊO¬¼¹ä(R(ëè;d©¤É™Íä¨DGŒt4¥@ÅoóoU’ï¿l3ŒŸ8k¿–Ló= ïá‚›’‹/ÊÇõô_ ž'²yWòí­š3èˆí„OÏÏùɯ2®¿ù±¬Ø[J$Óü¡z%§Uõ «\‘ÿ=‡ÑžÛºU 9GÓúþ×ëïøv7òwab”…O99Oº[Cý€âùÿ4Féñz—öA_§¶o=ŸÓøšŽ3Êþ<ƒåŸð]íÉv7åâ}Z‰ÿ™Tÿ@ø½»É:o­qãZ‘Ð~U“ôò«C ¶ä§†H8ó/·<·f"†=©@2M%F(¸Xªb®Å]Š¿ÿÕûùŠ¼[þróþXþNyïÍÐJ"Ô­4çµÑ h~½xE½¹<^@ß!˜=¥©ü¾žsë[{ÎÁê}Šì_åŽØÓ鈸™\¿©T¾`WÅüçUK1vbK»–'rIîIÏ2~äv*ìU•hÖĤKMä<ÓÓðÎÿ±tþš=òÜüy}ÈŸðNíŸåÜʸaýÜÍú¾s¿}'ù{åÿ¬M )Z‘Û6áó¹¾~mê+ùù/¯ÞBÂK_TÐôÃѹ^&aþ¬*ç5µ¨ð4²®rô?²Þãþ}Œ;S·p‰ †/ÞËüϧç3æ/M¼3ϲÅÅ]Š£tÝ>}_Q°Ò­Enu+ˆí¡öiX(?Ek–bÆrL@s&œ]v·‹O“Q“hc‰‘÷D[ö7É÷úV¥é%‡³Ò-!³µQ·Á žô®zŽ,c +äü¯ÖdÖê2j2}Y$d}ò6ò/ùÌ?ÌÑ¿–ZW”,fásç[ðo‚þ£aÆWÙ¥hÇÐsEí&§ƒÆ9ÌýƒöÓêÿðìQªíLšÉNž_%Ä|¢$üÂÎú‘Ø«j¥˜(êƃéÉBrɯ›N«S 6æÉ´a#÷=E²õ$Š5-g§áÄ1B0¢)ø[´ûC'hj²êr}Y$dÎ7_O­-|³ëI1÷²àëd_yË P“Ù Ñ"úOÓcŠ5FÃ$Ö™Éj…iAŠ±KEŽpÕPkí °[¯%Á3“èƒôcIâjßÈöèkè»^$ž®ôïËo!ù·Î×h«–t»‹ØÔíÎdB ýœ…WéÊ5YÆ RÈ„[µì.ËŸjëðé#Ï,Ä}ÂýGá/ç®êêæúêæúòS5åôÒ\]ÌÝ^YX»±ù±'<¶R26y—ï,x£Š€îPûp3v*É4[rÜM7‘«ô™Üû?§ðôügœÍü9åø/vÇç;cÀ‰¸éâ#þ|½Sÿz>¨?-ôs,ÐHÍè|¢Eú/ùm£¡€ð§L˜q¤_QipâQNÙ&²ž †(ov*ìUÿÖûùŠ¿7çã¾i’ÏÈÞAò|Rq`ÖfÔow‹N‡Šì^àšç1í>jÅw›ùkîŸð ìá“]¨ÕòxÄG¾g²5ñ~Cçý2ìU°9¿Ì@ûòxáÇ!òÍ£U¨|3ÊyB2—úPOèzo—-=YâTÏQŒD@¦ÏÁÙóË4å’F̉‘÷ÈÙ}¹ùW¡«5¹)ÜvɇEäŸó™^lŽo1yWȲCË6'QÕ¾·}A#Å!@Ùçí.§‹,qá}çö}ïÒðìC‡C›_!¾ipGú˜ùüæؾ.ä¿Ì>üæ_p¢ÝAÅ[ÅÅY¯]-|Åo©?ý+U¤Š¿ïÆTý'7¾ÏéüMGå°|«þ ¯ù>Æü¼O«Q!ó#êŸûÑñ}“å5Oq4CÔ$TwÎéùL‡‚ÎJy’msÏÖ¶ !h<»¥ÛÛ"Wa%Ån$?HuÎÚ,Üzžæ€>{¿TÿÀo³†›°üjß6IKá@û¤ùó4/¬;EY';˜Çòü_vm»‰«•Ÿ—í|ÿþ  t}ž¹äáÇþ˜ïþÄ´y;Oõîbªõ#=ù¾ýü«ÐV–燇lqæ_qycNX`á¥É4•oÌÌ ò£Èºÿž¼Æäiº¿¨-£ Ks;ÛÅÊ€¼®B§a”jµ0Ób9%È~)Ûvbgí­v=«!«éÎR>Q—‚ù þs_ò+ÏB {¯0KäZn éÞaêéÌöK¤/ßmÜáší7nésleÂ|ÿ_'²í¿øvïfÜ£ˆg€ëŒñŒ Oì/¥mõ;Q¶ŠöÂò û)Ç(/-¤Y¡u=ÖD,¤|Žn#!!`Ø|ç.)â‘„âc!ÌAðwWIà~„a`ŒDzS~}ÏÃ|ü4oËÿ,~^YOÂëΚ‰½ÔãS¹±ÓhÁXx<î‡ýŽs^Òêx1Gþ#gÜ?kíßðì_Ìv†]t†Ø#ÃëäýPù¿³‰~žv*Ú©vUX€>œ³3’b™5óquúØh´ù5>œq2>è‹zO—l½IâP*€}éØñŒq€¯“ð¶·W=^yçɼ²HÈûäl¾×ü«ÐêО²ÐàH¿A¼‘¦ˆ`‹áèL8ò/gµŠ(ðÂÁŠ»v*ìUÿ×ûøzUùÿ?!º•üýùifOîaÐ/'Uÿ*[¥RiòAœ_µ÷¸ÇôOÞý3ÿœ`h5SêrD|£û_œ™Ì>èìUtd ž?~]§ŽXÈò}0K>‡>(o)c˜óOnò\î"¨î3Ô„ª…è?åMŠq·4ðɉ¾µµòæ…u ¸»Ðôû»‡QÎâ{Xdv  «2pp;Á²ÝF1à “ˆˆ ^Uç+hž”¢MM8Z@?RdN4|ƒl{KUþ«?ôÒýoÉ/Ï«ËfóíÖe 0A¡D°L°¢ 3È’WˆQôg Ûùc-G@"¾'rýSÿ.Ïˇ±ÿ3šR”³ÈÈq}ôÇŸyâ?Šæõ7b¬¯ËêÉB62µOÈl3¹ì ?‡§â<æoáÈ?*ÿÁw¶?;Û'MÇOóª šú›òæÊIe‡cÛ7Áò™>qüÛ‘ßó/΋%k¤ð ÿ,J¨?žqÚÒ½^Oë?hÀûÇìþˆ¸øÈ’~÷žf½ìŠ¦:] ÚƒÝM? ß{; 5$wÄþ‡É¿àÍŠrìHÈ £š$üD€ûM|_Iþ^Z+Ü@HFwùfOѯÊûX­Í; ˜qäúºÊ{M;Ošööæ+;+8Zk»¹ÝcŠ(£ÝØ€ª T’p’³° qã–I@"h¹$òw¿¿ç.¿ç#çO™âòï–.\~[ùRwýÛ¨Ôï(÷̦‡€¬@þÉ-Õ¨8ÚíOÍφDyyžÿÔýuÿ?aÐþ”çÔð¬£Õþ×c¿¬üèt|w×c¸Í#ê »Ê~~ó·‘.Eד¼Õ©ùr@jÉepéÿ¯ LoþÉN_ƒU—¼r1÷:žÔì-jC‡W†Gô€${¥õ~ŸÎ2~{~fù÷MÕ/|úÚ|ÚM“¥¶“¬C¶ºº¸ËÉúEPPª>#NÇ;~ÄÖê5P2Ë\#`j‰=|Ÿ—àŸìÏcö£ ˜Ë!Å8qFþϪåÐvÔ>ÞÒ|ÉÒ­$©9¼|¬‡â¿üææüÀüòó'¡7«¤ù9˺] TýP³\°ùÜ; gžvæ§ÆÕJ¹GÒ>þ×ìøv/òg`â2<ß½—ùÕÃþÀGæù{5¢;Giñó¸ J„úOLÞû?§ñ5g”üNÃô¾SÿþØüŸd 4MKQ!ó#ê—ÛÂ>/mò]‡«qGR3¹~X/Ð/ʽ!UmÏ qæûoË$0F)ØdšK9ŽEo…Š§ª¾8«bAŠ¯U¼UÿÐûøzUù?ÿ?#Ðf—ågšU ·{}KIš@6­ÂiܧÈç!íF3xçï¥ú3þúØøzÍ7[„þÄþ±ù‹œ›ô ±Wb—¡ù7ÍÖºDñ&¦®!B8ÜƼ¨?Ê^¿HΧ³{xc€Çšöå!¿Ïõ¾ í¯ü rj³ÏWÙ†72L±Hðú3 rÜïÂk~G£î¿ËÎÏË=6(^ÿÎ66A.³ U…=¸W7±í!âµò|ßð9ö†áüœÏ»„˜/hÕ?ç3ÿ$<»dâ×Y¾óEâ¯îí4«9b?âÛEúrœÞÐi1¤d|‡ë§gÙÿð"öƒU!âbŽ÷ÎCýÌx‹ãÌÿùÍ;yÃ×±òf‘oä}2J¨½fš‹/üdeGþÅ ÿ+4:¿hódÛàüÏê}cÙÿø önˆ‰ë¦uÃôcùÅ/‰ÉñÍÝÝÕýÕÅõõÌ·—·r4×Ws1y$‘ÍYš¤’{œçå#"I6Kì0cÁŽ8ñÄF€Cä[W"—eEêÄôå˜q³ÉÃí t4:lšŒŸN8™óEý¯Jòõ©4J€g§cÆ1ÄDr¾OÂúÝ^M^yçÈny$d}ò6_iþWhœŒ§†ZÈÿóšºæÿœ-åB‹¨M¥nH hîáG¨ù7%ùŒóÎÚÆa«Ÿ™¿˜~Çÿ–¶:¯gt¤L¾#î£ñxÆjÞíتø¤xdIc4t5S–áÍ,3¢ÓìÜ¥¦ž›Q,yúGqpz´ù'ó+HÑdˆê¶×p§'DŠ~Š‚3®Áí&"?y–ãõ¿ççà37A¢ž¯(„yu=ÃñÉ潫öŸOìþŠZœ»Èíuœúpç#ÐyÓî?"yš&ÓOÒtÕú½…‚,Vð¯`7$ø’w'¹ÏFÊ8`!@?vž¿?hêrjuâÉÙ? y@t¥¥üÊÿù'Ì~l¸“þ8zt×0)?jp¼`Aþ´Œ£#ªÔ eÿûz}­½ÙínÐÁ£ùY€|£ÎGá/Çk‹‰îî..î¥3]]ÊóÜÌz¼’1wcó$œòòI6y—îÜxãŽ"€î`¥“±TD2ÛšÇÇsSQ\ØhûK.Ž·ï#í'±=ŸíHdÕñ“DDeÂ76v®g½•i~{×´vW³6Õ^ž¤\¿Žf¢Wô~O4à;Ø=ÙÓþÇ«hßó”?šzU°“H)ORÄ7Oöcú"ÕGäÄÿÀo°L¿éÿc9·ÿœäü÷¶P±\è•Óÿ™˜ÿ¢=_ô~LäÌû?Ý—ý?ìEùÏÏáÿ>^ÿ¸Xÿª¸Ñ¯ú?%ÿ“1ìÿv_ôÿ±õüâÏüä?æ·æ֩櫯<\écËš ´0Û-•·y/®ù¶É1"Ÿ´<3yØ¡¨ÖJG%pǸu/–Á?ØþÈöwiü\¤“Å. !ÝCœˆùÜvzüS€×:Ç©”Û],€k…ŠaËá®*ÿÿÑûøzUó/üåGå\ß›Ÿ”ºÞ§D$ó”é¬y`W–¡«'§­LòFŸcîõi_RÔ hKMEŒõcUÏBìM?ƒ¥|½GãËì~=ÿ‚‡l)öîj7 ?ºùŸWÎfO²|£ç¼hÿyZÓ¾mß:!ô¶zÓÆ„šÔak,Þ§ÒÂÅÿÒûùŠ¥wñs¶Þ˜«ócþrgþqbÇΚ÷|”Ðè¾m¹&MZÆJ­ž¢àxHþêSMØ 7í üYÎö¯aI91m>½ÒýEöO`৓±¡¸šq´HúñyJÑç›lüÄó'“üÑå¹,¼É¡Ýé3FJó™+PÒ©*Õcœv£I—¬‘#îùò~‘ìh;?µ '¤Í ƒ¸P÷ÄÔ‡Ä1ªƒÓ1ÝÍ7ŠŠµŠim¦_Ý‘èZÈÀþÛ+÷µ33gê3ý>þCæ^kµ}°ìŽÌó˜?„9¥–Keå2h×Ó×þ)‡ø±þ7Ú_fúæ—À~·É»wþ cxvnóò~ˆ÷Òø3 - "ˆ­-„(z•Ÿ™;œé4ú\ZqXâã½ñnØíýwkäñ5™eôéõb=1øs¢ù.{™˜‰©³!Ó’úcÈž@txI„õ²@5JOµ<•å¡kUJPÙ&’^™ªèVzŽ•y¦ßÚE{a}ÛÞÙÌ¡ã–)«£©Ø‚  DHE‚Ëiáɘäc(AÁˆóÇÏùĽÉÚî¯ùw šÿ•åf‘tNU¾²Ô¢†?¿AØŽ›zçÚ>ÏäÆL°z£ÝÔ~¿½úwØßø/i5˜ãƒµØmÇþN~gù’ï¿OqŸ]ZÜÙNö׶ÒÙÜÆi%¼èѺŸu`ÎvQ05!GÍö\ñê 'ŠBq<ŒHù…‹k±V±M+Eó·byOù"¿Ž]‡O“1¨DËÜohö¾³¡ÇªÍ CúDæ~‘YyvG!ïŠÿ¾Sv?6è>Œèt~ÎÊ^¬æ‡pçñ/ŽûKÿ\8ÅÙpã—ú¤ÅDyÆåþwò,âÃGw úq/DQV0à ð>Ñí-Ohg–}NC“$¹“÷à:°zß•¼“5ı“;ŽÙh¾R}wä/ ôI‡}»d€i”ŸŸßó’h‹ÌŸ›~c†Öa&›å†] O¡ªÿ¡ÔNÃç3>yçmj|mT«”}#áÏí·ìoøö)ìÎÁÂ$*yo,¿Ïú~PxUGˆÍSèêVQŠÑuF+EÕ­Tb´]QŠÑDZÀnn`€oê¸åßðÌ&Ÿ,qŽ§û~ÇOíjDz»?>®_äàHó—(Œˆ¤|µ{rÒC’h¨£°žš‡'ᬓ”äg#r$’|Ï7Ú_–K<† ÔôɇO¸<«b¯†I ½Ÿ¹ÂÅÿÓûùŠ¨ÊœÅX>½¤­ÔN Ö£ _/yïÈI}èöâTjòF©¯±Û"EŠ-ØòKŠ$‚:ÍñÏšÿ%ô––G²±'tˆ'üF™…“³´Óú±ÇäôúOl»kJ+¯(×'ýÕ¼‚ÿò’Ò'<4þ#Àþ¹Aìm!ÿ&>ßÖí£ÿŸh@ÿ—ÄGõ$ÇòÖ(ÎÖ ·ˆ'õä£Ù:AþL4eÿ‚oäu™>¸# ò#ÄG§h¨Gu@ecÓbÇôÄp‹WÛšífÙóä˜î”äGÊé;·òMÛ‘XÉú2çYa•éß—w•¬$ýiOQп+¤bœ ?v4ÄÉîž[ü°Xý2`ð톘=÷˾IŠØF}*R²Md½LÒÒÝ¥0°%8–Ü¥;b‡˜y§@[¸ä+Pp3ñÿæåž©êýoM†ó¯Z%’Ÿ.@Ó*ɆLïçè»GQ£—Ÿ$ñŸèÈÇî!òw˜?%ô¸äţũû¯ê9ƒ>ÉÒKž0õZø öþQÖd#̉}à¼öçò®Þ&~òÝœ‰0M¶ZƒN0F?RäN8÷“duy¿Ÿ/ôÇõ¾8óW‘ÌÓIÆÍIèŠ?†=ÃäÜ5™¿Ÿ/ôÇõ¼ÊoË™Yú0ÿ<8÷“/Îfþ|¿ÓÖ£ÿ*Þ_ùfÿ…Ó=ÃäŸÎfþ|¾gõ¶?.%ÿ–aÿ‡áòGç3>_éëoþUÌßòÌ?à1ðãÜ>KùÜßÏ—úcúÝÿ*æoùgð8øqî ùÜßÏ—Ìþµh.¦ ·¡ÂÓøa e©É1R‘#Ì—¤ù_È$Ñ ê;d© ÉöWåï•šØBLtéÛ$d_Vh–žŒ()J “QeTø)ŠÿÔûùŠ»BOpE:â¬;TÐc¹Vª\ yf±ä(n D£d$ómCò¾'b~®>ìˉIùR„ÿ¼ÃîÁIâZŸ•(ûÍøa¥âN-?+bVÜ}ØÒ8™–ùk q>€F4Ž&¦ùxþè£ g–>^†´@)Š-’Ád‘€Ó Œ.(\TŠ¥—vk*EkŠ^¬yb ÕŒû`H/(Ö?.aœ¹_lÌI€Þ~VÆI¥¸û±¦\I9ü©Jÿ¼ß† O.ßòª0¶ÃîÃHâeúwåŒHTý\mí#‰èúO‘`ƒî@§¶bdô;@†´Œ bÆÙD6« ab¡ymͦ)yž»åÅ»ä8V¾Øò½Còê9‰€}°S.$”þWÄM~®>ìi‡býC~ÓÚ‰òæœ{?áý1[pòÞœ;?áý1[T]Ázü?¦+h”Ò­SìƒøLVÑ+i t¡XF£ ÅWôÅ]Š»h€zâª/oõªô»Y>Ð?‡ôÅm Þ_°n¡·ùLSjá½;Áÿá¦+k—˺zôøLVÑ £YÇöC~Ó´ZY@ůLU~*µ‘[®*…{dûUÅPçH´n þÓÚßÐÖ~ øLVÝúËù[ðþ˜­»ô5—ò·áý1[wèk/åoÃúb¶ïÐÖ_Ê߇ôÅm¿ÐÖÊ߇ôÅmzév«ÐÃúb‹E%´IökŠ«€LU¼UÿÖûùŠ»v*ìUØ«±Wb®Å]Š»v*ìUØ«±Wb®Å]Š»v*ìUØ«±Wb®Å]Š»v*ìUØ«±Wb®Å]Š»v*ìUØ«±WÿÙgcl27-2.7.0/gcl2.jpg000066400000000000000000000131511454061450500137740ustar00rootroot00000000000000ÿØÿàJFIFÿÛC    $.' ",#(7),01444'9=82<.342ÿÛC  2!!22222222222222222222222222222222222222222222222222ÿÀ|,"ÿÄ ÿĵ}!1AQa"q2‘¡#B±ÁRÑð$3br‚ %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyzƒ„…†‡ˆ‰Š’“”•–—˜™š¢£¤¥¦§¨©ª²³´µ¶·¸¹ºÂÃÄÅÆÇÈÉÊÒÓÔÕÖ×ØÙÚáâãäåæçèéêñòóôõö÷øùúÿÄ ÿĵw!1AQaq"2B‘¡±Á #3RðbrÑ $4á%ñ&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz‚ƒ„…†‡ˆ‰Š’“”•–—˜™š¢£¤¥¦§¨©ª²³´µ¶·¸¹ºÂÃÄÅÆÇÈÉÊÒÓÔÕÖ×ØÙÚâãäåæçèéêòóôõö÷øùúÿÚ ?÷ú(¢€ (¢€ (¬]sÄúO‡¡ßrB2§Í#ýõ½ÊŸzÿ‚}>%´àà׆h?5]6DŽþF½µèwÿ¬Qêƽ[OÖ­ï­¢¸‚PñH»•‡zë¥Z56< vY_ÿyª{5±¾ -SŠà?z´­šÔóÇQE! ž”´f¸ŸüIÑôvx- ¿º^ Äß"Ÿvþƒ5çZ¯Ä_jd„ºqà¶OýõÖ¹êbiÃMÏ_ ’bñ+šÜ«»ÿ-Ïvšx ]ÒÊ‘¯«°õªx‹EˆâMZÉO¡ƾpžâ{§/q4“1êdrÄþuès¼ké؇ ÆÞýO¹Á>Oè²6ÔÕ¬˜ú ×üjôWpλ¡–9Õ0ý+æJ’ æµ=¼ÒBã£FÅHü¨X×Õ|/{•>õÿúxJ=iÁÁ¯о#jš|‹¢ÆöÛ¡fÿX£Ø÷ükÔì5«{ëxî-åY"eXw®ºU£Qh|þ;-¯‚—ïf¶7Á¥ª‘\ïVU³ZžxêL×ñSZ“OÐmì­åhç»—$£`„^OO}µä?ÚWÿóýuÿ›ük–®)S—-w‘OEVçåOÈúl·µ&úù—ûJÿþ®¿ïó>ÍFâxàŽö輌|ÝIÇ­gõÕü§cá‰%wU}ßðO¥÷ŠPÙ®vÂé-là¶W,"PrN2kV ýë¹.Õž…ú)ŠÙ§Ð ¢Š(¢Š(¢ŠóOˆÞ6k ú&™..bæd<Æðƒê{úTT¨©Ç™X<%L]UJŸü2îIã?ˆé¦´šnŠÉ-Øùd¸ûËô­ú òK‹‰îîâæWši^I%¹¨©kÈ«VUÙú/£ƒ‡-5¯WÕÿ]‚Š$€MZŽÈ‘™o°ëJå7h£\N2Ž<Õ¥oÏî*ÑZ+eà)?SJúYeÌyÐ÷­ž¢W<Øgø9K•Ýyµ¡›EbÁQ\Ǵº¿ëZ´¶lçË?¼@OCÐÿJäêæ™!ŽùXƵ¡&ª+~mJ50Uº+ýÚžÙ§jBLs]¼ÛÔטè×m•æ»»•H ’8TUÜÌÇÜ×°~pÑ«y}m§ÙËww2ÃK¹ÝW‹x»â î¼òZX³Úé¹ÆÃÊ=XößVñ·Œ%ñ-ù†dÓ!oÝ'O0ÿ}¿ í\­y¸ŒK“åŽÇÚå,hEV®¯>‹·üÈJZ)UYÛ 2}«‘+ŸE)(«· ”U•³?Æüú “ì¾ë6}ëu†ªÕìyRÎð1—/?àÊTT“@ð>×zZŽ±i§fztêF¤Tàî˜WOàífK+§³g>TŸ2‚z0ëùŠæ*[I Wq8<‡t¤ã4Î\„ká§Ûñ[ã§jañÍtvóïQÍyn|I^k²:²éúEÍóž ˆ¾róÅ{7²»?5Pr’Œwg™üGÕ´ü_èRÅÏ©}ÏüŽ6ûÁRKy4ÿhØŽÙ©Èük:o ¤äsîq]ôÞ.ðÂ¥ýðßáY7:ÿ‡¥'múø…cÉB÷Óï=¬fܪ I%¦‘kô8Ã¥<%Z·Ó˜0ÂÖÉÕt"Ùûrß-þ·§ÙÛÝÛÇqŒ«c¬6Ž BÅ%Í]KçÔ§¤Ú2°âªøë^kk4Ñmß*‡¸#²ö_Ç©ü=k­ò Ó¬¦»Ÿˆ Bì}€¯¾¼—Q¾žòs™&rçÛÐ~Ž.§,yWSÔÈ0J½wZkHþð?È‚Š(¯0ûUK0QÔÕè£6¯^çÖ«Û¯»ž•¯cjdaÅz8ZJ1ç{³âóÜÂUj¼<»üßüÖ¶M!V完X–µ4­/v2µÖYéj|µÙcç<×ÄZ#¦˜%Ž&i@UÉçŠçDÔ˜dÚHƒÕþ_ç^ôÚjíàV=þ”–¹êa£9s6{<궇±„S×vxãiS§ß niÑiÿ8''»Û­–?-C†w}ÚqÃSB+g8ʪÎv^ZÁ(é18eâ¬ø×P6ú6 ~k—ËöWŸçŠÞ±Ò òןxÎóí^#š49ŽØW£ï~¤ÒÅO–Ÿ©yÛc{G_òüL (¢¼£ïÀ +JÒ<°B%Ëý+oM‡sŽ+ÐÁÂÑrî|wâ9ªÆŠû*ïÕÿÀüΧC¶ÉSŠô-2¨8®[C¶À^+¶³j íGÌ2ê } éKL¢Š(¬Oj¿Ø¾¿½S‰V2±ÿ¾ÜÔÖÝy·Åëã‘abú錌=”‹~••irÁ³·. «â¡MìÞ¾‹Vy=Î}ÏzZ(¯ý4*Õºp­UëÅiÙǹÅv`ãvä|×Wq¥ K«¿Ýÿni6›Øq[úôÃJð­Ã©Ä³bÿuý3QèvÀ•â²>!߆¾µÓPü¶éæ8ÿiº~ƒõ®ºóä¦ÙóùVëÈG¢Õü¿«]-&G­ä¢‹EPቮ'ŽûÒ0Qø×±éòÃoo ¼xÙ_ ¯&ÒˆKå”ÿË1‘õ®ÊÂù‡5èàáh¹w>3‰1õ£E}•›ÿùšuo'@ŠÊ6Ã]Éócû‹Éýq^a]ŒoçYXÉù`‰TsÉþb¹úåÄËš£=ì–‚£‚‡w¯ßÿÁ@8¢Ì‚²„y¤‘߈«ìiJ§dÙzÚ<°ºÝËs/Ïiñnq]þ‡j>^+ÚJÇæ3“m·»:.È*Ž+¡Šª8ªÖP…AÅÆ­m¡i…ÑýÜ+£«€ri¶’»"1”ä£vËÅ*¬ÖÁ³ÅsºWÄjaUîZÎSü#hϳtýk¦Kˆ¥ŒIŠèz2œƒøÒŒã/…šVÃV íV-z™¯§+»BiŠ?†µ)§ŒUÜÄÔä‹GÑîïÜ [ÄÎ=Î8ž+ç§w–F‘Î]سÜžMzÿÅWìú5®™a®¤Þàqúä~Uãõæc'yòö>߆ðܘwUï'ø/ø7 (  +úÒWe‹dÎ=ë¨Ñí÷2ñX6‘åÀ®ÛC¶åx¯jœyb¢~g‹®ëÖ•WÕÿÃvoµWŠê`\(¬6¨8­¤¡ÆÇÑE(¢Š+Çþ09:ΘŸÂ-Ù¿6ÿëW°W“üaµo?J¼å+$DûðGõ®|RýÓ=Œ…¥…üÿ&yQ^Iú¼+sN\¸¬:ÐÓ¯ÒÝÀ”£ø€®¼-XÁµ.§ÏgØ ¸ˆÆ¥%wèzn…Â×\–vÞ&cÔ²Oé^£ø“I…A’ú$Ç]Ù­©þ"ø~Ò#²yn_²Ãçñ8ÜêÓKV“ŽåhÓ•ý¡©ØÛí;m¡HÇøW’x¦D:ÃAª¬#iÚ1ÉäÿJÙÖ¾#_꣰,¢?ÄNùãÐ~UÆÉ#Ë#I#³»³1É'Þ¸±ã5Ëê2lª¾§¶¯ÛEé E’®=ϤmE]–­‰®«HŒ³ ç­"Ë]¦‰m’¼WµN<‘Q?2Å×uëJ«êÿáŽ#^$ë× ö¯åÅgÖÏ‹-¯‰¯Œoa ÷ ÿƯ"§ÆýOÑpM<56¿•~ARAþ²£¡IVuS—,”ƒAס:KvŽ§IŒZôm kÊ´Ýf fr8Çu®²Ûâ›cÉÄÎ:ÌŸé^¢ÄSµî|²œj—/³§ß±ê‘ºCI#ª"Œ³1Àu5â¾>ñü$z€µ´sý›lÇgý5oïý=?úõSÄ~7ÔüCÙØ‹k/ùáûßïÿʹªãÄby×,v>'É^^Ú¿ÅÑvÿ‚%\°Õu .Mö7“[ŸHÜ€~£¡ª•-¼â`€àz åŠmÚ;žõiS7*¶å[Üõ_øŸVÕ –MHÄaB9v³·~:WqàqÖ¼«K½X#Ž†ØÐ`]3k?`ÒnoXÿ©Œ°÷=‡çŠöaxCÞgæ؇F!º1²oD¿„øƒ«jøºçkf+P-Óþ÷¿ñâk—¥wiÎY‰f>¤óI^<äå'&~‘‡¢¨R(ì•‚ŸËçÒ™J®S¦)ÒqŒÓ–ÆXêujáåN—Äôÿ?ÀÝÓ¢Üâ½C·/åj—6äÙø­jÛøÛXµÀŒÛñëz[¦|‹áìg—ßÿ÷[5 ‚¯1^ŸÍ €¾\{Ir}sèç]ÌwAZÞS2<œVxj®”íuØ¿EDŽ J*Îp®cÇkþžÚ%ÍÌdM»߈Ȯž¢•r¦¦QRM3Z5eF¤jCtî|¼ÊUŠ°*Àà‚9Šõø=Fy/ì ÃvÜȇîJ}}y…æŸwa!ŽêÞHˆîÃô=+È«FTÞ»¢às*ȧiu]à•è¤¥¬@(¢’€ŠzC$ŸuãVc°ï#~ ZBŒç²8qŽ¿y5~ËVS±ÀŸj±»ºúV„vØDÀ«öÚs;+¶–EÞZ³æ1ùõJñtè®X½<ÿàéÖ¥œq]þ‹i€¼VN—¥Wå®ÛM³Ø£Šì>u³ˆø“¡<–vú¼)“ò§Ç÷Iá¿Çã^i_JOj“[¼R"¼n¥YXdzƒ^=âoÜé÷>˜¦{SÏ•Ÿ=¿Ú­pb¨6ùâ}fEšÓ5†¬ímŸOCŒ¢•Ñãr’##¡†¤®꓾¨(¢’‹E*«1‚~•b;Bysø ¸RœþrbqØ|2½Y[˯ÜAM+aGÏ¥iAÀÔúÓâ·' «è+^ÇMgaÅzTh*zõ>/2ͪc*Ò §ù’i–î̼T¾1¹6ÚEµ?4ｇû+ÿ×#ò®›KÒ±–¼ûÆ¢óÄ—*˜íÿpŸð¿®ib§ËNÝÊÈ°þÛ¤öŽ¿åþ#ŠJ?òϽŠJ(h¤¢€’Šr.ù}M ]Ù9(EÊ[#½ðµÊéÚLqƒ‡™ñéúb»+ @ÈG5æ–r9e§jítPÇm{p,TQù†&«­VUe»w;ËY («Ã¥fØ©Ú+MGg0´Œ3KEPº€:ž+–Õ4±*°+‘èkµeÍSžÔ8Z«ÜãmtBq•­Û= |µÒæ*㊿¢¯j,+™všhLq[Àt©V0;T€b™#8¬»ëQ"ž+c‘†皶Š“ç|Jÿï.k’»ðä!Ž Qô¯`¸²WÏ“q¤+gå©p‹ÝÓÄU§ðI¯GcÉ_CUÏ¡©h ¾Ï¡£ìéRÑ@ˆS‚ÒEQEÿÙgcl27-2.7.0/git.tag000066400000000000000000000000251454061450500137170ustar00rootroot00000000000000"Version_2_7_0pre2" gcl27-2.7.0/gmp.patch000066400000000000000000000012451454061450500142500ustar00rootroot00000000000000diff -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 gcl27-2.7.0/gmp4/000077500000000000000000000000001454061450500133115ustar00rootroot00000000000000gcl27-2.7.0/gmp4/.gdbinit000066400000000000000000000022611454061450500147330ustar00rootroot00000000000000# 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 gcl27-2.7.0/gmp4/.pc/000077500000000000000000000000001454061450500137715ustar00rootroot00000000000000gcl27-2.7.0/gmp4/.pc/.quilt_patches000066400000000000000000000000171454061450500166350ustar00rootroot00000000000000debian/patches gcl27-2.7.0/gmp4/.pc/.quilt_series000066400000000000000000000000071454061450500164770ustar00rootroot00000000000000series gcl27-2.7.0/gmp4/.pc/.version000066400000000000000000000000021454061450500154470ustar00rootroot000000000000002 gcl27-2.7.0/gmp4/.pc/4a6d258b467f.patch/000077500000000000000000000000001454061450500166355ustar00rootroot00000000000000gcl27-2.7.0/gmp4/.pc/4a6d258b467f.patch/mpn/000077500000000000000000000000001454061450500174275ustar00rootroot00000000000000gcl27-2.7.0/gmp4/.pc/4a6d258b467f.patch/mpn/powerpc64/000077500000000000000000000000001454061450500212605ustar00rootroot00000000000000gcl27-2.7.0/gmp4/.pc/4a6d258b467f.patch/mpn/powerpc64/mode64/000077500000000000000000000000001454061450500223565ustar00rootroot00000000000000gcl27-2.7.0/gmp4/.pc/4a6d258b467f.patch/mpn/powerpc64/mode64/gcd_1.asm000066400000000000000000000052461454061450500240440ustar00rootroot00000000000000dnl 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() gcl27-2.7.0/gmp4/.pc/applied-patches000066400000000000000000000000511454061450500167530ustar00rootroot00000000000000arm-asm-nothumb.patch 4a6d258b467f.patch gcl27-2.7.0/gmp4/.pc/arm-asm-nothumb.patch/000077500000000000000000000000001454061450500200765ustar00rootroot00000000000000gcl27-2.7.0/gmp4/.pc/arm-asm-nothumb.patch/mpn/000077500000000000000000000000001454061450500206705ustar00rootroot00000000000000gcl27-2.7.0/gmp4/.pc/arm-asm-nothumb.patch/mpn/generic/000077500000000000000000000000001454061450500223045ustar00rootroot00000000000000gcl27-2.7.0/gmp4/.pc/arm-asm-nothumb.patch/mpn/generic/div_qr_1n_pi1.c000066400000000000000000000170011454061450500251020ustar00rootroot00000000000000/* 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 gcl27-2.7.0/gmp4/AUTHORS000066400000000000000000000071451454061450500143700ustar00rootroot00000000000000Authors 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. gcl27-2.7.0/gmp4/COPYING000066400000000000000000001045131454061450500143500ustar00rootroot00000000000000 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 . gcl27-2.7.0/gmp4/COPYING.LESSERv3000066400000000000000000000167271454061450500156260ustar00rootroot00000000000000 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. gcl27-2.7.0/gmp4/COPYINGv2000066400000000000000000000432541454061450500146240ustar00rootroot00000000000000 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. gcl27-2.7.0/gmp4/COPYINGv3000066400000000000000000001045161454061450500146240ustar00rootroot00000000000000 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 . gcl27-2.7.0/gmp4/ChangeLog000066400000000000000000041312671454061450500151010ustar00rootroot000000000000002014-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.) gcl27-2.7.0/gmp4/INSTALL000066400000000000000000000366101454061450500143500ustar00rootroot00000000000000Installation 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. gcl27-2.7.0/gmp4/INSTALL.autoconf000066400000000000000000000220041454061450500161550ustar00rootroot00000000000000Copyright (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. gcl27-2.7.0/gmp4/Makefile.am000066400000000000000000000464631454061450500153620ustar00rootroot00000000000000## 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 gcl27-2.7.0/gmp4/Makefile.in000066400000000000000000001537011454061450500153650ustar00rootroot00000000000000# 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: gcl27-2.7.0/gmp4/NEWS000066400000000000000000001012261454061450500140120ustar00rootroot00000000000000Copyright 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. gcl27-2.7.0/gmp4/README000066400000000000000000000102231454061450500141670ustar00rootroot00000000000000Copyright 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: gcl27-2.7.0/gmp4/acinclude.m4000066400000000000000000003616371454061450500155220ustar00rootroot00000000000000dnl 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=0,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 <