Menu
▾
▴
clisp-cvs digest, Vol 1 #861 - 10 msgs
|
From: <cli...@li...> - 2004-12-14 13:03:01
|
Send clisp-cvs mailing list submissions to cli...@li... To subscribe or unsubscribe via the World Wide Web, visit https://lists.sourceforge.net/lists/listinfo/clisp-cvs or, via email, send a message with subject or body 'help' to cli...@li... You can reach the person managing the list at cli...@li... When replying, please edit your Subject line so it is more specific than "Re: Contents of clisp-cvs digest..." CLISP CVS commits for today Today's Topics: 1. clisp/src places.lisp,1.52,1.53 ChangeLog,1.3945,1.3946 (Bruno Haible) 2. clisp/src constsym.d,1.284,1.285 (Bruno Haible) 3. clisp/src ChangeLog,1.3946,1.3947 (Bruno Haible) 4. clisp/utils clispload.lsp,1.35,1.36 (Bruno Haible) 5. clisp/src ChangeLog,1.3947,1.3948 (Bruno Haible) 6. clisp configure,1.76,1.77 (Bruno Haible) 7. clisp/src lispbibl.d,1.590,1.591 package.d,1.87,1.88 ChangeLog,1.3948,1.3949 (Bruno Haible) 8. clisp/tests characters.tst,1.10,1.11 ChangeLog,1.285,1.286 (Bruno Haible) 9. clisp/src/po Makefile.devel,1.35,1.36 (Bruno Haible) 10. clisp/src case-sensitive.lisp,NONE,1.1 package.d,1.88,1.89 constsym.d,1.285,1.286 spvw.d,1.332,1.333 subr.d,1.194,1.195 init.lisp,1.202,1.203 symbol.d,1.31,1.32 charstrg.d,1.110,1.111 io.d,1.262,1.263 lispbibl.d,1.591,1.592 constpack.d,1.13,1.14 subrkw.d,1.50,1.51 defpackage.lisp,1.7,1.8 runprog.lisp,1.12,1.13 complete.lisp,1.12,1.13 defs1.lisp,1.45,1.46 makemake.in,1.491,1.492 encoding.d,1.117,1.118 ChangeLog,1.3949,1.3950 (Bruno Haible) --__--__-- Message: 1 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src places.lisp,1.52,1.53 ChangeLog,1.3945,1.3946 Date: Tue, 14 Dec 2004 12:02:12 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15280/src Modified Files: places.lisp ChangeLog Log Message: Fix REMF to respect ANSI CL 5.1.3. Index: places.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/places.lisp,v retrieving revision 1.52 retrieving revision 1.53 diff -u -d -r1.52 -r1.53 --- places.lisp 21 Nov 2004 23:24:44 -0000 1.52 +++ places.lisp 14 Dec 2004 12:02:07 -0000 1.53 @@ -480,15 +480,17 @@ (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method place env) (let* ((indicatorvar (gensym)) (bindlist - `(,@(mapcar #'list SM1 SM2) - (,(first SM3) ,SM5) - (,indicatorvar ,indicator))) + ;; The order of the bindings is a not strictly left-to-right here, + ;; but that's how ANSI CL 5.1.3 specifies it. + `(,@(mapcar #'list SM1 SM2) + (,indicatorvar ,indicator) + (,(first SM3) ,SM5))) (new-plist (gensym)) (removed-p (gensym))) `(LET* ,bindlist - (multiple-value-bind (,new-plist ,removed-p) - (sys::%remf ,(first SM3) ,indicatorvar) - (when (and ,removed-p (atom ,new-plist)) + (MULTIPLE-VALUE-BIND (,new-plist ,removed-p) + (SYSTEM::%REMF ,(first SM3) ,indicatorvar) + (WHEN (AND ,removed-p (ATOM ,new-plist)) ,(if (simple-assignment-p SM4 SM3) (subst new-plist (first SM3) SM4) `(PROGN (SETQ ,(first SM3) ,new-plist) ,SM4))) Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3945 retrieving revision 1.3946 diff -u -d -r1.3945 -r1.3946 --- ChangeLog 14 Dec 2004 12:01:01 -0000 1.3945 +++ ChangeLog 14 Dec 2004 12:02:07 -0000 1.3946 @@ -1,5 +1,9 @@ 2004-12-13 Bruno Haible <br...@cl...> + * places.lisp (remf): Reorder bindings according to ANSI CL 5.1.3. + +2004-12-13 Bruno Haible <br...@cl...> + * format.lisp (format-iteration): In the cases without colon, a *FORMAT-UP-AND-OUT* = :TERMINATE terminates the entire construct. --__--__-- Message: 2 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src constsym.d,1.284,1.285 Date: Tue, 14 Dec 2004 12:02:43 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15617/src Modified Files: constsym.d Log Message: SYS::%REMF is part of the ABI, used in the REMF expansion. Index: constsym.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/constsym.d,v retrieving revision 1.284 retrieving revision 1.285 diff -u -d -r1.284 -r1.285 --- constsym.d 13 Dec 2004 12:11:39 -0000 1.284 +++ constsym.d 14 Dec 2004 12:02:41 -0000 1.285 @@ -1008,7 +1008,7 @@ LISPSYM(get,"GET",lisp) LISPSYM(getf,"GETF",lisp) LISPSYM(putf,"%PUTF",system) /* ABI */ -LISPSYM(remf,"%REMF",system) +LISPSYM(remf,"%REMF",system) /* ABI */ LISPSYM(get_properties,"GET-PROPERTIES",lisp) LISPSYM(putplist,"%PUTPLIST",system) /* ABI */ LISPSYM(put,"%PUT",system) /* ABI */ --__--__-- Message: 3 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src ChangeLog,1.3946,1.3947 Date: Tue, 14 Dec 2004 12:04:06 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15853/src Modified Files: ChangeLog Log Message: Update. Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3946 retrieving revision 1.3947 diff -u -d -r1.3946 -r1.3947 --- ChangeLog 14 Dec 2004 12:02:07 -0000 1.3946 +++ ChangeLog 14 Dec 2004 12:04:02 -0000 1.3947 @@ -1,5 +1,10 @@ 2004-12-13 Bruno Haible <br...@cl...> + * utils/clispload.lsp: Call disable-note. + (*expected-failures*): Update. + +2004-12-13 Bruno Haible <br...@cl...> + * places.lisp (remf): Reorder bindings according to ANSI CL 5.1.3. 2004-12-13 Bruno Haible <br...@cl...> --__--__-- Message: 4 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/utils clispload.lsp,1.35,1.36 Date: Tue, 14 Dec 2004 12:04:04 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/utils In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15853/utils Modified Files: clispload.lsp Log Message: Update. Index: clispload.lsp =================================================================== RCS file: /cvsroot/clisp/clisp/utils/clispload.lsp,v retrieving revision 1.35 retrieving revision 1.36 diff -u -d -r1.35 -r1.36 --- clispload.lsp 22 Oct 2004 14:29:42 -0000 1.35 +++ clispload.lsp 14 Dec 2004 12:04:02 -0000 1.36 @@ -9,10 +9,17 @@ ;; Set *package*. (in-package :cl-test) -;; for ENSURE-DIRECTORIES-EXIST.8 -(when (ext:probe-directory "scratch/") - (mapc #'delete-file (directory "scratch/*")) - (ext:delete-dir "scratch/")) +;; Some expected failures, by category. (See notes.lsp.) +(progn + + ;; Paul Dietz assumes a particular implementation for sequence functions + ;; (MAKE-SEQUENCE, CONCATENATE, MAP, ...) that rejects result types like + ;; (OR (VECTOR BIT) (VECTOR T)) because the element type is ambiguous. + ;; CLISP handles these ambiguous cases by computing the union type of the + ;; possible element types and therefore does not need to give an error. + (rt:disable-note :result-type-element-type-by-subtype) + +) ;; The expected failures. (setq regression-test::*expected-failures* '( @@ -20,6 +27,7 @@ ;; ANSI CL 11.1.2. says that the only nickname of the COMMON-LISP package ;; is "CL". In CLISP it also has the nickname "LISP", for backward ;; compatibility with older programs. + ;; Cf. notes.lsp :standardized-package-nicknames. COMMON-LISP-PACKAGE-NICKNAMES ;; ANSI CL 11.1.2. says that the only nickname of the COMMON-LISP-USER @@ -235,8 +243,21 @@ FORMAT.B.20 FORMAT.B.21 FORMAT.O.18 FORMAT.O.19 FORMAT.O.20 FORMAT.O.21 FORMAT.X.18 FORMAT.X.19 FORMAT.X.20 FORMAT.X.21 PARSE-NAMESTRING.4 + INCF.ORDER.4 DECF.ORDER.4 FORMATTER.*.5 FORMATTER.*.9 |FORMATTER.:*.7| + |FORMATTER.:*.13| FORMATTER.@*.5 FORMATTER.@*.10 FORMATTER.COND.13 + FORMATTER.COND.14 |FORMATTER.COND:.6| |FORMATTER.COND:.7| FORMATTER.{.33 + |FORMATTER.:{.12| |FORMATTER.:{.17| FORMATTER.@{.8 |FORMATTER.:@.9| + FORMAT.{.ERROR.1 FORMAT.{.ERROR.2 FORMAT.{.ERROR.3 FORMAT.{.ERROR.4 + FORMAT.{.ERROR.5 |FORMAT.:{.ERROR.1| |FORMAT.:{.ERROR.2| |FORMAT.:{.ERROR.4| + |FORMAT.:{.ERROR.5| |FORMAT.:@.ERROR.1| |FORMAT.:@.ERROR.2| + |FORMAT.:@.ERROR.3| |FORMAT.:@.ERROR.4| |FORMAT.:@.ERROR.5| )) +;; For ENSURE-DIRECTORIES-EXIST.8 +(when (ext:probe-directory "scratch/") + (mapc #'delete-file (directory "scratch/*")) + (ext:delete-dir "scratch/")) + ;; A few tests call DISASSEMBLE. Make it work without user intervention. (setf (ext:getenv "PAGER") "cat") --__--__-- Message: 5 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src ChangeLog,1.3947,1.3948 Date: Tue, 14 Dec 2004 12:26:01 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv19989/src Modified Files: ChangeLog Log Message: Unset CDPATH. Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3947 retrieving revision 1.3948 diff -u -d -r1.3947 -r1.3948 --- ChangeLog 14 Dec 2004 12:04:02 -0000 1.3947 +++ ChangeLog 14 Dec 2004 12:25:55 -0000 1.3948 @@ -1,3 +1,8 @@ +2004-12-14 Bruno Haible <br...@cl...> + + * configure: Unset CDPATH. + Reported by Robert Olney <ro...@pc...>. + 2004-12-13 Bruno Haible <br...@cl...> * utils/clispload.lsp: Call disable-note. --__--__-- Message: 6 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp configure,1.76,1.77 Date: Tue, 14 Dec 2004 12:25:57 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv19989 Modified Files: configure Log Message: Unset CDPATH. Index: configure =================================================================== RCS file: /cvsroot/clisp/clisp/configure,v retrieving revision 1.76 retrieving revision 1.77 diff -u -d -r1.76 -r1.77 --- configure 11 Aug 2004 17:33:03 -0000 1.76 +++ configure 14 Dec 2004 12:25:55 -0000 1.77 @@ -74,6 +74,9 @@ # Abort in case something fails. set -e +# Nuisances. +unset CDPATH + srcdir='' subdir_configure_args='' makemake_args='' --__--__-- Message: 7 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src lispbibl.d,1.590,1.591 package.d,1.87,1.88 ChangeLog,1.3948,1.3949 Date: Tue, 14 Dec 2004 12:56:35 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv25982/src Modified Files: lispbibl.d package.d ChangeLog Log Message: Drop CLtL1 code. Index: package.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/package.d,v retrieving revision 1.87 retrieving revision 1.88 diff -u -d -r1.87 -r1.88 --- package.d 11 Dec 2004 14:16:10 -0000 1.87 +++ package.d 14 Dec 2004 12:56:30 -0000 1.88 @@ -819,13 +819,9 @@ /* UP: Shadows in a package all symbols accessible from other packages of give name by one symbol present in this package of the same name. - shadow(&sym,&pack) */ -#ifdef X3J13_161 -/* > sym: symbol or string (in STACK) */ -#else -/* > sym: symbol (in STACK) */ -#endif -/* > pack: package (in STACK) + shadow(&sym,&pack) + > sym: symbol or string (in STACK) + > pack: package (in STACK) < pack: package, EQ to the old can trigger GC */ local maygc void shadow (const gcv_object_t* sym_, const gcv_object_t* pack_) { @@ -833,11 +829,7 @@ set_break_sem_2(); /* protect against breaks */ /* Search an internal or external symbol of the same name: */ var object string = /* only the name of the symbol counts. */ - #ifdef X3J13_161 test_stringsymchar_arg(*sym_); - #else - Symbol_name(*sym_); - #endif var object pack = *pack_; pushSTACK(NIL); /* make room for othersym */ pushSTACK(string); /* save string */ @@ -2077,18 +2069,13 @@ /* test for symbol: */ if (symbolp(symarg)) goto ok; - #ifdef X3J13_161 if ((fun == &shadow) && (stringp(symarg) || charp(symarg))) goto ok; - #endif /* test for symbol-list: */ while (consp(symarg)) { /* symarg loops over STACK_1 */ if (!(symbolp(Car(symarg)) - #ifdef X3J13_161 || ((fun == &shadow) - && (stringp(Car(symarg)) || charp(Car(symarg)))) - #endif - ) ) + && (stringp(Car(symarg)) || charp(Car(symarg)))))) goto not_ok; symarg = Cdr(symarg); } Index: lispbibl.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/lispbibl.d,v retrieving revision 1.590 retrieving revision 1.591 diff -u -d -r1.590 -r1.591 --- lispbibl.d 14 Dec 2004 11:55:09 -0000 1.590 +++ lispbibl.d 14 Dec 2004 12:56:29 -0000 1.591 @@ -2097,7 +2097,6 @@ #define X3J13_005 # 18.5.1993 #define X3J13_014 # 22.1.1995 #define X3J13_149 # 22.7.1993 -#define X3J13_161 # 20.5.1993 #define X3J13_175 # 25.7.1993 Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3948 retrieving revision 1.3949 diff -u -d -r1.3948 -r1.3949 --- ChangeLog 14 Dec 2004 12:25:55 -0000 1.3948 +++ ChangeLog 14 Dec 2004 12:56:30 -0000 1.3949 @@ -1,3 +1,8 @@ +2004-07-14 Bruno Haible <br...@cl...> + + * lispbibl.d (X3J13_161): Undefine. + * package.d (shadow, apply_symbols): Assume X3J13_161 to be true. + 2004-12-14 Bruno Haible <br...@cl...> * configure: Unset CDPATH. --__--__-- Message: 8 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/tests characters.tst,1.10,1.11 ChangeLog,1.285,1.286 Date: Tue, 14 Dec 2004 13:01:05 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/tests In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv26680/tests Modified Files: characters.tst ChangeLog Log Message: Support for :case-inverted packages and package CS-COMMON-LISP. Index: characters.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/characters.tst,v retrieving revision 1.10 retrieving revision 1.11 diff -u -d -r1.10 -r1.11 --- characters.tst 30 Aug 2004 13:49:44 -0000 1.10 +++ characters.tst 14 Dec 2004 13:01:03 -0000 1.11 @@ -674,3 +674,11 @@ :collect (list i x :digit (digit-char-p x) :alpha (alpha-char-p x) :alphanumericp (alphanumericp x))) nil + +;; Check that sys::char-invertcase is an involution +(locally (declare (compile)) + (loop :for i :from 0 :below char-code-limit + :for x = (code-char i) + :unless (eq (sys::char-invertcase (sys::char-invertcase x)) x) + :collect x)) +NIL Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/tests/ChangeLog,v retrieving revision 1.285 retrieving revision 1.286 diff -u -d -r1.285 -r1.286 --- ChangeLog 13 Dec 2004 11:55:58 -0000 1.285 +++ ChangeLog 14 Dec 2004 13:01:03 -0000 1.286 @@ -1,3 +1,7 @@ +2004-12-12 Bruno Haible <br...@cl...> + + * characters.tst: Add test of sys::char-invertcase. + 2004-12-08 Bruno Haible <br...@cl...> * eval20.tst: Add more constantp tests. --__--__-- Message: 9 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src/po Makefile.devel,1.35,1.36 Date: Tue, 14 Dec 2004 13:00:50 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src/po In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv26680/src/po Modified Files: Makefile.devel Log Message: Support for :case-inverted packages and package CS-COMMON-LISP. Index: Makefile.devel =================================================================== RCS file: /cvsroot/clisp/clisp/src/po/Makefile.devel,v retrieving revision 1.35 retrieving revision 1.36 diff -u -d -r1.35 -r1.36 --- Makefile.devel 24 Nov 2004 11:41:09 -0000 1.35 +++ Makefile.devel 14 Dec 2004 13:00:47 -0000 1.36 @@ -62,8 +62,8 @@ clos-dependent clos-print clos-custom documentation \ fill-out disassem condition loadform gstream xcharin keyboard \ screen beossock runprog query reploop dribble complete \ - describe room edit macros3 clhs inspect gray \ - threads foreign1 german french spanish russian dutch \ + describe room edit macros3 clhs inspect gray threads \ + case-sensitive foreign1 german french spanish russian dutch \ deprecated affi1 SOURCES := $(patsubst %,%.d,$(DSOURCES)) $(patsubst %,%.lisp,$(LISPSOURCES)) --__--__-- Message: 10 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src case-sensitive.lisp,NONE,1.1 package.d,1.88,1.89 constsym.d,1.285,1.286 spvw.d,1.332,1.333 subr.d,1.194,1.195 init.lisp,1.202,1.203 symbol.d,1.31,1.32 charstrg.d,1.110,1.111 io.d,1.262,1.263 lispbibl.d,1.591,1.592 constpack.d,1.13,1.14 subrkw.d,1.50,1.51 defpackage.lisp,1.7,1.8 runprog.lisp,1.12,1.13 complete.lisp,1.12,1.13 defs1.lisp,1.45,1.46 makemake.in,1.491,1.492 encoding.d,1.117,1.118 ChangeLog,1.3949,1.3950 Date: Tue, 14 Dec 2004 13:01:05 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv26680/src Modified Files: package.d constsym.d spvw.d subr.d init.lisp symbol.d charstrg.d io.d lispbibl.d constpack.d subrkw.d defpackage.lisp runprog.lisp complete.lisp defs1.lisp makemake.in encoding.d ChangeLog Added Files: case-sensitive.lisp Log Message: Support for :case-inverted packages and package CS-COMMON-LISP. Index: package.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/package.d,v retrieving revision 1.88 retrieving revision 1.89 diff -u -d -r1.88 -r1.89 --- package.d 14 Dec 2004 12:56:30 -0000 1.88 +++ package.d 14 Dec 2004 13:00:48 -0000 1.89 @@ -37,10 +37,11 @@ } /* UP: Calculates the hashcode of a string. This is a 24-bit-number. - string_hashcode(string) - > string: a string. + string_hashcode(string,invert) + > string: a string + > invert: whether to implicitly case-invert the string < result: the hashcode of the string */ -local uint32 string_hashcode (object string) { +local uint32 string_hashcode (object string, bool invert) { [...983 lines suppressed...] - var object nicks = listof(2); /* ("CL-USER","USER") */ - make_package(popSTACK(),nicks,false); /* "COMMON-LISP-USER" */ + { /* #<PACKAGE COMMON-LISP-USER>: */ + pushSTACK(coerce_imm_ss(ascii_to_string("COMMON-LISP-USER"))); + pushSTACK(coerce_imm_ss(ascii_to_string("CL-USER"))); + pushSTACK(coerce_imm_ss(ascii_to_string("USER"))); + var object nicks = listof(2); /* ("CL-USER" "USER") */ + make_package(popSTACK(),nicks,false,false); /* "COMMON-LISP-USER" */ } - { /* #<PACKAGE LISP>: */ + { /* #<PACKAGE COMMON-LISP>: */ + pushSTACK(coerce_imm_ss(ascii_to_string("COMMON-LISP"))); + pushSTACK(coerce_imm_ss(ascii_to_string("LISP"))); + pushSTACK(coerce_imm_ss(ascii_to_string("CL"))); var object nicks = listof(2); /* ("LISP" "CL") */ - O(default_package) = make_package(popSTACK(),nicks,false); /* "COMMON-LISP" */ + O(default_package) = make_package(popSTACK(),nicks,false,false); /* "COMMON-LISP" */ } /* Created all basic packages. Now append all further packages to the end of O(all_packages). */ --- NEW FILE: case-sensitive.lisp --- ;;; Case-Sensitive Packages for CLISP ;;; Bruno Haible 2004-07-14 (in-package "SYSTEM") ;; From CS-COMMON-LISP export all standard symbols which don't have a ;; case-sensitive variant (like SYMBOL-NAME etc). (let ((cs-cl-package (find-package "CS-COMMON-LISP"))) (do-external-symbols (standard-sym "COMMON-LISP") (let ((cs-sym (find-symbol (symbol-name standard-sym) cs-cl-package))) (if cs-sym ;; Copy the property list (important for STRING et al.). (setf (symbol-plist cs-sym) (copy-list (symbol-plist standard-sym))) ;; Use the standard-sym unmodified. (progn (import (list standard-sym) cs-cl-package) (setq cs-sym standard-sym))) (export (list cs-sym) cs-cl-package)))) ;; #<PACKAGE CS-COMMON-LISP-USER> is default case-sensitive user package. (use-package '("CS-COMMON-LISP" "EXT") "CS-COMMON-LISP-USER") Index: encoding.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/encoding.d,v retrieving revision 1.117 retrieving revision 1.118 diff -u -d -r1.117 -r1.118 --- encoding.d 13 Dec 2004 11:58:26 -0000 1.117 +++ encoding.d 14 Dec 2004 13:01:01 -0000 1.118 @@ -1787,7 +1787,7 @@ var object arg_upcase = string_upcase(arg); var object sym; arg = STACK_3; /* refetch */ - if (find_external_symbol(arg_upcase,O(charset_package),&sym) + if (find_external_symbol(arg_upcase,false,O(charset_package),&sym) && constantp(TheSymbol(sym)) && encodingp(Symbol_value(sym))) arg = Symbol_value(sym); #ifdef HAVE_GOOD_ICONV Index: subrkw.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/subrkw.d,v retrieving revision 1.50 retrieving revision 1.51 diff -u -d -r1.50 -r1.51 --- subrkw.d 2 Nov 2004 11:39:55 -0000 1.50 +++ subrkw.d 14 Dec 2004 13:01:00 -0000 1.51 @@ -14,11 +14,17 @@ s(adjust_array) v(4, (kw(start1),kw(end1),kw(start2),kw(end2)) ) s(string_gleich) +s(cs_string_gleich) s(string_ungleich) +s(cs_string_ungleich) s(string_kleiner) +s(cs_string_kleiner) s(string_groesser) +s(cs_string_groesser) s(string_klgleich) +s(cs_string_klgleich) s(string_grgleich) +s(cs_string_grgleich) s(string_equal) s(string_not_equal) s(string_lessp) @@ -96,8 +102,9 @@ s(rassoc_if) s(rassoc_if_not) s(merge) -v(3, (kw(nicknames),kw(use),kw(case_sensitive)) ) +v(4, (kw(nicknames),kw(use),kw(case_sensitive),kw(case_inverted)) ) s(make_package) +s(cs_make_package) s(pin_package) v(3, (kw(start),kw(end),kw(junk_allowed)) ) s(parse_namestring) Index: constsym.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/constsym.d,v retrieving revision 1.285 retrieving revision 1.286 diff -u -d -r1.285 -r1.286 --- constsym.d 14 Dec 2004 12:02:41 -0000 1.285 +++ constsym.d 14 Dec 2004 13:00:48 -0000 1.286 @@ -181,16 +181,24 @@ LISPSYM(char_int,"CHAR-INT",lisp) LISPSYM(int_char,"INT-CHAR",ext) LISPSYM(char_name,"CHAR-NAME",lisp) +LISPSYM(char_invertcase,"CHAR-INVERTCASE",system) +LISPSYM(string_invertcase,"STRING-INVERTCASE",system) LISPSYM(char,"CHAR",lisp) LISPSYM(schar,"SCHAR",lisp) LISPSYM(store_char,"STORE-CHAR",system) /* ABI */ LISPSYM(store_schar,"STORE-SCHAR",system) /* ABI */ LISPSYM(string_gleich,"STRING=",lisp) +LISPSYM(cs_string_gleich,"STRING=",cs_lisp) LISPSYM(string_ungleich,"STRING/=",lisp) +LISPSYM(cs_string_ungleich,"STRING/=",cs_lisp) LISPSYM(string_kleiner,"STRING<",lisp) +LISPSYM(cs_string_kleiner,"STRING<",cs_lisp) LISPSYM(string_groesser,"STRING>",lisp) +LISPSYM(cs_string_groesser,"STRING>",cs_lisp) LISPSYM(string_klgleich,"STRING<=",lisp) +LISPSYM(cs_string_klgleich,"STRING<=",cs_lisp) LISPSYM(string_grgleich,"STRING>=",lisp) +LISPSYM(cs_string_grgleich,"STRING>=",cs_lisp) LISPSYM(string_equal,"STRING-EQUAL",lisp) LISPSYM(string_not_equal,"STRING-NOT-EQUAL",lisp) LISPSYM(string_lessp,"STRING-LESSP",lisp) @@ -209,6 +217,7 @@ LISPSYM(nstring_capitalize,"NSTRING-CAPITALIZE",lisp) LISPSYM(string_capitalize,"STRING-CAPITALIZE",lisp) LISPSYM(string,"STRING",lisp) +LISPSYM(cs_string,"STRING",cs_lisp) LISPSYM(name_char,"NAME-CHAR",lisp) LISPSYM(substring,"SUBSTRING",ext) LISPSYM(string_concat,"STRING-CONCAT",ext) @@ -579,6 +588,7 @@ LISPSYM(package_lock,"PACKAGE-LOCK",ext) LISPSYM(package_shortest_name,"PACKAGE-SHORTEST-NAME",ext) LISPSYM(package_case_sensitive_p,"PACKAGE-CASE-SENSITIVE-P",ext) +LISPSYM(package_case_inverted_p,"PACKAGE-CASE-INVERTED-P",ext) LISPSYM(package_documentation,"PACKAGE-DOCUMENTATION",system) /* ABI */ LISPSYM(set_package_documentation,"(SETF PACKAGE-DOCUMENTATION)",system) /* ABI */ LISPSYM(set_package_lock,"(SETF PACKAGE-LOCK)",system) /* ABI */ @@ -586,7 +596,9 @@ LISPSYM(check_package_lock,"CHECK-PACKAGE-LOCK",system) LISPSYM(list_all_packages,"LIST-ALL-PACKAGES",lisp) LISPSYM(intern,"INTERN",lisp) +LISPSYM(cs_intern,"INTERN",cs_lisp) LISPSYM(find_symbol,"FIND-SYMBOL",lisp) +LISPSYM(cs_find_symbol,"FIND-SYMBOL",cs_lisp) LISPSYM(unintern,"UNINTERN",lisp) LISPSYM(export,"EXPORT",lisp) LISPSYM(unexport,"UNEXPORT",lisp) @@ -594,13 +606,16 @@ LISPSYM(import,"IMPORT",lisp) LISPSYM(shadowing_import,"SHADOWING-IMPORT",lisp) LISPSYM(shadow,"SHADOW",lisp) +LISPSYM(cs_shadow,"SHADOW",cs_lisp) LISPSYM(use_package,"USE-PACKAGE",lisp) LISPSYM(unuse_package,"UNUSE-PACKAGE",lisp) LISPSYM(make_package,"MAKE-PACKAGE",lisp) +LISPSYM(cs_make_package,"MAKE-PACKAGE",cs_lisp) LISPSYM(pin_package,"%IN-PACKAGE",system) /* ABI */ /* LISPSYM(in_package,"IN-PACKAGE",lisp) */ LISPSYM(delete_package,"DELETE-PACKAGE",lisp) LISPSYM(find_all_symbols,"FIND-ALL-SYMBOLS",lisp) +LISPSYM(cs_find_all_symbols,"FIND-ALL-SYMBOLS",cs_lisp) LISPSYM(map_symbols,"MAP-SYMBOLS",system) /* ABI */ LISPSYM(map_external_symbols,"MAP-EXTERNAL-SYMBOLS",system) /* ABI */ LISPSYM(map_all_symbols,"MAP-ALL-SYMBOLS",system) /* ABI */ @@ -1016,6 +1031,7 @@ LISPSYM(symbol_package,"SYMBOL-PACKAGE",lisp) LISPSYM(symbol_plist,"SYMBOL-PLIST",lisp) LISPSYM(symbol_name,"SYMBOL-NAME",lisp) +LISPSYM(cs_symbol_name,"SYMBOL-NAME",cs_lisp) LISPSYM(keywordp,"KEYWORDP",lisp) LISPSYM(special_variable_p,"SPECIAL-VARIABLE-P",ext) LISPSYM(gensym,"GENSYM",lisp) @@ -1226,6 +1242,7 @@ LISPSYM(Knicknames,"NICKNAMES",keyword) LISPSYM(Kuse,"USE",keyword) LISPSYM(Kcase_sensitive,"CASE-SENSITIVE",keyword) +LISPSYM(Kcase_inverted,"CASE-INVERTED",keyword) LISPSYM(Kupdate,"UPDATE",keyword) LISPSYM(Kup,"UP",keyword) /* 19.2.2.4.3 - directory component */ LISPSYM(Kback,"BACK",keyword) /* (see MAKE-PATHNAME in pathname.d) */ Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3949 retrieving revision 1.3950 diff -u -d -r1.3949 -r1.3950 --- ChangeLog 14 Dec 2004 12:56:30 -0000 1.3949 +++ ChangeLog 14 Dec 2004 13:01:02 -0000 1.3950 @@ -1,3 +1,122 @@ +2004-12-12 Bruno Haible <br...@cl...> + + Support for :case-inverted packages and package CS-COMMON-LISP. + * lispbibl.d (mark_pack_caseinverted, pack_caseinvertedp): New macros. + (mark_pack_locked, mark_pack_unlocked, pack_locked_p): Use bit 2. + (invert_case, string_gleich_inverted, string_invertcase): New + declarations. + (test_stringsymchar_arg, find_external_symbol, intern): Add invert + argument. + * package.d (string_hashcode): Add invert argument. + (newinsert): Update. + (symtab_lookup): Add invert argument. + (symtab_find, symtab_insert, symtab_delete): Update. + (package_lookup_ext, package_lookup_int): Add invert argument. + (inherited_lookup): Likewise. + (make_package): Likewise. + (shadowing_lookup, shadowing_delete): Likewise. + (accessiblep): Update. + (find_external_symbol, find_symbol, intern): Add invert argument. + (intern_keyword): Update. + (package_lookup): Add invert argument. + (shadowing_import): Update. + (do_shadow): Renamed from shadow. Add invert argument. + (shadow, cs_shadow): New functions. + (unintern, import, export, use_package_aux, test_package_arg): Update. + (FIND-PACKAGE): Update. + (test_names_args, RENAME-PACKAGE): Update. + (EXT:PACKAGE-CASE-INVERTED-P): New function. + (do_intern): New function, extracted from INTERN. + (INTERN): Call it. + (CS-COMMON-LISP:INTERN): New function. + (do_find_symbol): New function, extracted from FIND-SYMBOL. + (FIND-SYMBOL): Call it. + (CS-COMMON-LISP:FIND-SYMBOL): New function. + (apply_symbols): Update. + (CS-COMMON-LISP:SHADOW): New function. + (correct_packname): Update. + (in_make_package): Add case_inverted argument. + (MAKE-PACKAGE): Add :CASE-INVERTED argument. + (CS-COMMON-LISP:MAKE-PACKAGE): New function. + (SYSTEM::%IN-PACKAGE): Add :CASE-INVERTED argument. + (do_find_all_symbols): New function, extracted from FIND-ALL-SYMBOLS. + (FIND-ALL-SYMBOLS): Call it. + (CS-COMMON-LISP:FIND-ALL-SYMBOLS): New function. + (map_symbols_aux): Update. + (SYSTEM::PACKAGE-ITERATE): Update. + (init_packages): Reorganize. Creates packages CS-COMMON-LISP and + CS-COMMON-LISP-USER too. + * charstrg.d (invert_case): New function. + (SYS::CHAR-INVERTCASE): New function. + (string_eqcomp_inverted, string_gleich_inverted): New functions. + (nstring_invertcase, string_invertcase): New functions. + (SYS::STRING-INVERTCASE): New function. + (test_stringsymchar_arg): Add invert argument. + (test_1_stringsym_limits, test_2_stringsym_limits): Likewise. + (STRING=): Update. + (CS-COMMON-LISP:STRING=): New function. + (STRING/=): Update. + (CS-COMMON-LISP:STRING/=): New function. + (STRING<): Update. + (CS-COMMON-LISP:STRING<): New function. + (STRING>): Update. + (CS-COMMON-LISP:STRING>): New function. + (STRING<=): Update. + (CS-COMMON-LISP:STRING<=): New function. + (STRING>=): Update. + (CS-COMMON-LISP:STRING>=): New function. + (STRING-EQUAL): Update. + (CS-COMMON-LISP:STRING-EQUAL): New function. + (STRING-NOT-EQUAL): Update. + (CS-COMMON-LISP:STRING-NOT-EQUAL): New function. + (STRING-LESSP): Update. + (CS-COMMON-LISP:STRING-LESSP): New function. + (STRING-GREATERP): Update. + (CS-COMMON-LISP:STRING-GREATERP): New function. + (STRING-NOT-GREATERP): Update. + (CS-COMMON-LISP:STRING-NOT-GREATERP): New function. + (STRING-NOT-LESSP): Update. + (CS-COMMON-LISP:STRING-NOT-LESSP): New function. + (SYS::SEARCH-STRING=): Update. + (SYS::SEARCH-STRING-EQUAL): Update. + (SYS::STRING-BOTH-TRIM): Add an invertp argument. + (STRING-UPCASE, STRING-DOWNCASE, STRING-CAPITALIZE): Update. + (STRING): Update. + (CS-COMMON-LISP:STRING): New function. + (NAME-CHAR): Update. + (SUBSTRING): Update. + * io.d (read_internal): Use the package's case-inverted bit. + (write_sstring_invert): New function. + (write_sstring_case_ext): New function, extracted from + write_sstring_case, with an added case_inverted argument. + (write_sstring_case): Call it. + (pr_symbol): Use the package's case-inverted bit. + (pr_symbol_part): Add case_inverted argument. + (pr_like_symbol): Use the package's case-inverted bit. + * symbol.d (CS-COMMON-LISP:SYMBOL-NAME): New function. + * spvw.d (init_symbol_tab_2): Support packages CS-COMMON-LISP and + CS-COMMON-LISP-USER too. + * constpack.d (LISPPACK): Update. + * encoding.d (MAKE-ENCODING): Update. + * defs1.lisp (string-trim): Update. + (cs-cl::string-trim): New function. + (string-left-trim): Update. + (cs-cl::string-left-trim): New function. + (string-right-trim): Update. + (cs-cl::string-right-trim): New function. + * defpackage.lisp (defpackage): Support case-inverted option. + (find-symbol-cerror): Add invert argument. + (shadowing-import-cerror, import-cerror, intern-export): Likewise. + * case-sensitive.lisp: New file. + * init.lisp: Export package-case-inverted-p. + Load case-sensitive.lisp. + * runprog.lisp (xstring): Handle symbols according to *PRINT-CASE* + and its package. + * complete.lisp (completion): Reorganize. Support case-inverted + packages. + * makemake.in (LPARTS): Add case-sensitive. + * po/Makefile.devel (LISPSOURCES): Add case-sensitive. + 2004-07-14 Bruno Haible <br...@cl...> * lispbibl.d (X3J13_161): Undefine. Index: makemake.in =================================================================== RCS file: /cvsroot/clisp/clisp/src/makemake.in,v retrieving revision 1.491 retrieving revision 1.492 diff -u -d -r1.491 -r1.492 --- makemake.in 11 Dec 2004 14:16:03 -0000 1.491 +++ makemake.in 14 Dec 2004 13:01:00 -0000 1.492 @@ -1468,6 +1468,7 @@ if [ "${with_threads}" != no ]; then LPARTS=$LPARTS' threads' fi +LPARTS=$LPARTS' case-sensitive' if [ $TSYS = master -o "${with_dynamic_ffi}" != no ] ; then LPARTS=$LPARTS' foreign1' fi Index: defs1.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/defs1.lisp,v retrieving revision 1.45 retrieving revision 1.46 diff -u -d -r1.45 -r1.46 --- defs1.lisp 31 Oct 2004 22:55:21 -0000 1.45 +++ defs1.lisp 14 Dec 2004 13:01:00 -0000 1.46 @@ -436,13 +436,19 @@ ;;; functions for strings (Chapter 18) (defun string-trim (character-bag string) - (sys::string-both-trim character-bag character-bag string)) + (sys::string-both-trim character-bag character-bag string nil)) +(defun cs-cl::string-trim (character-bag string) + (sys::string-both-trim character-bag character-bag string t)) (defun string-left-trim (character-bag string) - (sys::string-both-trim character-bag nil string)) + (sys::string-both-trim character-bag nil string nil)) +(defun cs-cl::string-left-trim (character-bag string) + (sys::string-both-trim character-bag nil string t)) (defun string-right-trim (character-bag string) - (sys::string-both-trim nil character-bag string)) + (sys::string-both-trim nil character-bag string nil)) +(defun cs-cl::string-right-trim (character-bag string) + (sys::string-both-trim nil character-bag string t)) ;;; functions for pathnames (Chapter 23.1.5) Index: charstrg.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/charstrg.d,v retrieving revision 1.110 retrieving revision 1.111 diff -u -d -r1.110 -r1.111 --- charstrg.d 11 Dec 2004 14:16:06 -0000 1.110 +++ charstrg.d 14 Dec 2004 13:00:52 -0000 1.111 @@ -2025,6 +2025,144 @@ } +/* Support for case-inverted packages. */ + +/* Converts a character to opposite case. + invert_case(ch) + > ch: a character + < result: a character, either ch or up_case(ch) or down_case(ch) + Note that always invert_case(invert_case(ch)) == ch. */ +global chart invert_case (chart ch) { + var chart up = up_case(ch); + if (!chareq(ch,up)) + return up; + var chart down = down_case(ch); + if (!chareq(ch,down)) + return down; + return ch; +} + +/* (SYS::CHAR-INVERTCASE char) */ +LISPFUNNF(char_invertcase,1) +{ + var object arg = check_char(popSTACK()); + VALUES1(code_char(invert_case(char_code(arg)))); +} + +/* UP: compares two strings of equal length for equality modulo case-invert + > string1,offset1: here are the addressed characters in string1 + > string2,offset2: here are the addressed characters in string2 + > len: number of addressed characters in String1 and in String2, > 0 + < result: true if equal, else false. */ +local bool string_eqcomp_inverted (object string1, uintL offset1, object string2, + uintL offset2, uintL len) { + SstringDispatch(string1,X1, { + var const cintX1* charptr1 = &((SstringX1)TheVarobject(string1))->data[offset1]; + SstringDispatch(string2,X2, { + var const cintX2* charptr2 = &((SstringX2)TheVarobject(string2))->data[offset2]; + do { + if (!chareq(invert_case(as_chart(*charptr1++)),as_chart(*charptr2++))) + goto no; + } while (--len); + }); + }); + return true; + no: return false; +} + +/* UP: compares two strings for equality modulo case-invert + string_gleich_inverted(string1,string2) + > string1: string + > string2: simple-string + < result: /=0, if equal modulo case-invert */ +global bool string_gleich_inverted (object string1, object string2) { + var uintL len1; + var uintL offset1; + string1 = unpack_string_ro(string1,&len1,&offset1); + sstring_un_realloc(string2); + if (len1 != Sstring_length(string2)) + return false; + /* Now both strings have exactly len1 characters. Compare them. */ + if (len1 > 0) + return string_eqcomp_inverted(string1,offset1,string2,0,len1); + return true; +} + +/* UP: converts a string piece to opposite case, uppercase characters to + lowercase and lowercase characters to uppercase. + nstring_invertcase(dv,offset,len); + > object dv: the character storage vector + > uintL offset: index of first affected character + > uintL len: number of affected characters + can trigger GC */ +local maygc void nstring_invertcase (object dv, uintL offset, uintL len) { + restart_it: + if (len > 0) + SstringCase(dv,{ + do { + var chart ch = invert_case(as_chart(TheS8string(dv)->data[offset])); + if (as_cint(ch) < cint8_limit) { + TheS8string(dv)->data[offset] = as_cint(ch); + offset++; + len--; + } else { + dv = sstring_store(dv,offset,ch); + offset++; + len--; + if (sstring_reallocatedp(TheSstring(dv))) { /* has it been reallocated? */ + dv = TheSistring(dv)->data; + goto restart_it; + } + } + } while (len > 0); + },{ + do { + var chart ch = invert_case(as_chart(TheS16string(dv)->data[offset])); + if (as_cint(ch) < cint16_limit) { + TheS16string(dv)->data[offset] = as_cint(ch); + offset++; + len--; + } else { + dv = sstring_store(dv,offset,ch); + offset++; + len--; + if (sstring_reallocatedp(TheSstring(dv))) { /* has it been reallocated? */ + dv = TheSistring(dv)->data; + goto restart_it; + } + } + } while (len > 0); + },{ + var cint32* charptr = &TheS32string(dv)->data[offset]; + do { *charptr = as_cint(invert_case(as_chart(*charptr))); charptr++; + } while (--len); + },{ + fehler_nilarray_retrieve(); + }); +} + +/* UP: converts a string to opposite case + string_invertcase(string) + > string: string + < result: new normal-simple-string + can trigger GC */ +global maygc object string_invertcase (object string) { + string = copy_string_normal(string); /* copy and turn into a normal-simple-string */ + pushSTACK(string); + nstring_invertcase(string,0,Sstring_length(string)); /* convert */ + string = popSTACK(); + DBGREALLOC(string); + return string; +} + +/* (SYS::STRING-INVERTCASE string) */ +LISPFUNNR(string_invertcase,1) +{ + var object arg = check_string(popSTACK()); + VALUES1(string_invertcase(arg)); +} + + /* error, if index-argument is not an integer. */ nonreturning_function(local, fehler_int, (object kw, object obj)) { pushSTACK(obj); /* TYPE-ERROR slot DATUM */ @@ -2309,15 +2447,19 @@ } /* UP: checks a string/symbol/character-argument + test_stringsymchar_arg(obj,invert) > obj: argument - < ergebnis: argument as string + > invert: whether to implicitly case-invert a symbol's printname + < result: argument as string can trigger GC */ -global maygc object test_stringsymchar_arg (object obj) { +global maygc object test_stringsymchar_arg (object obj, bool invert) { restart_stringsymchar: if (stringp(obj)) /* string: return unchanged */ return obj; - if (symbolp(obj)) /* symbol: user print name */ - return TheSymbol(obj)->pname; + if (symbolp(obj)) { /* symbol: use print name */ + obj = TheSymbol(obj)->pname; + return (invert ? string_invertcase(obj) : obj); + } if (charp(obj)) { /* character: turn it into a one-element string: */ var object new_string = allocate_string(1); TheSnstring(new_string)->data[0] = char_code(obj); @@ -2336,23 +2478,24 @@ } /* UP: checks the limits for 1 string/symbol-argument and copies it - test_1_stringsym_limits(&string,&len) + test_1_stringsym_limits(invert,&string,&len) > STACK_2: string/symbol-argument > STACK_1: optional :start-argument > STACK_0: optional :end-argument + > invert: whether to implicitly case-invert a symbol's printname < object string: copy of the string < uintL offset: index of first affected character < uintL len: number of affected characters increases STACK by 3 can trigger GC */ -local maygc void test_1_stringsym_limits (object* string_, uintL* offset_, - uintL* len_) { +local maygc void test_1_stringsym_limits (bool invert, object* string_, + uintL* offset_, uintL* len_) { var object string; var uintL len; var uintL start; var uintL end; /* check string/symbol-argument: */ - string = test_stringsymchar_arg(STACK_2); + string = test_stringsymchar_arg(STACK_2,invert); len = vector_length(string); /* now, len is the length (<2^oint_data_len). check :START-argument: @@ -2377,24 +2520,25 @@ } /* UP: checks the limits for 2 string/symbol-arguments - test_2_stringsym_limits(&arg1,&arg2) + test_2_stringsym_limits(invert,&arg1,&arg2) > STACK_5: string/symbol-argument1 > STACK_4: string/symbol-argument2 > STACK_3: optional :start1-argument > STACK_2: optional :end1-argument > STACK_1: optional :start2-argument > STACK_0: optional :end2-argument + > invert: whether to implicitly case-invert a symbol's printname < stringarg arg1: description of argument1 < stringarg arg2: description of argument2 increases STACK by 6 */ -local void test_2_stringsym_limits (stringarg* arg1, stringarg* arg2) { +local void test_2_stringsym_limits (bool invert, stringarg* arg1, stringarg* arg2) { var uintL len1; var uintL len2; { /* check string/symbol-argument1: */ - var object string1 = test_stringsymchar_arg(STACK_5); + var object string1 = test_stringsymchar_arg(STACK_5,invert); pushSTACK(string1); /* save string1 */ /* check string/symbol-argument2: */ - var object string2 = test_stringsymchar_arg(STACK_(4+1)); + var object string2 = test_stringsymchar_arg(STACK_(4+1),invert); arg2->string = unpack_string_ro(string2,&len2,&arg2->offset); /* now, len2 is the length (<2^oint_data_len) of string2. */ string1 = popSTACK(); /* restore string1 */ @@ -2598,13 +2742,30 @@ }); } +/* (STRING= string1 string2 :start1 :end1 :start2 :end2), CLTL p. 300 */ LISPFUN(string_gleich,seclass_read,2,0,norest,key,4, (kw(start1),kw(end1),kw(start2),kw(end2)) ) -{ /* (STRING= string1 string2 :start1 :end1 :start2 :end2), CLTL p. 300 */ +{ var stringarg arg1; var stringarg arg2; /* check arguments: */ - test_2_stringsym_limits(&arg1,&arg2); + test_2_stringsym_limits(false,&arg1,&arg2); + /* compare: */ + VALUES_IF((arg1.len==arg2.len) + && ((arg1.len==0) + || string_eqcomp(arg1.string,arg1.offset+arg1.index, + arg2.string,arg2.offset+arg2.index, + arg1.len))); +} + +/* (CS-COMMON-LISP:STRING= string1 string2 :start1 :end1 :start2 :end2) */ +LISPFUN(cs_string_gleich,seclass_read,2,0,norest,key,4, + (kw(start1),kw(end1),kw(start2),kw(end2)) ) +{ + var stringarg arg1; + var stringarg arg2; + /* check arguments: */ + test_2_stringsym_limits(true,&arg1,&arg2); /* compare: */ VALUES_IF((arg1.len==arg2.len) && ((arg1.len==0) @@ -2613,57 +2774,122 @@ arg1.len))); } +/* (STRING/= string1 string2 :start1 :end1 :start2 :end2), CLTL p. 301 */ LISPFUN(string_ungleich,seclass_read,2,0,norest,key,4, (kw(start1),kw(end1),kw(start2),kw(end2)) ) -{ /* (STRING/= string1 string2 :start1 :end1 :start2 :end2), CLTL p. 301 */ +{ var stringarg arg1; var stringarg arg2; /* check arguments: */ - test_2_stringsym_limits(&arg1,&arg2); + test_2_stringsym_limits(false,&arg1,&arg2); + /* compare: */ + VALUES1(string_comp(&arg1,&arg2)==0 ? NIL : fixnum(arg1.index)); +} + +/* (CS-COMMON-LISP:STRING/= string1 string2 :start1 :end1 :start2 :end2) */ +LISPFUN(cs_string_ungleich,seclass_read,2,0,norest,key,4, + (kw(start1),kw(end1),kw(start2),kw(end2)) ) +{ + var stringarg arg1; + var stringarg arg2; + /* check arguments: */ + test_2_stringsym_limits(true,&arg1,&arg2); /* compare: */ VALUES1(string_comp(&arg1,&arg2)==0 ? NIL : fixnum(arg1.index)); } +/* (STRING< string1 string2 :start1 :end1 :start2 :end2), CLTL p. 301 */ LISPFUN(string_kleiner,seclass_read,2,0,norest,key,4, (kw(start1),kw(end1),kw(start2),kw(end2)) ) -{ /* (STRING< string1 string2 :start1 :end1 :start2 :end2), CLTL p. 301 */ +{ var stringarg arg1; var stringarg arg2; /* check arguments: */ - test_2_stringsym_limits(&arg1,&arg2); + test_2_stringsym_limits(false,&arg1,&arg2); + /* compare: */ + VALUES1(string_comp(&arg1,&arg2)<0 ? fixnum(arg1.index) : NIL); +} + +/* (CS-COMMON-LISP:STRING< string1 string2 :start1 :end1 :start2 :end2) */ +LISPFUN(cs_string_kleiner,seclass_read,2,0,norest,key,4, + (kw(start1),kw(end1),kw(start2),kw(end2)) ) +{ + var stringarg arg1; + var stringarg arg2; + /* check arguments: */ + test_2_stringsym_limits(true,&arg1,&arg2); /* compare: */ VALUES1(string_comp(&arg1,&arg2)<0 ? fixnum(arg1.index) : NIL); } +/* (STRING> string1 string2 :start1 :end1 :start2 :end2), CLTL p. 301 */ LISPFUN(string_groesser,seclass_read,2,0,norest,key,4, (kw(start1),kw(end1),kw(start2),kw(end2)) ) -{ /* (STRING> string1 string2 :start1 :end1 :start2 :end2), CLTL p. 301 */ +{ var stringarg arg1; var stringarg arg2; /* check arguments: */ - test_2_stringsym_limits(&arg1,&arg2); + test_2_stringsym_limits(false,&arg1,&arg2); + /* compare: */ + VALUES1(string_comp(&arg1,&arg2)>0 ? fixnum(arg1.index) : NIL); +} + +/* (CS-COMMON-LISP:STRING> string1 string2 :start1 :end1 :start2 :end2) */ +LISPFUN(cs_string_groesser,seclass_read,2,0,norest,key,4, + (kw(start1),kw(end1),kw(start2),kw(end2)) ) +{ + var stringarg arg1; + var stringarg arg2; + /* check arguments: */ + test_2_stringsym_limits(true,&arg1,&arg2); /* compare: */ VALUES1(string_comp(&arg1,&arg2)>0 ? fixnum(arg1.index) : NIL); } +/* (STRING<= string1 string2 :start1 :end1 :start2 :end2), CLTL p. 301 */ LISPFUN(string_klgleich,seclass_read,2,0,norest,key,4, (kw(start1),kw(end1),kw(start2),kw(end2)) ) -{ /* (STRING<= string1 string2 :start1 :end1 :start2 :end2), CLTL p. 301 */ +{ var stringarg arg1; var stringarg arg2; /* check arguments: */ - test_2_stringsym_limits(&arg1,&arg2); + test_2_stringsym_limits(false,&arg1,&arg2); + /* compare: */ + VALUES1(string_comp(&arg1,&arg2)<=0 ? fixnum(arg1.index) : NIL); +} + +/* (CS-COMMON-LISP:STRING<= string1 string2 :start1 :end1 :start2 :end2) */ +LISPFUN(cs_string_klgleich,seclass_read,2,0,norest,key,4, + (kw(start1),kw(end1),kw(start2),kw(end2)) ) +{ + var stringarg arg1; + var stringarg arg2; + /* check arguments: */ + test_2_stringsym_limits(true,&arg1,&arg2); /* compare: */ VALUES1(string_comp(&arg1,&arg2)<=0 ? fixnum(arg1.index) : NIL); } +/* (STRING>= string1 string2 :start1 :end1 :start2 :end2), CLTL p. 301 */ LISPFUN(string_grgleich,seclass_read,2,0,norest,key,4, (kw(start1),kw(end1),kw(start2),kw(end2)) ) -{ /* (STRING>= string1 string2 :start1 :end1 :start2 :end2), CLTL p. 301 */ +{ var stringarg arg1; var stringarg arg2; /* check arguments: */ - test_2_stringsym_limits(&arg1,&arg2); + test_2_stringsym_limits(false,&arg1,&arg2); + /* compare: */ + VALUES1(string_comp(&arg1,&arg2)>=0 ? fixnum(arg1.index) : NIL); +} + +/* (CS-COMMON-LISP:STRING>= string1 string2 :start1 :end1 :start2 :end2) */ +LISPFUN(cs_string_grgleich,seclass_read,2,0,norest,key,4, + (kw(start1),kw(end1),kw(start2),kw(end2)) ) +{ + var stringarg arg1; + var stringarg arg2; + /* check arguments: */ + test_2_stringsym_limits(true,&arg1,&arg2); /* compare: */ VALUES1(string_comp(&arg1,&arg2)>=0 ? fixnum(arg1.index) : NIL); } @@ -2822,13 +3048,14 @@ }); } +/* (STRING-EQUAL string1 string2 :start1 :end1 :start2 :end2), CLTL p. 301 */ LISPFUN(string_equal,seclass_read,2,0,norest,key,4, (kw(start1),kw(end1),kw(start2),kw(end2)) ) -{ /* (STRING-EQUAL string1 string2 :start1 :end1 :start2 :end2), CLTL p. 301 */ +{ var stringarg arg1; var stringarg arg2; /* check arguments: */ - test_2_stringsym_limits(&arg1,&arg2); + test_2_stringsym_limits(false,&arg1,&arg2); /* compare: */ VALUES_IF((arg1.len==arg2.len) && ((arg1.len==0) @@ -2837,61 +3064,66 @@ arg1.len))); } +/* (STRING-NOT-EQUAL string1 string2 :start1 :end1 :start2 :end2), + CLTL p. 302 */ LISPFUN(string_not_equal,seclass_read,2,0,norest,key,4, (kw(start1),kw(end1),kw(start2),kw(end2)) ) -{ /* (STRING-NOT-EQUAL string1 string2 :start1 :end1 :start2 :end2), - CLTL p. 302 */ +{ var stringarg arg1; var stringarg arg2; /* check arguments: */ - test_2_stringsym_limits(&arg1,&arg2); + test_2_stringsym_limits(false,&arg1,&arg2); /* compare: */ VALUES1(string_comp_ci(&arg1,&arg2)==0 ? NIL : fixnum(arg1.index)); } +/* (STRING-LESSP string1 string2 :start1 :end1 :start2 :end2), CLTL p. 302 */ LISPFUN(string_lessp,seclass_read,2,0,norest,key,4, (kw(start1),kw(end1),kw(start2),kw(end2)) ) -{ /* (STRING-LESSP string1 string2 :start1 :end1 :start2 :end2), CLTL p. 302 */ +{ var stringarg arg1; var stringarg arg2; /* check arguments: */ - test_2_stringsym_limits(&arg1,&arg2); + test_2_stringsym_limits(false,&arg1,&arg2); /* compare: */ VALUES1(string_comp_ci(&arg1,&arg2)<0 ? fixnum(arg1.index) : NIL); } +/* (STRING-GREATERP string1 string2 :start1 :end1 :start2 :end2), + CLTL p. 302 */ LISPFUN(string_greaterp,seclass_read,2,0,norest,key,4, (kw(start1),kw(end1),kw(start2),kw(end2)) ) -{ /* (STRING-GREATERP string1 string2 :start1 :end1 :start2 :end2), - CLTL p. 302 */ +{ var stringarg arg1; var stringarg arg2; /* check arguments: */ - test_2_stringsym_limits(&arg1,&arg2); + test_2_stringsym_limits(false,&arg1,&arg2); /* compare: */ VALUES1(string_comp_ci(&arg1,&arg2)>0 ? fixnum(arg1.index) : NIL); } +/* (STRING-NOT-GREATERP string1 string2 :start1 :end1 :start2 :end2), + CLTL p. 302 */ LISPFUN(string_not_greaterp,seclass_read,2,0,norest,key,4, (kw(start1),kw(end1),kw(start2),kw(end2)) ) -{ /* (STRING-NOT-GREATERP string1 string2 :start1 :end1 :start2 :end2), - CLTL p. 302 */ +{ var stringarg arg1; var stringarg arg2; /* check arguments: */ - test_2_stringsym_limits(&arg1,&arg2); + test_2_stringsym_limits(false,&arg1,&arg2); /* compare: */ VALUES1(string_comp_ci(&arg1,&arg2)<=0 ? fixnum(arg1.index) : NIL); } +/* (STRING-NOT-LESSP string1 string2 :start1 :end1 :start2 :end2), + CLTL p. 302 */ LISPFUN(string_not_lessp,seclass_read,2,0,norest,key,4, (kw(start1),kw(end1),kw(start2),kw(end2)) ) -{ /* (STRING-NOT-LESSP string1 string2 :start1 :end1 :start2 :end2), - CLTL p. 302 */ +{ var stringarg arg1; var stringarg arg2; /* check arguments: */ - test_2_stringsym_limits(&arg1,&arg2); + test_2_stringsym_limits(false,&arg1,&arg2); /* compare: */ VALUES1(string_comp_ci(&arg1,&arg2)>=0 ? fixnum(arg1.index) : NIL); } @@ -2941,7 +3173,7 @@ var stringarg arg1; var stringarg arg2; /* check arguments: */ - test_2_stringsym_limits(&arg1,&arg2); + test_2_stringsym_limits(false,&arg1,&arg2); /* search string1 in string2: */ VALUES1(string_search(&arg1,&arg2,&string_eqcomp)); } @@ -2953,7 +3185,7 @@ var stringarg arg1; var stringarg arg2; /* check arguments: */ - test_2_stringsym_limits(&arg1,&arg2); + test_2_stringsym_limits(false,&arg1,&arg2); /* search string1 in string2: */ VALUES1(string_search(&arg1,&arg2,&string_eqcomp_ci)); } @@ -3035,8 +3267,8 @@ VALUES1(new_string); skipSTACK(3); } -LISPFUNNR(string_both_trim,3) -/* (SYS::STRING-BOTH-TRIM character-bag-left character-bag-right string) +LISPFUNNR(string_both_trim,4) +/* (SYS::STRING-BOTH-TRIM character-bag-left character-bag-right string invertp) basic function for STRING-TRIM, STRING-LEFT-TRIM, STRING-RIGHT-TRIM, CLTL p. 302 method: @@ -3052,7 +3284,8 @@ (return (if (and (= i 0) (= j l)) string (substring string i j)))))))) */ { - var object string = test_stringsymchar_arg(popSTACK()); /* convert argument into string */ + var object invertp = popSTACK(); + var object string = test_stringsymchar_arg(popSTACK(),!nullp(invertp)); /* convert argument into string */ pushSTACK(string); /* and back into stack again */ pushSTACK(fixnum(vector_length(string))); /* length as fixnum into the stack */ pushSTACK(Fixnum_0); /* i := 0 */ @@ -3176,7 +3409,7 @@ var object string; var uintL offset; var uintL len; - test_1_stringsym_limits(&string,&offset,&len); + test_1_stringsym_limits(false,&string,&offset,&len); pushSTACK(string); nstring_upcase(string,offset,len); string = popSTACK(); @@ -3251,7 +3484,7 @@ var object string; var uintL offset; var uintL len; - test_1_stringsym_limits(&string,&offset,&len); + test_1_stringsym_limits(false,&string,&offset,&len); pushSTACK(string); nstring_downcase(string,offset,len); string = popSTACK(); @@ -3373,7 +3606,7 @@ var object string; var uintL offset; var uintL len; - test_1_stringsym_limits(&string,&offset,&len); + test_1_stringsym_limits(false,&string,&offset,&len); pushSTACK(string); nstring_capitalize(string,offset,len); string = popSTACK(); @@ -3381,15 +3614,23 @@ VALUES1(string); } +/* (STRING object), CLTL p. 304 */ LISPFUNNR(string,1) -{ /* (STRING object), CLTL p. 304 */ - VALUES1(test_stringsymchar_arg(popSTACK())); +{ + VALUES1(test_stringsymchar_arg(popSTACK(),false)); +} + +/* (CS-COMMON-LISP:STRING object) */ +LISPFUNNR(cs_string,1) +{ + VALUES1(test_stringsymchar_arg(popSTACK(),true)); } +/* (NAME-CHAR name), CLTL p. 243 */ LISPFUNNR(name_char,1) -{ /* (NAME-CHAR name), CLTL p. 243 */ - /* convert argument into a string, search character with this name: */ - VALUES1(name_char(test_stringsymchar_arg(popSTACK()))); +{ /* Convert argument into a string. (Case is not significant here.) + Then search a character with this name: */ + VALUES1(name_char(test_stringsymchar_arg(popSTACK(),false))); } /* UP: Returns a substring of a simple-string. @@ -3434,7 +3675,8 @@ var uintL start; var uintL end; /* check string/symbol-argument: */ - string = test_stringsymchar_arg(STACK_2); + /* FIXME: This does the wrong thing in a case-sensitive package. */ + string = test_stringsymchar_arg(STACK_2,false); len = vector_length(string); /* now, len is the length (<2^oint_data_len). check :START-argument: Index: subr.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/subr.d,v retrieving revision 1.194 retrieving revision 1.195 diff -u -d -r1.194 -r1.195 --- subr.d 10 Dec 2004 16:09:12 -0000 1.194 +++ subr.d 14 Dec 2004 13:00:51 -0000 1.195 @@ -259,22 +259,36 @@ LISPFUNNF(char_int,1) LISPFUNNF(int_char,1) LISPFUNNF(char_name,1) +LISPFUNNF(char_invertcase,1) +LISPFUNNR(string_invertcase,1) LISPFUNNR(char,2) LISPFUNNR(schar,2) LISPFUNN(store_char,3) LISPFUNN(store_schar,3) LISPFUN(string_gleich,seclass_read,2,0,norest,key,4, (kw(start1),kw(end1),kw(start2),kw(end2)) ) +LISPFUN(cs_string_gleich,seclass_read,2,0,norest,key,4, + (kw(start1),kw(end1),kw(start2),kw(end2)) ) LISPFUN(string_ungleich,seclass_read,2,0,norest,key,4, (kw(start1),kw(end1),kw(start2),kw(end2)) ) +LISPFUN(cs_string_ungleich,seclass_read,2,0,norest,key,4, + (kw(start1),kw(end1),kw(start2),kw(end2)) ) LISPFUN(string_kleiner,seclass_read,2,0,norest,key,4, (kw(start1),kw(end1),kw(start2),kw(end2)) ) +LISPFUN(cs_string_kleiner,seclass_read,2,0,norest,key,4, + (kw(start1),kw(end1),kw(start2),kw(end2)) ) LISPFUN(string_groesser,seclass_read,2,0,norest,key,4, (kw(start1),kw(end1),kw(start2),kw(end2)) ) +LISPFUN(cs_string_groesser,seclass_read,2,0,norest,key,4, + (kw(start1),kw(end1),kw(start2),kw(end2)) ) LISPFUN(string_klgleich,seclass_read,2,0,norest,key,4, (kw(start1),kw(end1),kw(start2),kw(end2)) ) +LISPFUN(cs_string_klgleich,seclass_read,2,0,norest,key,4, + (kw(start1),kw(end1),kw(start2),kw(end2)) ) LISPFUN(string_grgleich,seclass_read,2,0,norest,key,4, (kw(start1),kw(end1),kw(start2),kw(end2)) ) +LISPFUN(cs_string_grgleich,seclass_read,2,0,norest,key,4, + (kw(start1),kw(end1),kw(start2),kw(end2)) ) LISPFUN(string_equal,seclass_read,2,0,norest,key,4, (kw(start1),kw(end1),kw(start2),kw(end2)) ) LISPFUN(string_not_equal,seclass_read,2,0,norest,key,4, @@ -293,7 +307,7 @@ (kw(start1),kw(end1),kw(start2),kw(end2)) ) LISPFUN(make_string,seclass_no_se,1,0,norest,key,2, (kw(initial_element),kw(element_type)) ) -LISPFUNNR(string_both_trim,3) +LISPFUNNR(string_both_trim,4) LISPFUN(string_width,seclass_default,1,0,norest,key,2, (kw(start),kw(end)) ) LISPFUN(nstring_upcase,seclass_default,1,0,norest,key,2, (kw(start),kw(end)) ) LISPFUN(string_upcase,seclass_read,1,0,norest,key,2, (kw(start),kw(end)) ) @@ -304,6 +318,7 @@ (kw(start),kw(end)) ) LISPFUN(string_capitalize,seclass_read,1,0,norest,key,2, (kw(start),kw(end)) ) LISPFUNNR(string,1) +LISPFUNNR(cs_string,1) LISPFUNNR(name_char,1) LISPFUN(substring,seclass_read,2,1,norest,nokey,0,NIL) LISPFUN(string_concat,seclass_read,0,0,rest,nokey,0,NIL) @@ -696,6 +711,7 @@ LISPFUNNR(package_lock,1) LISPFUNNR(package_shortest_name,1) LISPFUNNR(package_case_sensitive_p,1) +LISPFUNNR(package_case_inverted_p,1) LISPFUNNR(package_documentation,1) LISPFUNN(set_package_documentation,2) LISPFUNN(set_package_lock,2) @@ -703,7 +719,9 @@ LISPFUNN(check_package_lock,3) LISPFUNNR(list_all_packages,0) LISPFUN(intern,seclass_default,1,1,norest,nokey,0,NIL) +LISPFUN(cs_intern,seclass_default,1,1,norest,nokey,0,NIL) LISPFUN(find_symbol,seclass_read,1,1,norest,nokey,0,NIL) +LISPFUN(cs_find_symbol,seclass_read,1,1,norest,nokey,0,NIL) LISPFUN(unintern,seclass_default,1,1,norest,nokey,0,NIL) LISPFUN(export,seclass_default,1,1,norest,nokey,0,NIL) LISPFUN(unexport,seclass_default,1,1,norest,nokey,0,NIL) @@ -711,14 +729,18 @@ LISPFUN(import,seclass_default,1,1,norest,nokey,0,NIL) LISPFUN(shadowing_import,seclass_default,1,1,norest,nokey,0,NIL) LISPFUN(shadow,seclass_default,1,1,norest,nokey,0,NIL) +LISPFUN(cs_shadow,seclass_default,1,1,norest,nokey,0,NIL) LISPFUN(use_package,seclass_default,1,1,norest,nokey,0,NIL) LISPFUN(unuse_package,seclass_default,1,1,norest,nokey,0,NIL) -LISPFUN(make_package,seclass_default,1,0,norest,key,3, - (kw(nicknames),kw(use),kw(case_sensitive)) ) -LISPFUN(pin_package,seclass_default,1,0,norest,key,3, - (kw(nicknames),kw(use),kw(case_sensitive)) ) +LISPFUN(make_package,seclass_default,1,0,norest,key,4, + (kw(nicknames),kw(use),kw(case_sensitive),kw(case_inverted)) ) +LISPFUN(cs_make_package,seclass_default,1,0,norest,key,4, + (kw(nicknames),kw(use),kw(case_sensitive),kw(case_inverted)) ) +LISPFUN(pin_package,seclass_default,1,0,norest,key,4, + (kw(nicknames),kw(use),kw(case_sensitive),kw(case_inverted)) ) LISPFUNN(delete_package,1) LISPFUNNR(find_all_symbols,1) +LISPFUNNR(cs_find_all_symbols,1) LISPFUNN(map_symbols,2) LISPFUNN(map_external_symbols,2) LISPFUNN(map_all_symbols,1) @@ -1191,6 +1213,7 @@ LISPFUNNR(symbol_package,1) LISPFUNNR(symbol_plist,1) LISPFUN(symbol_name,seclass_no_se,1,0,norest,nokey,0,NIL) +LISPFUNNR(cs_symbol_name,1) LISPFUNNR(keywordp,1) LISPFUN(gensym,seclass_read,0,1,norest,nokey,0,NIL) /* ---------- LISPARIT ---------- */ Index: symbol.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/symbol.d,v retrieving revision 1.31 retrieving revision 1.32 diff -u -d -r1.31 -r1.32 --- symbol.d 31 Mar 2004 12:23:53 -0000 1.31 +++ symbol.d 14 Dec 2004 13:00:52 -0000 1.32 @@ -297,6 +297,13 @@ VALUES1(Symbol_name(symbol)); } +/* (CS-COMMON-LISP:SYMBOL-NAME symbol) */ +LISPFUNNR(cs_symbol_name,1) +{ /* Return the case-inverted symbol name. */ + var object symbol = check_symbol(popSTACK()); + VALUES1(string_in... [truncated message content] |