You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
208 lines
8.7 KiB
208 lines
8.7 KiB
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)
|