mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-14 05:12:38 -08:00
Code Issues Projects Releases Packages Wiki Activity

The unsafe inline forms for CHAR/CHAR-SET do not handle Unicode strings properly.

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2008-12-08 14:39:28 +01:00
parent 6aa5c0572d
commit 2f4aa7aa96
5 changed files with 49 additions and 21 deletions
Download patch file Download diff file Expand all files Collapse all files

24
src/c/symbols_list.h
View file

@ -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}};

2
src/c/symbols_list2.h
View file

@ -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}};

4
src/cmp/cmpffi.lsp
View file

@ -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)

33
src/cmp/sysfun.lsp
View file

@ -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)

7
src/lsp/predlib.lsp
View file

@ -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