X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-posix%2Fmacros.lisp;h=2e15e10ef208f1fafcdda249ee753fd3d2800e67;hb=9fb8bf2eb2c91cbda313edaa3362ff8b221ab81d;hp=c69182694aa8246a7d932df11402409a9ffbeeda;hpb=607f3e366b0e5b5fb4606202a6a5f625c05c3838;p=sbcl.git diff --git a/contrib/sb-posix/macros.lisp b/contrib/sb-posix/macros.lisp index c691826..2e15e10 100644 --- a/contrib/sb-posix/macros.lisp +++ b/contrib/sb-posix/macros.lisp @@ -2,7 +2,8 @@ (define-designator filename c-string (pathname - (sb-ext:native-namestring (translate-logical-pathname filename))) + (sb-ext:native-namestring (translate-logical-pathname filename) + :as-file t)) (string filename)) (define-designator file-descriptor (integer 32) @@ -17,8 +18,37 @@ (null (sb-alien:sap-alien (sb-sys:int-sap 0) (* t))) ((alien (* t)) alien-pointer-to-anything-or-nil)) -(defun lisp-for-c-symbol (s) - (intern (substitute #\- #\_ (string-upcase s)) :sb-posix)) +(defun lisp-for-c-symbol (name) + (etypecase name + (list + (lisp-for-c-symbol (car name))) + (string + (let ((root (if (eql #\_ (char name 0)) (subseq name 1) name))) + (intern (substitute #\- #\_ (string-upcase root)) :sb-posix))))) + +;; Note: this variable is set in interface.lisp. defined here for +;; clarity and so the real-c-name compile as desired. +(defparameter *c-functions-in-runtime* nil) + +(defun real-c-name (name) + (let ((maybe-name + (etypecase name + (list + (destructuring-bind (name &key c-name options) name + (if c-name + c-name + (cond #+largefile + ((or (eql options :largefile) + (member :largefile options)) + (format nil "~a_largefile" name)) + (t + name))))) + (string + name)))) + (if (member maybe-name *c-functions-in-runtime* + :test #'string=) + (format nil "_~A" maybe-name) + maybe-name))) (defmacro define-call-internally (lisp-name c-name return-type error-predicate &rest arguments) @@ -49,11 +79,12 @@ `(sb-int:style-warn "Didn't find definition for ~S" ,c-name))) (defmacro define-call (name return-type error-predicate &rest arguments) - (let ((lisp-name (lisp-for-c-symbol name))) + (let ((lisp-name (lisp-for-c-symbol name)) + (real-c-name (real-c-name name))) `(progn (export ',lisp-name :sb-posix) (define-call-internally ,lisp-name - ,name + ,real-c-name ,return-type ,error-predicate ,@arguments))))