diff --git a/modules/berkeley-db/bdb.c b/modules/berkeley-db/bdb.c index a266d41..942652a 100644 --- a/modules/berkeley-db/bdb.c +++ b/modules/berkeley-db/bdb.c @@ -2216,7 +2216,13 @@ DEFUN(BDB:DB-COMPACT, db &key TRANSACTION :START STOP FREE FILL TIMEOUT \ c_data.compact_timeout = timeout; c_data.compact_pages = pages; SYSCALL(db->compact,(db,txn,pstart,pstop,&c_data,flags,&end)); - pushSTACK(uint32_to_I(c_data.compact_empty_buckets)); + /* ==== + * compact_empty_buckets is in bdb-5.3 as part of output stats + * however this version use bdb-4.8 which does not have it + * ==== + * + * pushSTACK(uint32_to_I(c_data.compact_empty_buckets)); + * */ pushSTACK(uint32_to_I(c_data.compact_pages_free)); pushSTACK(uint32_to_I(c_data.compact_pages_examine)); pushSTACK(uint32_to_I(c_data.compact_levels)); diff --git a/modules/bindings/glibc/linux.lisp b/modules/bindings/glibc/linux.lisp index c960753..2993990 100644 --- a/modules/bindings/glibc/linux.lisp +++ b/modules/bindings/glibc/linux.lisp @@ -1,7 +1,7 @@ ;; Foreign functions provided by the Linux C library version 6, ;; i.e. the GNU C library version 2.0.7. ;; Bruno Haible 10.4.1998, 19.4.1998 -;; Sam Steingold 2002-2008, 2011 +;; Sam Steingold 2002-2008, 2011, 2013, 2016-2017 ;; NB: quite a few functions here have more portable counterparts in POSIX @@ -649,7 +649,6 @@ (def-call-out calloc (:arguments (nmemb size_t) (size size_t)) (:return-type c-pointer)) (def-call-out free (:arguments (ptr c-pointer)) (:return-type nil)) -(def-call-out cfree (:arguments (ptr c-pointer)) (:return-type nil)) (def-call-out valloc (:arguments (size size_t)) (:return-type c-pointer)) (def-call-out abort (:arguments) (:return-type nil)) @@ -687,9 +686,8 @@ (def-call-out system? (:arguments (null c-string)) (:return-type boolean) (:name "system")) -; You can uncomment this if your compiler sets __USE_GNU -; (def-call-out canonicalize_file_name (:arguments (name c-string)) -; (:return-type c-string :malloc-free)) +(def-call-out canonicalize_file_name (:arguments (name c-string)) + (:return-type c-string :malloc-free) (:guard "defined(__USE_GNU)")) (def-call-out realpath (:arguments (name c-string) @@ -1041,9 +1039,8 @@ (def-call-out access (:arguments (name c-string) (type int)) (:return-type int)) -; You can uncomment this if your compiler sets __USE_GNU -; (def-call-out euidaccess (:arguments (name c-string) (type int)) -; (:return-type int)) +(def-call-out euidaccess (:arguments (name c-string) (type int)) + (:return-type int) (:guard "defined(__USE_GNU)")) (defconstant SEEK_SET 0) (defconstant SEEK_CUR 1) @@ -1094,9 +1091,8 @@ ;(def-call-out getcwd (:arguments (buf c-string :out) (size size_t)) ; ?? ; (:return-type c-string)) -; You can uncomment this if your compiler sets __USE_GNU -; (def-call-out get_current_dir_name (:arguments) -; (:return-type c-string :malloc-free)) +(def-call-out get_current_dir_name (:arguments) + (:return-type c-string :malloc-free) (:guard "defined(__USE_GNU)")) ;(def-call-out getwd (:arguments (buf c-string :out)) ; ?? ; (:return-type c-string)) @@ -1324,8 +1320,8 @@ ; (:arguments (size int) (list (c-ptr (c-array gid_t ??)) :out)) ; ?? ; (:return-type int)) -; You can uncomment this if your compiler sets __USE_GNU -; (def-call-out group_member (:arguments (gid gid_t)) (:return-type boolean)) +(def-call-out group_member (:arguments (gid gid_t)) (:return-type boolean) + (:guard "defined(__USE_GNU)")) (def-call-out setuid (:arguments (uid uid_t)) (:return-type int)) (def-call-out setreuid (:arguments (ruid uid_t) (euid uid_t)) (:return-type int)) @@ -1822,8 +1818,8 @@ (:return-type c-string :malloc-free)) (def-call-out ungetc (:arguments (c int) (fp FILE)) (:return-type int)) -; You can uncomment this if your compiler sets __USE_GNU -; (def-call-out fcloseall (:arguments) (:return-type int)) +(def-call-out fcloseall (:arguments) (:return-type int) + (:guard "defined(__USE_GNU)")) (def-call-out fdopen (:arguments (fildes int) (mode c-string)) (:return-type c-pointer)) (def-call-out fileno (:arguments (fp FILE)) (:return-type int)) @@ -1901,11 +1897,11 @@ typedef __off64_t clisp_dirent_off_t; (:return-type (c-ptr-null dirent))) (def-call-out readdir64 (:arguments (dirp c-pointer)) (:return-type (c-ptr-null dirent64))) -(def-call-out readdir_r +(def-call-out readdir_r ; deprecated (:arguments (dirp c-pointer) (entry (c-ptr dirent) :out :alloca) (result (c-ptr (c-ptr dirent)) :out :alloca)) ; ?? (:return-type int)) -(def-call-out readdir64_r +(def-call-out readdir64_r ; deprecated (:arguments (dirp c-pointer) (entry (c-ptr dirent64) :out :alloca) (result (c-ptr (c-ptr dirent64)) :out :alloca)) ; ?? (:return-type int)) diff --git a/modules/bindings/glibc/test.tst b/modules/bindings/glibc/test.tst index f807389..b2c1222 100644 --- a/modules/bindings/glibc/test.tst +++ b/modules/bindings/glibc/test.tst @@ -5,6 +5,16 @@ (progn (require "linux") T) T (listp (show (multiple-value-list (ext:module-info "linux" t)) :pretty t)) T +(stringp (show (linux:get-domain-name))) T +(stringp (show (linux:get-host-name))) T + +;; usually __USE_GNU is defined, so this should work: +(let* ((d (linux:get_current_dir_name)) + (c (linux:canonicalize_file_name (concatenate 'string d "/.")))) + (or (string= d c) + (list :cur-dir d :canonical c))) +T + (defparameter *d* (show (linux:opendir "."))) *D* (linux:dirent64-d_name (show (linux:readdir64 *d*))) "." (linux:dirent64-d_name (show (linux:readdir64 *d*))) ".." diff --git a/src/foreign1.lisp b/src/foreign1.lisp index 26a3ba5..0e43de7 100644 --- a/src/foreign1.lisp +++ b/src/foreign1.lisp @@ -1,6 +1,6 @@ ;;; Foreign function interface for CLISP ;;; Bruno Haible 19.2.1995 -;;; Sam Steingold 1998-2010 +;;; Sam Steingold 1998-2010, 2017 #+UNICODE (progn @@ -805,14 +805,17 @@ c-name (to-c-string c-name) (third variable) (first variable)) (when *foreign-guard* (format *coutput-stream* "# endif~%")))) (dolist (function *function-list*) - (let ((c-name (first function))) - (when *foreign-guard* - (format *coutput-stream* "# if defined(HAVE_~A)~%" - (string-upcase c-name))) + (let ((c-name (first function)) + (guard (fourth function))) + (when guard + (format *coutput-stream* "# if ~A~%" + (if (eq guard t) + (format nil "defined(HAVE_~A)" (string-upcase c-name)) + guard))) (format *coutput-stream* " register_foreign_function((void*)&~A,~A,~D);~%" c-name (to-c-string c-name) (svref (second function) 3)) - (when *foreign-guard* (format *coutput-stream* "# endif~%")))) + (when guard (format *coutput-stream* "# endif~%")))) (maphash (lambda (type fun-vec) (declare (ignore type)) (let ((c-name (to-c-name (car fun-vec)))) @@ -1083,7 +1086,7 @@ (defmacro DEF-CALL-OUT (&whole whole-form name &rest options) (setq name (check-symbol name (first whole-form))) (let* ((alist - (parse-options options '(:name :arguments :return-type :language + (parse-options options '(:name :arguments :return-type :language :guard :built-in :library :version :documentation) whole-form)) (def (gensym "DEF-CALL-OUT-")) @@ -1095,6 +1098,7 @@ (version (second (assoc :version alist))) (c-name (foreign-name name (assoc :name alist))) (built-in (second (assoc :built-in alist))) + (guard (get-assoc :guard alist '*foreign-guard*)) ;; Maximize sharing in .fas file, reuse options ;; parse-c-function ignores unknown options, e.g. :name (ctype `(PARSE-C-FUNCTION ',options ',whole-form))) @@ -1102,7 +1106,7 @@ ',c-name ,ctype ',properties ,library ,version NIL))) (EXT:COMPILER-LET ((,def ,ctype)) (EVAL-WHEN (COMPILE) - (UNLESS ,LIBRARY (NOTE-C-FUN ',c-name ,def ',built-in))) + (UNLESS ,LIBRARY (NOTE-C-FUN ',c-name ,def ',built-in ,guard))) (SYSTEM::EVAL-WHEN-COMPILE (SYSTEM::C-DEFUN ',name (C-TYPE-TO-SIGNATURE ,ctype)))) (WHEN ,def ; found library function @@ -1110,10 +1114,10 @@ (SYSTEM::%PUTD ',name ,def)) ',name))) -(defun note-c-fun (c-name ctype built-in) ; not ABI, compile-time only +(defun note-c-fun (c-name ctype built-in guard) ; not ABI, compile-time only (when (system::prepare-coutput-file) (prepare-module) - (push (list c-name ctype built-in) + (push (list c-name ctype built-in guard) *function-list*))) (defun count-inarguments (arg-vector)