From 2f4aa7aa9635c7bc438ce437327ef486d0746fd9 Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Mon, 8 Dec 2008 14:39:28 +0100 Subject: [PATCH] The unsafe inline forms for CHAR/CHAR-SET do not handle Unicode strings properly. --- src/c/symbols_list.h | 24 +++++++++++++----------- src/c/symbols_list2.h | 2 ++ src/cmp/cmpffi.lsp | 4 ++-- src/cmp/sysfun.lsp | 33 +++++++++++++++++++++++++-------- src/lsp/predlib.lsp | 7 +++++++ 5 files changed, 49 insertions(+), 21 deletions(-) diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 8f4e7eb1e..ccd9abf3a 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1687,7 +1687,7 @@ cl_symbols[] = { {"LOG1P", SI_ORDINARY, si_log1p, 1, OBJNULL}, -{EXT_ "BC-FILE", SI_ORDINARY, si_bc_file, 1, Cnil}, +{EXT_ "BC-FILE", EXT_ORDINARY, si_bc_file, 1, Cnil}, {SYS_ "PROPERTY-LIST", SI_ORDINARY, NULL, 1, OBJNULL}, @@ -1697,17 +1697,19 @@ cl_symbols[] = { {SYS_ "HASH-EQUAL", SI_ORDINARY, si_hash_equal, -1, OBJNULL}, {SYS_ "HASH-EQUALP", SI_ORDINARY, si_hash_equalp, -1, OBJNULL}, -{EXT_ "INTERACTIVE-INTERRUPT", SI_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "INTERACTIVE-INTERRUPT", EXT_ORDINARY, NULL, -1, OBJNULL}, -{EXT_ "STACK-OVERFLOW", SI_ORDINARY, NULL, -1, OBJNULL}, -{EXT_ "STACK-OVERFLOW-SIZE", SI_ORDINARY, NULL, -1, OBJNULL}, -{EXT_ "STACK-OVERFLOW-TYPE", SI_ORDINARY, NULL, -1, OBJNULL}, -{EXT_ "BINDING-STACK", SI_ORDINARY, NULL, -1, OBJNULL}, -{EXT_ "FRAME-STACK", SI_ORDINARY, NULL, -1, OBJNULL}, -{EXT_ "LISP-STACK", SI_ORDINARY, NULL, -1, OBJNULL}, -{EXT_ "C-STACK", SI_ORDINARY, NULL, -1, OBJNULL}, -{EXT_ "SET-STACK-SIZE", SI_ORDINARY, si_set_stack_size, 2, OBJNULL}, -{EXT_ "SEGMENTATION-VIOLATION", SI_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "STACK-OVERFLOW", EXT_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "STACK-OVERFLOW-SIZE", EXT_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "STACK-OVERFLOW-TYPE", EXT_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "BINDING-STACK", EXT_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "FRAME-STACK", EXT_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "LISP-STACK", EXT_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "C-STACK", EXT_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "SET-STACK-SIZE", EXT_ORDINARY, si_set_stack_size, 2, OBJNULL}, +{EXT_ "SEGMENTATION-VIOLATION", EXT_ORDINARY, NULL, -1, OBJNULL}, + +{EXT_ "EXTENDED-STRING", EXT_ORDINARY, NULL, -1, OBJNULL}, /* Tag for end of list */ {NULL, CL_ORDINARY, NULL, -1, OBJNULL}}; diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 787bb8820..e54d3c11d 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1709,5 +1709,7 @@ cl_symbols[] = { {EXT_ "SET-STACK-SIZE","si_set_stack_size"}, {EXT_ "SEGMENTATION-VIOLATION",NULL}, +{EXT_ "EXTENDED-STRING",NULL}, + /* Tag for end of list */ {NULL,NULL}}; diff --git a/src/cmp/cmpffi.lsp b/src/cmp/cmpffi.lsp index 7db92f033..85a195322 100644 --- a/src/cmp/cmpffi.lsp +++ b/src/cmp/cmpffi.lsp @@ -31,8 +31,8 @@ :float (single-float "float") :double (double-float "double") #+:long-float :long-double #+:long-float (long-float "long double") - :char (base-char "char") :unsigned-char (base-char "char") + :char (base-char "char") :wchar (character "cl_index") :object (t "cl_object") :bool (t "bool") @@ -120,7 +120,7 @@ (t (case (first loc) (FIXNUM-VALUE :fixnum) - (CHARACTER-VALUE (if (<= (second loc) 255) :char :wchar)) + (CHARACTER-VALUE (if (<= (second loc) 255) :unsigned-char :wchar)) (DOUBLE-FLOAT-VALUE :double) (SINGLE-FLOAT-VALUE :float) (LONG-FLOAT-VALUE :long-double) diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp index 91d27a893..99e78b683 100644 --- a/src/cmp/sysfun.lsp +++ b/src/cmp/sysfun.lsp @@ -1146,31 +1146,48 @@ type_of(#0)==t_bitvector") (proclaim-function char (string fixnum) character :no-side-effects t) (def-inline char :always (t t) t "cl_char(#0,#1)") (def-inline char :always (t fixnum) t "ecl_aref1(#0,#1)") +#-unicode (def-inline char :unsafe (t t) t "CODE_CHAR((#0)->base_string.self[fix(#1)])") +#-unicode (def-inline char :unsafe (t fixnum) :fixnum "(#0)->base_string.self[#1]") +#-unicode (def-inline char :unsafe (t fixnum) :char "(#0)->base_string.self[#1]") +(def-inline char :unsafe (base-string fixnum) :fixnum "(#0)->base_string.self[#1]") +(def-inline char :unsafe (base-string fixnum) :unsigned-char "(#0)->base_string.self[#1]") +(def-inline char :unsafe (ext:extended-string fixnum) :fixnum "(#0)->string.self[#1]") +(def-inline char :unsafe (ext:extended-string fixnum) :wchar "(#0)->string.self[#1]") (proclaim-function si:char-set (string fixnum character) character) (def-inline si:char-set :always (t t t) t "si_char_set(#0,#1,#2)") (def-inline si:char-set :always (t fixnum t) t "ecl_aset1(#0,#1,#2)") +#-unicode (def-inline si:char-set :unsafe (t t t) t "@2;((#0)->base_string.self[fix(#1)]=ecl_char_code(#2),(#2))") +#-unicode (def-inline si:char-set :unsafe (t fixnum character) :char "(#0)->base_string.self[#1]= #2") +(def-inline si:char-set :unsafe (base-string t t) t + "@2;((#0)->base_string.self[fix(#1)]=ecl_char_code(#2),(#2))") +(def-inline si:char-set :unsafe (base-string fixnum base-char) :char + "(#0)->base_string.self[#1]= #2") +(def-inline si:char-set :unsafe (ext:extended-string t t) t + "@2;((#0)->string.self[fix(#1)]=ecl_char_code(#2),(#2))") +(def-inline si:char-set :unsafe (ext:extended-string fixnum character) :char + "(#0)->string.self[#1]= #2") (proclaim-function schar (simple-string fixnum) character :no-side-effects t) (def-inline schar :always (t t) t "ecl_elt(#0,fixint(#1))") (def-inline schar :always (t fixnum) t "ecl_elt(#0,#1)") -(def-inline schar :unsafe ((array base-char (*)) t) t "CODE_CHAR((#0)->base_string.self[fix(#1)])") +(def-inline schar :unsafe (base-string t) t "CODE_CHAR((#0)->base_string.self[fix(#1)])") #-unicode (def-inline schar :unsafe (t t) :fixnum "(#0)->base_string.self[fix(#1)]") #-unicode (def-inline schar :unsafe (t fixnum) :fixnum "(#0)->base_string.self[#1]") -(def-inline schar :unsafe ((array base-char (*)) t) :fixnum "(#0)->base_string.self[fix(#1)]") -(def-inline schar :unsafe ((array base-char (*)) fixnum) :fixnum "(#0)->base_string.self[#1]") -(def-inline schar :unsafe ((array base-char (*)) fixnum) :char "(#0)->base_string.self[#1]") +(def-inline schar :unsafe (base-string t) :fixnum "(#0)->base_string.self[fix(#1)]") +(def-inline schar :unsafe (base-string fixnum) :fixnum "(#0)->base_string.self[#1]") +(def-inline schar :unsafe (base-string fixnum) :char "(#0)->base_string.self[#1]") #+unicode -(def-inline schar :unsafe ((array character (*)) t) t "(#0)->string.self[fix(#1)]") +(def-inline schar :unsafe (ext:extended-string t) t "(#0)->string.self[fix(#1)]") (proclaim-function si:schar-set (string fixnum character) character) (def-inline si:schar-set :always (t t t) t "ecl_elt_set(#0,fixint(#1),#2)") @@ -1181,12 +1198,12 @@ type_of(#0)==t_bitvector") #-unicode (def-inline si:schar-set :unsafe (t fixnum base-char) :char "(#0)->base_string.self[#1]= #2") -(def-inline si:schar-set :unsafe ((array base-char (*)) t t) t +(def-inline si:schar-set :unsafe (base-string t t) t "@2;((#0)->base_string.self[fix(#1)]=ecl_char_code(#2),(#2))") -(def-inline si:schar-set :unsafe ((array base-char (*)) fixnum base-char) :char +(def-inline si:schar-set :unsafe (base-string fixnum base-char) :char "(#0)->base_string.self[#1]= #2") #+unicode -(def-inline si:schar-set :unsafe ((array character (*)) fixnum t) :char +(def-inline si:schar-set :unsafe (ext:extended-string fixnum t) :char "(#0)->string.self[#1]= #2") (proclaim-function string= (string-designator string-designator *) t :predicate t :no-side-effects t) diff --git a/src/lsp/predlib.lsp b/src/lsp/predlib.lsp index d32e96e4d..b9d7ee9b7 100644 --- a/src/lsp/predlib.lsp +++ b/src/lsp/predlib.lsp @@ -213,6 +213,13 @@ called simple-strings." "A string which is made of BASE-CHAR." (if size `(array base-char (,size)) '(array base-char (*)))) +(deftype extended-string (&optional size) + "A string which is nt a base string" + #-unicode + NIL + #+unicode + (if size `(array character (,size)) '(array character (*)))) + (deftype bit-vector (&optional size) "A bit-vector is a vector of bits. A bit-vector is notated by '#*' followed by its elements (0 or 1). Bit-vectors may be displaced to another array, may