From 87acde9ae931ba8ac7bd486809f6dab3b2448790 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Wed, 8 Jun 2005 18:52:54 +0000 Subject: [PATCH] r10571: avoid multiple evaluation for strings input to macros --- ChangeLog | 2 + src/libraries.lisp | 7 +- src/strings.lisp | 228 ++++++++++++++++++++++++++------------------- 3 files changed, 140 insertions(+), 97 deletions(-) diff --git a/ChangeLog b/ChangeLog index 3ad8a33..a473121 100644 --- a/ChangeLog +++ b/ChangeLog @@ -5,6 +5,8 @@ locations known to the operating system. * tests/cast.lisp: Add :module keyword as noted by Joerg Hoehle. + * src/strings.lisp: Avoid multiple evaluation of input + parameters for macros as noted by Joerg Hoele. 2005-04-12 Kevin Rosenberg (kevin@rosenberg.net) * Version 1.4.37 diff --git a/src/libraries.lisp b/src/libraries.lisp index 3ca10da..af860c4 100644 --- a/src/libraries.lisp +++ b/src/libraries.lisp @@ -87,8 +87,11 @@ library type if type is not specified." (probe-file filename))) (if (pathnamep filename) ;; ensure filename is a string to check if already loaded (setq filename (namestring (if (null (pathname-directory filename)) - filename (truename filename))))) - + filename + ;; lispworks treats as UNC, so use truename + #+(and lispworks win32 mswindows) (truename filename) + #-(and lispworks win32 mswindows) filename)))) + (if (and (not force-load) (find filename *loaded-libraries* :test #'string-equal)) t ;; return T, but don't reload library diff --git a/src/strings.lisp b/src/strings.lisp index 684b035..1e90118 100644 --- a/src/strings.lisp +++ b/src/strings.lisp @@ -35,7 +35,7 @@ that LW/CMU automatically converts strings from c-calls." `(let ((,stored ,obj)) (if (zerop ,stored) nil - (values (excl:native-to-string ,stored))))) + (values (excl:native-to-string ,stored))))) #+mcl (let ((stored (gensym))) `(let ((,stored ,obj)) @@ -47,41 +47,53 @@ that LW/CMU automatically converts strings from c-calls." (defmacro convert-to-cstring (obj) #+(or cmu sbcl scl lispworks) obj #+allegro - `(if (null ,obj) - 0 - (values (excl:string-to-native ,obj))) + (let ((stored (gensym))) + `(let ((,stored ,obj)) + (if (null ,stored) + 0 + (values (excl:string-to-native ,stored))))) #+mcl - `(if (null ,obj) - +null-cstring-pointer+ - (let ((ptr (new-ptr (1+ (length ,obj))))) - (ccl::%put-cstring ptr ,obj) - ptr)) + (let ((stored (gensym))) + `(let ((,stored ,obj)) + (if (null ,stored) + +null-cstring-pointer+ + (let ((ptr (new-ptr (1+ (length ,stored))))) + (ccl::%put-cstring ptr ,stored) + ptr)))) ) (defmacro free-cstring (obj) #+(or cmu sbcl scl lispworks) (declare (ignore obj)) #+allegro - `(unless (zerop ,obj) - (ff:free-fobject ,obj)) + (let ((stored (gensym))) + `(let ((,stored ,obj)) + (unless (zerop ,stored) + (ff:free-fobject ,stored)))) #+mcl - `(unless (ccl:%null-ptr-p ,obj) - (dispose-ptr ,obj)) + (let ((stored (gensym))) + `(let ((,stored ,obj)) + (unless (ccl:%null-ptr-p ,stored) + (dispose-ptr ,stored)))) ) (defmacro with-cstring ((cstring lisp-string) &body body) #+(or cmu sbcl scl lispworks) `(let ((,cstring ,lisp-string)) ,@body) #+allegro - (let ((acl-native (gensym))) - `(excl:with-native-string (,acl-native ,lisp-string) - (let ((,cstring (if ,lisp-string ,acl-native 0))) - ,@body))) + (let ((acl-native (gensym)) + (stored-lisp-string (gensym))) + `(let ((,stored-lisp-string ,lisp-string)) + (excl:with-native-string (,acl-native ,stored-lisp-string) + (let ((,cstring (if ,stored-lisp-string ,acl-native 0))) + ,@body)))) #+mcl - `(if (stringp ,lisp-string) - (ccl:with-cstrs ((,cstring ,lisp-string)) - ,@body) - (let ((,cstring +null-cstring-pointer+)) - ,@body)) + (let ((stored-lisp-string (gensym))) + `(let ((,stored-lisp-string ,lisp-string)) + (if (stringp ,stored-lisp-string) + (ccl:with-cstrs ((,cstring ,stored-lisp-string)) + ,@body) + (let ((,cstring +null-cstring-pointer+)) + ,@body)))) ) (defmacro with-cstrings (bindings &rest body) @@ -95,104 +107,130 @@ that LW/CMU automatically converts strings from c-calls." (defmacro convert-to-foreign-string (obj) #+lispworks - `(if (null ,obj) - +null-cstring-pointer+ - (fli:convert-to-foreign-string ,obj :external-format '(:latin-1 :eol-style :lf))) + (let ((stored (gensym))) + `(let ((,stored ,obj)) + `(if (null ,stored) + +null-cstring-pointer+ + (fli:convert-to-foreign-string + ,stored + :external-format '(:latin-1 :eol-style :lf))))) #+allegro - `(if (null ,obj) - 0 - (values (excl:string-to-native ,obj))) + (let ((stored (gensym))) + `(let ((,stored ,obj)) + (if (null ,stored) + 0 + (values (excl:string-to-native ,stored))))) #+(or cmu scl) (let ((size (gensym)) (storage (gensym)) + (stored-obj (gensym)) (i (gensym))) - `(etypecase ,obj - (null - (alien:sap-alien (system:int-sap 0) (* (alien:unsigned 8)))) - (string - (let* ((,size (length ,obj)) - (,storage (alien:make-alien (alien:unsigned 8) (1+ ,size)))) - (setq ,storage (alien:cast ,storage (* (alien:unsigned 8)))) - (locally - (declare (optimize (speed 3) (safety 0))) - (dotimes (,i ,size) - (declare (fixnum ,i)) - (setf (alien:deref ,storage ,i) (char-code (char ,obj ,i)))) + `(let ((,stored-obj ,obj)) + (etypecase ,stored-obj + (null + (alien:sap-alien (system:int-sap 0) (* (alien:unsigned 8)))) + (string + (let* ((,size (length ,stored-obj)) + (,storage (alien:make-alien (alien:unsigned 8) (1+ ,size)))) + (setq ,storage (alien:cast ,storage (* (alien:unsigned 8)))) + (locally + (declare (optimize (speed 3) (safety 0))) + (dotimes (,i ,size) + (declare (fixnum ,i)) + (setf (alien:deref ,storage ,i) + (char-code (char ,stored-obj ,i)))) (setf (alien:deref ,storage ,size) 0)) - ,storage)))) + ,storage))))) #+sbcl (let ((size (gensym)) (storage (gensym)) + (stored-obj (gensym)) (i (gensym))) - `(etypecase ,obj - (null - (sb-alien:sap-alien (sb-sys:int-sap 0) (* (sb-alien:unsigned 8)))) - (string - (let* ((,size (length ,obj)) - (,storage (sb-alien:make-alien (sb-alien:unsigned 8) (1+ ,size)))) - (setq ,storage (sb-alien:cast ,storage (* (sb-alien:unsigned 8)))) - (locally - (declare (optimize (speed 3) (safety 0))) - (dotimes (,i ,size) - (declare (fixnum ,i)) - (setf (sb-alien:deref ,storage ,i) (char-code (char ,obj ,i)))) - (setf (sb-alien:deref ,storage ,size) 0)) - ,storage)))) + `(let ((,stored-obj ,obj)) + (etypecase ,stored-obj + (null + (sb-alien:sap-alien (sb-sys:int-sap 0) (* (sb-alien:unsigned 8)))) + (string + (let* ((,size (length ,stored-obj)) + (,storage (sb-alien:make-alien (sb-alien:unsigned 8) (1+ ,size)))) + (setq ,storage (sb-alien:cast ,storage (* (sb-alien:unsigned 8)))) + (locally + (declare (optimize (speed 3) (safety 0))) + (dotimes (,i ,size) + (declare (fixnum ,i)) + (setf (sb-alien:deref ,storage ,i) + (char-code (char ,stored-obj ,i)))) + (setf (sb-alien:deref ,storage ,size) 0)) + ,storage))))) #+mcl - `(if (null ,obj) - +null-cstring-pointer+ - (let ((ptr (new-ptr (1+ (length ,obj))))) - (ccl::%put-cstring ptr ,obj) - ptr)) + (let ((stored-obj (gensym))) + `(let ((,stored-obj ,obj)) + (if (null ,stored-obj) + +null-cstring-pointer+ + (let ((ptr (new-ptr (1+ (length ,stored-obj))))) + (ccl::%put-cstring ptr ,stored-obj) + ptr)))) ) - ;; Either length or null-terminated-p must be non-nil (defmacro convert-from-foreign-string (obj &key length (locale :default) (null-terminated-p t)) #+allegro - `(if (zerop ,obj) - nil - (if (eq ,locale :none) - (fast-native-to-string ,obj ,length) - (values - (excl:native-to-string - ,obj - ,@(when length (list :length length)) - :truncate (not ,null-terminated-p))))) + (let ((stored-obj (gensym))) + `(let ((,stored-obj ,obj)) + (if (zerop ,stored-obj) + nil + (if (eq ,locale :none) + (fast-native-to-string ,stored-obj ,length) + (values + (excl:native-to-string + ,stored-obj + ,@(when length (list :length length)) + :truncate (not ,null-terminated-p))))))) #+lispworks - `(if (fli:null-pointer-p ,obj) - nil - (if (eq ,locale :none) - (fast-native-to-string ,obj ,length) - (fli:convert-from-foreign-string - ,obj - ,@(when length (list :length length)) - :null-terminated-p ,null-terminated-p - :external-format '(:latin-1 :eol-style :lf)))) + (let ((stored-obj (gensym))) + `(let ((,stored-obj ,obj)) + (if (fli:null-pointer-p ,stored-obj) + nil + (if (eq ,locale :none) + (fast-native-to-string ,stored-obj ,length) + (fli:convert-from-foreign-string + ,stored-obj + ,@(when length (list :length length)) + :null-terminated-p ,null-terminated-p + :external-format '(:latin-1 :eol-style :lf)))))) #+(or cmu scl) - `(if (null-pointer-p ,obj) - nil - (cmucl-naturalize-cstring (alien:alien-sap ,obj) - :length ,length - :null-terminated-p ,null-terminated-p)) + (let ((stored-obj (gensym))) + `(let ((,stored-obj ,obj)) + (if (null-pointer-p ,stored-obj) + nil + (cmucl-naturalize-cstring (alien:alien-sap ,stored-obj) + :length ,length + :null-terminated-p ,null-terminated-p)))) + #+sbcl - `(if (null-pointer-p ,obj) - nil - (sbcl-naturalize-cstring (sb-alien:alien-sap ,obj) - :length ,length - :null-terminated-p ,null-terminated-p)) + (let ((stored-obj (gensym))) + `(let ((,stored-obj ,obj)) + (if (null-pointer-p ,stored-obj) + nil + (sbcl-naturalize-cstring (sb-alien:alien-sap ,stored-obj) + :length ,length + :null-terminated-p ,null-terminated-p)))) #+mcl (declare (ignore null-terminated-p)) #+mcl - `(if (ccl:%null-ptr-p ,obj) - nil - #+(and mcl (not openmcl)) (ccl:%get-cstring ,obj 0 ,@(if length (list length) nil)) - #+openmcl ,@(if length - `((ccl:%str-from-ptr ,obj ,length)) - `((ccl:%get-cstring ,obj)))) + (let ((stored-obj (gensym))) + `(let ((,stored-obj ,obj)) + (if (ccl:%null-ptr-p ,stored-obj) + nil + #+(and mcl (not openmcl)) (ccl:%get-cstring + ,stored-obj 0 + ,@(if length (list length) nil)) + #+openmcl ,@(if length + `((ccl:%str-from-ptr ,stored-obj ,length)) + `((ccl:%get-cstring ,stored-obj)))))) ) -- 2.34.1