clisp-cvs digest, Vol 1 #871 - 7 msgs

[<cli...@li...>]

Send clisp-cvs mailing list submissions to
	cli...@li...

To subscribe or unsubscribe via the World Wide Web, visit
	https://lists.sourceforge.net/lists/listinfo/clisp-cvs
or, via email, send a message with subject or body 'help' to
	cli...@li...

You can reach the person managing the list at
	cli...@li...

When replying, please edit your Subject line so it is more specific
than "Re: Contents of clisp-cvs digest..."


CLISP CVS commits for today

Today's Topics:

   1. clisp/src ChangeLog,1.3977,1.3978 (Bruno Haible)
   2. clisp/src exporting.lisp,NONE,1.1 (Bruno Haible)
   3. clisp/modules exporting.lisp,1.2,NONE (Bruno Haible)
   4. clisp/modules/postgresql postgresql.lisp,1.7,1.8 (Bruno Haible)
   5. clisp/modules/bindings/win32 win32.lisp,1.10,1.11 (Bruno Haible)
   6. clisp/modules/bindings/glibc linux.lisp,1.14,1.15 wrap.lisp,1.2,1.3 (Bruno Haible)
   7. clisp/modules/netica netica.lisp,1.8,1.9 wrap.lisp,1.6,1.7 (Bruno Haible)

--__--__--

Message: 1
From: Bruno Haible <ha...@us...>
To: cli...@li...
Subject: clisp/src ChangeLog,1.3977,1.3978
Date: Mon, 20 Dec 2004 14:10:35 +0000
Reply-To: cli...@li...

Update of /cvsroot/clisp/clisp/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv22596/src

Modified Files:
	ChangeLog 
Log Message:
Revisit the test failures.


Index: ChangeLog
===================================================================
RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v
retrieving revision 1.3977
retrieving revision 1.3978
diff -u -d -r1.3977 -r1.3978
--- ChangeLog	20 Dec 2004 14:09:13 -0000	1.3977
+++ ChangeLog	20 Dec 2004 14:10:31 -0000	1.3978
@@ -1,5 +1,9 @@
 2004-12-19  Bruno Haible  <br...@cl...>
 
+	* utils/clispload.lsp (*expected-failures*): Revisited.
+
+2004-12-19  Bruno Haible  <br...@cl...>
+
 	* format.lisp (formatter-main-1): In ~{, when the max-n-iterations
 	prefix is not known to be a number, test it against nil before
 	comparing it.



--__--__--

Message: 2
From: Bruno Haible <ha...@us...>
To: cli...@li...
Subject: clisp/src exporting.lisp,NONE,1.1
Date: Mon, 20 Dec 2004 14:13:33 +0000
Reply-To: cli...@li...

Update of /cvsroot/clisp/clisp/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv23424/src

Added Files:
	exporting.lisp 
Log Message:
Macros that export their definiendum.


--- NEW FILE: exporting.lisp ---
;;; Macros that export their definiendum
;;; Bruno Haible 2004-12-15

(defpackage "EXPORTING" (:nicknames "XP")
  (:use "COMMON-LISP")
  (:shadow . #1=(defconstant defparameter defvar define-symbol-macro
                 defun defgeneric defmethod define-compiler-macro defsetf
                 define-setf-expander defmacro define-modify-macro
                 deftype defstruct defclass define-condition
                 define-method-combination
                 #+FFI def-c-type #+FFI def-c-enum #+FFI def-c-struct
                 #+FFI def-c-var
                 #+FFI def-c-call-out #+FFI def-call-out #+AFFI def-lib-call-out))
  (:export . #1#))

(in-package "EXPORTING")

;; Macros for the variable namespace.

(cl:defmacro defconstant (&whole whole
                          name initial-value &optional documentation)
  (declare (ignore initial-value documentation))
  `(PROGN
     (EXPORT ',(or name '(NIL)))
     (CL:DEFCONSTANT ,name ,@(cddr whole))))

(cl:defmacro defparameter (&whole whole
                           name initial-value &optional documentation)
  (declare (ignore initial-value documentation))
  `(PROGN
     (EXPORT ',(or name '(NIL)))
     (CL:DEFPARAMETER ,name ,@(cddr whole))))

(cl:defmacro defvar (&whole whole
                     name &optional initial-value documentation)
  (declare (ignore initial-value documentation))
  `(PROGN
     (EXPORT ',(or name '(NIL)))
     (CL:DEFVAR ,name ,@(cddr whole))))

(cl:defmacro define-symbol-macro (symbol expansion)
  `(PROGN
     (EXPORT ',(or symbol '(NIL)))
     (CL:DEFINE-SYMBOL-MACRO ,symbol ,expansion)))

;; Macros for the function namespace.

(cl:defmacro defun (name lambda-list &body body)
  `(PROGN
     (EXPORT ',(or (sys::function-block-name name) '(NIL)))
     (CL:DEFUN ,name ,lambda-list ,@body)))

(cl:defmacro defgeneric (name lambda-list &rest options)
  `(PROGN
     (EXPORT ',(or (sys::function-block-name name) '(NIL)))
     (CL:DEFGENERIC ,name ,lambda-list ,@options)))

(cl:defmacro defmethod (name &rest definition)
  `(PROGN
     (EXPORT ',(or (sys::function-block-name name) '(NIL)))
     (CL:DEFMETHOD ,name ,@definition)))

(cl:defmacro define-compiler-macro (name lambda-list &body body)
  `(PROGN
     (EXPORT ',(or (sys::function-block-name name) '(NIL)))
     (CL:DEFINE-COMPILER-MACRO ,name ,lambda-list ,@body)))

(cl:defmacro defsetf (name &rest definition)
  `(PROGN
     (EXPORT ',(or name '(NIL)))
     (CL:DEFSETF ,name ,@definition)))

(cl:defmacro define-setf-expander (name lambda-list &body body)
  `(PROGN
     (EXPORT ',(or name '(NIL)))
     (CL:DEFINE-SETF-EXPANDER ,name ,lambda-list ,@body)))

(cl:defmacro defmacro (name lambda-list &body body)
  `(PROGN
     (EXPORT ',(or name '(NIL)))
     (CL:DEFMACRO ,name ,lambda-list ,@body)))

(cl:defmacro define-modify-macro (&whole whole
                                  name lambda-list function &optional documentation)
  (declare (ignore lambda-list function documentation))
  `(PROGN
     (EXPORT ',(or name '(NIL)))
     (CL:DEFINE-MODIFY-MACRO ,name ,@(cddr whole))))

;; Macros for the type namespace.

(cl:defmacro deftype (name lambda-list &body body)
  `(PROGN
     (EXPORT ',(or name '(NIL)))
     (CL:DEFTYPE ,name ,lambda-list ,@body)))

(cl:defmacro defstruct (name+options &rest slots)
  (let ((name (if (consp name+options) (first name+options) name+options)))
    `(PROGN
       (EXPORT '(,name
                 ,@(let ((constructor-option-list nil)
                         (copier-option 0)
                         (predicate-option 0))
                     (when (consp name+options)
                       (dolist (option (rest name+options))
                         (if (or (eq option ':CONSTRUCTOR) (equal option '(:CONSTRUCTOR)))
                           (push (sys::concat-pnames "MAKE-" name) constructor-option-list)
                           (when (and (consp option) (consp (cdr option)))
                             (case (first option)
                               (:CONSTRUCTOR (push (second option) constructor-option-list))
                               (:COPIER (setq copier-option (second option)))
                               (:PREDICATE (setq predicate-option (second option))))))))
                     (nconc (if constructor-option-list
                              (delete 'NIL constructor-option-list)
                              (list (sys::concat-pnames "MAKE-" name)))
                            (when copier-option
                              (list (if (eql copier-option 0)
                                      (sys::concat-pnames "COPY-" name)
                                      copier-option)))
                            (when predicate-option
                              (list (if (eql predicate-option 0)
                                      (sys::concat-pnames name "-P")
                                      predicate-option)))))
                 ,@(let ((conc-name-option 0))
                     (when (consp name+options)
                       (dolist (option (rest name+options))
                         (when (and (consp option) (consp (cdr option))
                                    (eq (first option) ':CONC-NAME))
                           (setq conc-name-option (second option)))))
                     (when (eql conc-name-option 0)
                       (setq conc-name-option (sys::string-concat (string name) "-")))
                     (mapcar #'(lambda (slot-spec)
                                 (sys::ds-accessor-name
                                   (if (consp slot-spec) (first slot-spec) slot-spec)
                                   conc-name-option))
                             slots))))
       (CL:DEFSTRUCT ,name+options ,@slots))))

(cl:defun slot-definition-accessor-symbols (slot)
  (mapcar #'sys::function-block-name
          (append (clos:slot-definition-readers slot)
                  (clos:slot-definition-writers slot))))

(cl:defun all-accessor-symbols (direct-slot-list)
  (mapcan #'slot-definition-accessor-symbols direct-slot-list))

(cl:defun class-accessor-symbols (class) ; ABI
  (all-accessor-symbols (clos:class-direct-slots class)))

(cl:defmacro defclass (name superclasses slot-specs &rest options)
  `(PROGN
     (EXPORT ',(or name '(NIL)))
     (LET ((C (CL:DEFCLASS ,name ,superclasses ,slot-specs ,@options)))
       (EXPORT (CLASS-ACCESSOR-SYMBOLS C))
       C)))

(cl:defmacro define-condition (name parent-types slot-specs &rest options)
  `(PROGN
     (EXPORT '(,name
               ,@(mapcan #'(lambda (slot-spec)
                             (when (consp slot-spec)
                               (let ((symbols '()))
                                 (do ((slot-options (cdr slot-spec) (cddr slot-options)))
                                     ((endp slot-options))
                                   (when (sys::memq (first slot-options)
                                                    '(:READER :WRITER :ACCESSOR))
                                     (push (sys::function-block-name (second slot-options))
                                           symbols)))
                                 (nreverse symbols))))
                         slot-specs)))
     (CL:DEFINE-CONDITION ,name ,parent-types ,slot-specs ,@options)))

;; Macros for the method-combination namespace.

(cl:defmacro define-method-combination (name &rest definition)
  `(PROGN
     (EXPORT ',(or name '(NIL)))
     (CL:DEFINE-METHOD-COMBINATION ,name ,@definition)))

;; FFI.

#+FFI
(cl:defmacro def-c-type (name typespec)
  `(PROGN
     (EXPORT ',(or name '(NIL)))
     (FFI:DEF-C-TYPE ,name ,typespec)))

#+FFI
(cl:defmacro def-c-enum (name &rest items)
  `(PROGN
     (EXPORT '(,name ,@(mapcar #'(lambda (item) (if (consp item) (first item) item))
                               items)))
     (FFI:DEF-C-ENUM ,name ,@items)))

#+FFI
(cl:defmacro def-c-struct (name+options &rest slots)
  (let ((name (if (consp name+options) (first name+options) name+options)))
    `(PROGN
       (EXPORT '(,name
                 ,(sys::concat-pnames "MAKE-" name)
                 ,(sys::concat-pnames "COPY-" name)
                 ,(sys::concat-pnames "-P" name)
                 ,@(let ((concname (sys::string-concat (string name) "-")))
                     (mapcar #'(lambda (slot)
                                 (let ((slotname (first slot)))
                                   (sys::concat-pnames concname slotname)))
                             slots))))
       (FFI:DEF-C-STRUCT ,name+options ,@slots))))

#+FFI
(cl:defmacro def-c-var (name &rest options)
  `(PROGN
     (EXPORT ',(or name '(NIL)))
     (FFI:DEF-C-VAR ,name ,@options)))

#+FFI
(cl:defmacro def-c-call-out (name &rest options)
  `(PROGN
     (EXPORT ',(or name '(NIL)))
     (FFI:DEF-C-CALL-OUT ,name ,@options)))

#+FFI
(cl:defmacro def-call-out (name &rest options)
  `(PROGN
     (EXPORT ',(or name '(NIL)))
     (FFI:DEF-CALL-OUT ,name ,@options)))

#+AFFI
(cl:defmacro def-lib-call-out (name library &rest options)
  `(PROGN
     (EXPORT ',(or name '(NIL)))
     (FFI:DEF-LIB-CALL-OUT ,name ,library ,@options)))

#| ;; def-c-call-in and def-call-in don't actually define anything; they are
   ;; more like declarations.

#+FFI
(cl:defmacro def-c-call-in (name &rest options)
  `(PROGN
     (EXPORT ',(or name '(NIL)))
     (FFI:DEF-C-CALL-IN ,name ,@options)))

#+FFI
(cl:defmacro def-call-in (name &rest options)
  `(PROGN
     (EXPORT ',(or name '(NIL)))
     (FFI:DEF-CALL-IN ,name ,@options)))

|#



--__--__--

Message: 3
From: Bruno Haible <ha...@us...>
To: cli...@li...
Subject: clisp/modules exporting.lisp,1.2,NONE
Date: Mon, 20 Dec 2004 14:14:16 +0000
Reply-To: cli...@li...

Update of /cvsroot/clisp/clisp/modules
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv23493/modules

Removed Files:
	exporting.lisp 
Log Message:
Replaced with src/exporting.lisp and the use of case-inverted packages.


--- exporting.lisp DELETED ---



--__--__--

Message: 4
From: Bruno Haible <ha...@us...>
To: cli...@li...
Subject: clisp/modules/postgresql postgresql.lisp,1.7,1.8
Date: Mon, 20 Dec 2004 14:15:34 +0000
Reply-To: cli...@li...

Update of /cvsroot/clisp/clisp/modules/postgresql
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv23645/modules/postgresql

Modified Files:
	postgresql.lisp 
Log Message:
Define package as case-inverted.
Use some symbols from package EXPORTING; drop old exporting code.
Remove useless package prefixes.


Index: postgresql.lisp
===================================================================
RCS file: /cvsroot/clisp/clisp/modules/postgresql/postgresql.lisp,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -d -r1.7 -r1.8
--- postgresql.lisp	27 Sep 2004 00:19:50 -0000	1.7
+++ postgresql.lisp	20 Dec 2004 14:15:31 -0000	1.8
@@ -3,20 +3,12 @@
 (pushnew :PostgreSQL *features*)
 
 (defpackage "SQL"
-  (:case-sensitive t)
   (:nicknames "POSTGRES" "POSTGRESQL")
-  (:use))
-
-(eval-when (compile eval)
-  (require "exporting" "../exporting")
-  (make-exporting "SQL"
-    cl:compile cl:eval cl:load cl:defconstant
-    ffi:bitsizeof ffi:boolean ffi:char ffi:character ffi:c-array
-    ffi:c-array-max ffi:c-array-ptr ffi:c-function ffi:c-ptr ffi:c-pointer
-    ffi:c-string ffi:c-struct ffi:deref ffi:double-float ffi:element ffi:int
-    ffi:long ffi:nil ffi:short ffi:sint8 ffi:sint16 ffi:sint32 ffi:sint64
-    ffi:single-float ffi:sizeof ffi:slot ffi:uchar ffi:uint ffi:uint8
-    ffi:uint16 ffi:uint32 ffi:uint64 ffi:ulong ffi:ushort))
+  (:case-sensitive t) (:case-inverted t)
+  (:use "CS-COMMON-LISP" "FFI")
+  (:shadowing-import-from "EXPORTING"
+           #:defconstant #:defun #:defmacro
+           #:def-c-type #:def-c-enum #:def-c-struct #:def-c-var #:def-call-out))
 
 (in-package "SQL")
 
@@ -396,5 +388,4 @@
 ;; Get encoding id from environment variable PGCLIENTENCODING
 (def-call-out PQenv2encoding (:return-type int) (:arguments))
 
-(cl:in-package "CL-USER")
 (provide "postgresql")



--__--__--

Message: 5
From: Bruno Haible <ha...@us...>
To: cli...@li...
Subject: clisp/modules/bindings/win32 win32.lisp,1.10,1.11
Date: Mon, 20 Dec 2004 14:15:32 +0000
Reply-To: cli...@li...

Update of /cvsroot/clisp/clisp/modules/bindings/win32
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv23645/modules/bindings/win32

Modified Files:
	win32.lisp 
Log Message:
Define package as case-inverted.
Use some symbols from package EXPORTING; drop old exporting code.
Remove useless package prefixes.


Index: win32.lisp
===================================================================
RCS file: /cvsroot/clisp/clisp/modules/bindings/win32/win32.lisp,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -d -r1.10 -r1.11
--- win32.lisp	27 Sep 2004 00:19:51 -0000	1.10
+++ win32.lisp	20 Dec 2004 14:15:29 -0000	1.11
@@ -2,21 +2,12 @@
 ;; Sam Steingold 2003
 
 (defpackage "WIN32"
-  (:case-sensitive t)
   (:nicknames "WOE32" "W32")
-  (:use))
-
-(eval-when (compile eval)
-  (require "exporting" "../../exporting")
-  (make-exporting "WIN32"
-    cl:compile cl:defconstant cl:eval cl:load
-    ffi:cast ffi:char ffi:character ffi:c-array ffi:c-array-max
-    ffi:c-array-ptr ffi:c-function ffi:c-ptr ffi:c-ptr-null ffi:c-pointer
-    ffi:c-string ffi:c-struct ffi:deref ffi::foreign-value ffi:double-float
-    ffi:element ffi:int ffi:long ffi:nil ffi:short ffi:sint8 ffi:sint16
-    ffi:sint32 ffi:sint64 ffi:single-float ffi:sizeof ffi:slot ffi:uchar
-    ffi:uint ffi:uint8 ffi:uint16 ffi:uint32 ffi:uint64 ffi:ulong ffi:ushort
-    ffi:boolean ffi:with-c-var))
+  (:case-sensitive t) (:case-inverted t)
+  (:use "CS-COMMON-LISP" "FFI")
+  (:shadowing-import-from "EXPORTING"
+           #:defconstant #:defun #:defmacro
+           #:def-c-type #:def-c-enum #:def-c-struct #:def-c-var #:def-call-out))
 
 (ffi:default-foreign-language :stdc)
 
@@ -277,6 +268,5 @@
 |#
 
 ;;; ==========================================================================
-;;; clean up
-(lisp:in-package "CL-USER")
+
 (provide "win32")



--__--__--

Message: 6
From: Bruno Haible <ha...@us...>
To: cli...@li...
Subject: clisp/modules/bindings/glibc linux.lisp,1.14,1.15 wrap.lisp,1.2,1.3
Date: Mon, 20 Dec 2004 14:15:31 +0000
Reply-To: cli...@li...

Update of /cvsroot/clisp/clisp/modules/bindings/glibc
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv23645/modules/bindings/glibc

Modified Files:
	linux.lisp wrap.lisp 
Log Message:
Define package as case-inverted.
Use some symbols from package EXPORTING; drop old exporting code.
Remove useless package prefixes.


Index: wrap.lisp
===================================================================
RCS file: /cvsroot/clisp/clisp/modules/bindings/glibc/wrap.lisp,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- wrap.lisp	1 Nov 2004 15:28:40 -0000	1.2
+++ wrap.lisp	20 Dec 2004 14:15:29 -0000	1.3
@@ -1,23 +1,8 @@
 ;;; Lisp wrappers for the GLIBC FFI
 
-(in-package "SYS")
-
 (require "linux")
 
-(defpackage "LINUX"
-  (:case-sensitive t)
-  (:nicknames "UNIX" "GLIBC")
-  (:use)
-  (:export "real-path" "get-host-name" "get-domain-name"
-           "linux-error" "check-res"
-           "signal-valid-p" "signal-action-retrieve" "signal-action-install"
-           "sa-handler" "sa-flags" "sa-mask" "sigset-empty" "sigset-fill"
-           "sigset-add" "sigset-del" "sigset-member-p" "set-sigprocmask"
-           "sigset-pending" "set-signal-handler"))
-
-(eval-when (compile load eval)
-  (setf (package-lock "SYS") nil))
-(push "LINUX" *system-package-list*)
+(in-package "LINUX")
 
 ;; if you think you need this, you should use (array character)
 ;; instead of (array char)
@@ -26,146 +11,144 @@
 ;;  (convert-string-from-bytes vec *foreign-encoding*
 ;;                             :end (position 0 vec)))
 
-(defun linux:linux-error (caller)
-  (error "~s: ~a" caller (linux::strerror linux::errno)))
-(defmacro linux:check-res (res caller)
-  `(unless (zerop ,res) (linux:linux-error ,caller)))
+(defun linux-error (caller)
+  (error "~s: ~a" caller (strerror errno)))
+(defmacro check-res (res caller)
+  `(unless (zerop ,res) (linux-error ,caller)))
 
-(defun linux:real-path (name)
+(defun real-path (name)
   (multiple-value-bind (success resolved)
       ;; :out or :in-out parameters are returned via multiple values
-      (linux::realpath name)
-    (unless success (linux:linux-error 'linux:real-path))
+      (realpath name)
+    (unless success (linux-error 'real-path))
     resolved))
 
-(defun linux:get-host-name ()
+(defun get-host-name ()
   (multiple-value-bind (success name)
       ;; :out or :in-out parameters are returned via multiple values
-      (linux::gethostname linux::MAXHOSTNAMELEN)
-    (linux:check-res success 'linux:get-host-name)
+      (gethostname MAXHOSTNAMELEN)
+    (check-res success 'get-host-name)
     name))
 
-(defun linux:get-domain-name ()
+(defun get-domain-name ()
   (multiple-value-bind (success name)
       ;; :out or :in-out parameters are returned via multiple values
-      (linux::getdomainname linux::MAXHOSTNAMELEN)
-    (linux:check-res success 'linux:get-domain-name)
+      (getdomainname MAXHOSTNAMELEN)
+    (check-res success 'get-domain-name)
     name))
 
 ;; convenience functions for ffi sigaction definitions
 ;; Peter Wood 2002
 
-(defun linux:signal-valid-p (signal)
+(defun signal-valid-p (signal)
   "Is SIGNAL valid for this machine?"
-  (zerop (linux::sigaction-new signal nil nil)))
+  (zerop (sigaction-new signal nil nil)))
 
-(defun linux:signal-action-retrieve (signal)
+(defun signal-action-retrieve (signal)
   "Return the presently installed sigaction structure for SIGNAL"
-  (multiple-value-bind (ret act) (linux::sigaction-old signal nil)
-    (linux:check-res ret 'linux:signal-action-retrieve)
+  (multiple-value-bind (ret act) (sigaction-old signal nil)
+    (check-res ret 'signal-action-retrieve)
     act))
 
-(defun linux:signal-action-install (signal newact)
+(defun signal-action-install (signal newact)
   "Install NEWACT as the sigaction structure for SIGNAL. Error on failure."
-  (linux:check-res (linux::sigaction-new signal newact nil)
-                   'linux:signal-action-install))
+  (check-res (sigaction-new signal newact nil) 'signal-action-install))
 
-(defun linux:sa-handler (sigact)
+(defun sa-handler (sigact)
   "Returns the signal handler function for SIGACT struct. SETF place."
-  (slot-value sigact 'linux::sa_handler))
-(defsetf linux:sa-handler (sigact) (handler)
-  `(setf (slot-value ,sigact 'linux::sa_handler) ,handler))
+  (slot-value sigact 'sa_handler))
+(defsetf sa-handler (sigact) (handler)
+  `(setf (slot-value ,sigact 'sa_handler) ,handler))
 
-(defun linux:sa-flags (sigact)
+(defun sa-flags (sigact)
   "Returns the sa_flags for SIGACT struct. SETF place."
-  (slot-value sigact 'linux::sa_flags))
-(defsetf linux:sa-flags (sigact) (newflags)
-  `(setf (slot-value ,sigact 'linux::sa_flags) ,newflags))
+  (slot-value sigact 'sa_flags))
+(defsetf sa-flags (sigact) (newflags)
+  `(setf (slot-value ,sigact 'sa_flags) ,newflags))
 
 ;; e.g.: (setf (sa-flags SIGACT) (logior SA_RESETHAND SA_NOCLDSTOP))
 
-(defun linux:sa-mask (sigact)
+(defun sa-mask (sigact)
   "Returns the sa_mask for SIGACT struct. SETF place."
-  (slot-value sigact 'linux::sa_mask))
-(defsetf linux:sa-mask (sigact) (mask)
-  `(setf (slot-value ,sigact 'linux::sa_mask) ,mask))
+  (slot-value sigact 'sa_mask))
+(defsetf sa-mask (sigact) (mask)
+  `(setf (slot-value ,sigact 'sa_mask) ,mask))
 
-(defun linux:sigset-empty ()
+(defun sigset-empty ()
   "Return an empty sigset."
-  (multiple-value-bind (ret act) (linux::sigemptyset)
-    (linux:check-res ret 'linux:sigset-empty)
+  (multiple-value-bind (ret act) (sigemptyset)
+    (check-res ret 'sigset-empty)
     act))
 
-(defun linux:sigset-fill ()
+(defun sigset-fill ()
   "Return a full sigset"
-  (multiple-value-bind (ret set) (linux::sigfillset)
-    (linux:check-res ret 'linux:sigset-fill)
+  (multiple-value-bind (ret set) (sigfillset)
+    (check-res ret 'sigset-fill)
     set))
 
-(defun linux:sigset-add (set signal)
+(defun sigset-add (set signal)
   "Return a new set with SIGNAL"
-  (multiple-value-bind (ret set) (linux::sigaddset set signal)
-    (linux:check-res ret 'linux:sigset-add)
+  (multiple-value-bind (ret set) (sigaddset set signal)
+    (check-res ret 'sigset-add)
     set))
 
-(defun linux:sigset-del (set signal)
+(defun sigset-del (set signal)
   "Return a new set without SIGNAL"
-  (multiple-value-bind (ret set) (linux::sigdelset set signal)
-    (linux:check-res ret 'linux:sigset-del)
+  (multiple-value-bind (ret set) (sigdelset set signal)
+    (check-res ret 'sigset-del)
     set))
 
-(defun linux:sigset-member-p (set signal)
+(defun sigset-member-p (set signal)
   "T if SIGNAL is a member of SET, otherwise NIL"
-  (not (zerop (linux::sigismember set signal))))
+  (not (zerop (sigismember set signal))))
 
-(defun linux:set-sigprocmask (act set)
+(defun set-sigprocmask (act set)
   ;; NB the result of this will not be 'visible' in the sigaction
   ;; struct which contains SET, although the ACT *will* be performed.
-  ;; If you want a visible result, see linux:sigprocmask-set-n-save,
+  ;; If you want a visible result, see sigprocmask-set-n-save,
   ;; which returns as 2nd value the set structure resulting from ACT.
   "Do ACT on SET. Returns NIL on success and signals an error on failure."
-  (linux:check-res (linux::sigprocmask-set act set nil)
-                   'linux:set-sigprocmask))
+  (check-res (sigprocmask-set act set nil) 'set-sigprocmask))
 
-(defun linux:sigset-pending ()
+(defun sigset-pending ()
   "Returns the set of pending signals. Nil on failure"
-  (multiple-value-bind (ret set) (linux::sigpending)
-    (linux:check-res ret 'linux:sigset-pending)
+  (multiple-value-bind (ret set) (sigpending)
+    (check-res ret 'sigset-pending)
     set))
 
-(defun linux:set-signal-handler (signal fn)
+(defun set-signal-handler (signal fn)
   "Sets FN as signal handler for SIGNAL.  Returns old signal handler."
-  (let* ((sigact (linux:signal-action-retrieve signal)) ; the current sigact
-         (oh (linux:sa-handler sigact))) ; save the old handler to return
-    (setf (linux:sa-handler sigact) fn) ; make fn be the handler in sigact
-    (linux:signal-action-install signal sigact) ; install
+  (let* ((sigact (signal-action-retrieve signal)) ; the current sigact
+         (oh (sa-handler sigact))) ; save the old handler to return
+    (setf (sa-handler sigact) fn) ; make fn be the handler in sigact
+    (signal-action-install signal sigact) ; install
     oh))                        ; return the old handler
 
 #| signal handling examples:
 
 ;;; changing signal handlers:
 
- (setf oldsigact (linux:signal-action-retrieve linux:SIGINT))
+ (setf oldsigact (signal-action-retrieve SIGINT))
 #S(LINUX:sigaction :|sa_handler| #<FOREIGN-FUNCTION #x080711D4>
    :|sa_mask| #S(LINUX:sigset_t :|val| #(2)) :|sa_flags| 335544320
    :|sa_restorer| #<FOREIGN-FUNCTION #x401F1868>)
- (setf savehandler (linux:sa-handler oldsigact))
+ (setf savehandler (sa-handler oldsigact))
 #<FOREIGN-FUNCTION #x080711D4>
 ;; this is example is _BAD_ because one cannot do i/o in handlers
 ;; <https://sourceforge.net/mailarchive/message.php?msg_id=3599878>
  (defun test-handler (s) (format t "~&~s: signal ~d~%" 'test-handler s))
- (setf (linux:sa-handler oldsigact) #'test-handler)
- (linux:signal-action-install linux:SIGINT oldsigact)
+ (setf (sa-handler oldsigact) #'test-handler)
+ (signal-action-install SIGINT oldsigact)
 ;; Now Ctrl-C invokes TEST-HANDLER
- (setf (linux:sa-handler oldsigact) savehandler)
- (linux:signal-action-install linux:SIGINT oldsigact)
+ (setf (sa-handler oldsigact) savehandler)
+ (signal-action-install SIGINT oldsigact)
 ;; the standard behavior is restored
 
-;; this is packaged into linux:set-signal-handler:
- (setf savehandler (linux:set-signal-handler linux:SIGINT #'test-handler))
- (linux:raise linux:SIGINT)
+;; this is packaged into set-signal-handler:
+ (setf savehandler (set-signal-handler SIGINT #'test-handler))
+ (raise SIGINT)
 ;; TEST-HANDLER is called
- (linux:set-signal-handler linux:SIGINT savehandler)
+ (set-signal-handler SIGINT savehandler)
 ;; the standard behavior is restored
 
 ;; Please note that if you use SA_RESETHAND, you reset the handler to
@@ -174,21 +157,20 @@
 
 ;;; sigprocmask & sigpending
 
- (setf sigact (linux:signal-action-retrieve linux:SIGINT))
- (linux:raise linux:SIGINT)
+ (setf sigact (signal-action-retrieve SIGINT))
+ (raise SIGINT)
 ;; ** - Continuable Error/PRINT: User break
- (linux:set-sigprocmask linux:SIG_BLOCK (linux:sa-mask sigact))
- (linux:raise linux:SIGINT)
+ (set-sigprocmask SIG_BLOCK (sa-mask sigact))
+ (raise SIGINT)
 ;; nothing
- (linux:sigset-pending)
+ (sigset-pending)
 #S(LINUX:sigset_t :|val| #(2))
- (linux:set-sigprocmask linux:SIG_UNBLOCK (linux:sa-mask sigact))
+ (set-sigprocmask SIG_UNBLOCK (sa-mask sigact))
 ;; ** - Continuable Error/EVAL: User break
- (linux:sigset-pending)
+ (sigset-pending)
 #S(LINUX:sigset_t :|val| #())
- (linux:raise linux:SIGINT)
+ (raise SIGINT)
 ;; ** - Continuable Error/PRINT: User break
 ;; |#
 
-(eval-when (compile load eval)
-  (setf (package-lock *system-package-list*) t))
+(push "LINUX" custom:*system-package-list*)

Index: linux.lisp
===================================================================
RCS file: /cvsroot/clisp/clisp/modules/bindings/glibc/linux.lisp,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -d -r1.14 -r1.15
--- linux.lisp	3 Nov 2004 18:22:57 -0000	1.14
+++ linux.lisp	20 Dec 2004 14:15:28 -0000	1.15
@@ -4,30 +4,21 @@
 ;; Sam Steingold 2002-2003
 
 (defpackage "LINUX"
-  (:case-sensitive t)
+  (:case-sensitive t) (:case-inverted t)
   (:nicknames "UNIX" "GLIBC")
-  (:use))
+  (:use "CS-COMMON-LISP" "FFI")
+  (:shadowing-import-from "EXPORTING"
+           #:defconstant #:defun #:defmacro #:define-modify-macro
+           #:define-symbol-macro #:defsetf
+           #:def-c-type #:def-c-enum #:def-c-struct #:def-c-var #:def-call-out)
+  (:shadow read write random abort abs acos asin atan cos sin tan cosh sinh tanh
+           acosh asinh atanh exp log sqrt floor truncate ftruncate open close
+           remove sleep))
 
 ;; This requires linking with NEW_LIBS='linux.o -lm'.
 
 (ffi:default-foreign-language :stdc)
 
-(eval-when (compile eval)
-  ;; so that we don't need to prefix everything with "lisp:" or "ffi:".
-  (require "exporting" "../../exporting")
-  (make-exporting "LINUX"
-    cl:aref cl:ash cl:coerce cl:compile cl:defconstant cl:dotimes cl:eval
-    cl:fill cl:floor cl:gensym cl:let cl:load cl:load-time-value cl:logand
-    cl:logbitp cl:logior cl:lognot cl:mod cl:multiple-value-bind cl:not
-    cl:or cl:&rest cl:progn cl:setf cl:t cl:zerop cl:+ cl:- cl:* cl:= cl:1-
-    ffi:bitsizeof ffi:boolean ffi:cast ffi:char ffi:character ffi:c-array
-    ffi:c-array-max ffi:c-array-ptr ffi:c-function ffi:c-ptr ffi:c-ptr-null
-    ffi:c-pointer ffi:c-string ffi:c-struct ffi:deref ffi::foreign-value
-    ffi:double-float ffi:element ffi:int ffi:long ffi:nil ffi:short ffi:sint8
-    ffi:sint16 ffi:sint32 ffi:sint64 ffi:single-float ffi:sizeof ffi:slot
-    ffi:uchar ffi:uint ffi:uint8 ffi:uint16 ffi:uint32 ffi:uint64 ffi:ulong
-    ffi:ushort ffi:with-c-var))
-
 (in-package "LINUX")
 
 (def-c-type longlong sint64)
@@ -2465,6 +2456,5 @@
   (:return-type int))
 
 ;;; ==========================================================================
-;;; clean up
-(cl:in-package "CL-USER")
+
 (provide "linux")



--__--__--

Message: 7
From: Bruno Haible <ha...@us...>
To: cli...@li...
Subject: clisp/modules/netica netica.lisp,1.8,1.9 wrap.lisp,1.6,1.7
Date: Mon, 20 Dec 2004 14:15:33 +0000
Reply-To: cli...@li...

Update of /cvsroot/clisp/clisp/modules/netica
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv23645/modules/netica

Modified Files:
	netica.lisp wrap.lisp 
Log Message:
Define package as case-inverted.
Use some symbols from package EXPORTING; drop old exporting code.
Remove useless package prefixes.


Index: netica.lisp
===================================================================
RCS file: /cvsroot/clisp/clisp/modules/netica/netica.lisp,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -d -r1.8 -r1.9
--- netica.lisp	27 Sep 2004 00:19:50 -0000	1.8
+++ netica.lisp	20 Dec 2004 14:15:30 -0000	1.9
@@ -6,19 +6,11 @@
 ;;; See http://www.gnu.org/copyleft/gpl.html
 
 (defpackage "NETICA"
-  (:case-sensitive t) (:use))
-
-(eval-when (compile eval)
-  (require "exporting" "../exporting")
-  (make-exporting "NETICA"
-    cl:compile cl:defconstant cl:eval cl:load
-    ffi:cast ffi:char ffi:character ffi:c-array ffi:c-array-max
-    ffi:c-array-ptr ffi:c-function ffi:c-ptr ffi:c-ptr-null ffi:c-pointer
-    ffi:c-string ffi:c-struct ffi:deref ffi::foreign-value ffi:double-float
-    ffi:element ffi:int ffi:long ffi:nil ffi:short ffi:sint8 ffi:sint16
-    ffi:sint32 ffi:sint64 ffi:single-float ffi:sizeof ffi:slot ffi:uchar
-    ffi:uint ffi:uint8 ffi:uint16 ffi:uint32 ffi:uint64 ffi:ulong ffi:ushort
-    ffi:with-c-var))
+  (:case-sensitive t) (:case-inverted t)
+  (:use "CS-COMMON-LISP" "FFI")
+  (:shadowing-import-from "EXPORTING"
+           #:defconstant #:defvar #:defun #:defmacro #:define-symbol-macro
+           #:def-c-type #:def-c-enum #:def-c-struct #:def-c-var #:def-call-out))
 
 (in-package "NETICA")
 
@@ -707,5 +699,4 @@
   (:arguments (s sensv_bn_) (Fnode node_bn_))
   (:return-type double-float))
 
-(cl:in-package "CL-USER")
 (provide "netica")

Index: wrap.lisp
===================================================================
RCS file: /cvsroot/clisp/clisp/modules/netica/wrap.lisp,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- wrap.lisp	15 Aug 2003 20:49:25 -0000	1.6
+++ wrap.lisp	20 Dec 2004 14:15:31 -0000	1.7
@@ -3,20 +3,14 @@
 
 (require "netica")
 
-(defpackage "NETICA"
-  (:export "*verbose*" "*env*" "*license*" "error-category" "error-message"
-           "check-errors" "start-netica" "close-netica" "save-net" "read-net"
-           "with-open-dne-file" "make-net" "net-info" "make-node" "node-info"
-           "get-beliefs" "enter-finding"))
+(in-package "NETICA")
 
-(in-package "SYS")
-(eval-when (compile load) (setf (package-lock "SYS") nil))
 (pushnew :netica *features*)
 
 ;;; low level wrappers
 
 (eval-when (compile eval)
-  (defmacro make-node-wrapper (func &rest more-args)
+  (cl:defmacro make-node-wrapper (func &rest more-args)
     (let* ((fun (if (consp func) (first func) func))
            (orig (symbol-name fun)) (node (gensym orig)) (vec (gensym orig))
            (length-form (if (consp func)
@@ -24,14 +18,13 @@
                             `(netica::GetNodeNumberStates_bn ,node)))
            (name (intern (subseq orig 0 (position #\_ orig)) "NETICA")))
       `(progn
-         (export ',name "NETICA")
          (defun ,name (,node ,@more-args)
            ,(concatenate 'string "A low-level wrapper for " orig)
            (ffi:with-c-var (,vec 'ffi:c-pointer (,fun ,node ,@more-args))
              (ffi:cast ,vec `(ffi:c-ptr (ffi:c-array netica::prob_bn
                                                      ,,length-form)))))))))
 
-(defun adjust-number-of-states (num-states type)
+(cl:defun adjust-number-of-states (num-states type)
   (+ num-states
      (gethash type
               (load-time-value
@@ -50,12 +43,12 @@
                      (netica::GetNodeType_bn <node>))))
 
 ;;; user interface variables
-(defvar netica:*verbose* *standard-output* "the netica log stream")
-(defvar netica:*env* nil "the current netica environment")
-(defvar netica:*license* "" "the netica license key - ask norsys")
+(defvar *verbose* *standard-output* "the netica log stream")
+(defvar *env* nil "the current netica environment")
+(defvar *license* "" "the netica license key - ask norsys")
 
 ;;; helpers
-(defun netica:error-category (err)
+(defun error-category (err)
   "return the list of categories where the error belongs"
   (mapcan (lambda (c)
             (unless (zerop (netica::ErrorCategory_ns (symbol-value c) err))
@@ -66,7 +59,7 @@
             netica::FROM_DEVELOPER_CND
             netica::INCONS_FINDING_CND)))
 
-(defun netica:error-message (err)
+(defun error-message (err)
   "Convert netica error to a string"
   (format nil "~s(~s)~@[ ~s~]: ~s~%"
           (ffi:enum-from-value 'netica::errseverity_ns
@@ -75,8 +68,8 @@
           (netica::error-category err)
           (netica::ErrorMessage_ns err)))
 
-(defun netica:check-errors (&key ((:env netica:*env*) netica:*env*) (clear t)
-                            (severity netica::NOTHING_ERR))
+(defun check-errors (&key ((:env netica:*env*) netica:*env*) (clear t)
+                          (severity netica::NOTHING_ERR))
   "Check all errors of the given severity and optionally clear them."
   (let ((err nil))
     (loop (setq err (netica::GetError_ns netica:*env* severity err))
@@ -89,8 +82,8 @@
         (netica::ClearError_ns err) (setq err nil)
         (format *error-output* "~&...cleared~%")))))
 
-(defun netica:start-netica (&key ((:license netica:*license*) netica:*license*)
-                            ((:verbose netica:*verbose*) netica:*verbose*))
+(defun start-netica (&key ((:license netica:*license*) netica:*license*)
+                          ((:verbose netica:*verbose*) netica:*verbose*))
   "Start netica, initialize it, and return the new environment.
 Sets netica:*env* to this environment on success."
   (let ((env (netica::NewNeticaEnviron_ns netica:*license* nil nil))
@@ -114,8 +107,8 @@
     (netica:check-errors :env env)
     (setq netica:*env* env)))
 
-(defun netica:close-netica (&key (env netica:*env*)
-                            ((:verbose netica:*verbose*) netica:*verbose*))
+(defun close-netica (&key (env netica:*env*)
+                          ((:verbose netica:*verbose*) netica:*verbose*))
   "Terminate the netica session.
 Sets netica:*env* to NIL when it was closed."
   (netica:check-errors)
@@ -125,12 +118,12 @@
   (when (eq env netica:*env*)
     (setq netica:*env* nil)))
 
-(defun required-argument (f a) (error "~s: missing ~s argument" f a))
+(cl:defun required-argument (f a) (error "~s: missing ~s argument" f a))
 
-(defun netica:make-net (&key (name (symbol-name (gensym)))
-                        (comment nil) (title nil)
-                        ((:env netica:*env*) netica:*env*)
-                        ((:verbose netica:*verbose*) netica:*verbose*))
+(defun make-net (&key (name (symbol-name (gensym)))
+                      (comment nil) (title nil)
+                      ((:env netica:*env*) netica:*env*)
+                      ((:verbose netica:*verbose*) netica:*verbose*))
   "Make a network with a given name and return it."
   (let ((net (netica::NewNet_bn name netica:*env*)))
     (when netica:*verbose*
@@ -144,7 +137,7 @@
       (netica:check-errors))
     net))
 
-(defun netica:net-info (net)
+(defun net-info (net)
   "Print information about the net."
   (format t "~&net: ~s~%name: ~s~%" net (netica::GetNetName_bn net))
   (let ((title (netica::GetNetTitle_bn net)))
@@ -162,15 +155,15 @@
       (netica:node-info (netica::NthNode_bn nodes ii) :header ii)))
   (netica:check-errors))
 
-(defun netica:make-node (&key (name (symbol-name (gensym)))
-                         (net (required-argument 'netica:make-node :net))
-                         (kind netica::NATURE_NODE)
-                         (levels nil) (states nil)
-                         (num-states (if levels 0 (length states)))
-                         (title nil) (comment nil)
-                         (parents nil) (cpt nil) x y
-                         ((:env netica:*env*) netica:*env*)
-                         ((:verbose netica:*verbose*) netica:*verbose*))
+(defun make-node (&key (name (symbol-name (gensym)))
+                       (net (required-argument 'netica:make-node :net))
+                       (kind netica::NATURE_NODE)
+                       (levels nil) (states nil)
+                       (num-states (if levels 0 (length states)))
+                       (title nil) (comment nil)
+                       (parents nil) (cpt nil) x y
+                       ((:env netica:*env*) netica:*env*)
+                       ((:verbose netica:*verbose*) netica:*verbose*))
   "Make a network node with the given parameters and return it.
 The parameters are: name, net, kind, states (state name list),
 levels (vector), number of states, parents list, cpt.
@@ -224,7 +217,7 @@
     (netica:check-errors)
     node))
 
-(defun netica:node-info (node &key header)
+(defun node-info (node &key header)
   "Print information about the node."
   (format t "~&~@[ * [~s] ~]node: ~s (net: ~s)~%name: ~s   (~s ~s)~%"
           header node (netica::GetNodeNet_bn node)
@@ -266,9 +259,9 @@
       (format t "[~:d] level: ~s~%" ii (aref levels ii))))
   (netica:check-errors))
 
-(defun netica:get-beliefs (node &key
-                           ((:env netica:*env*) netica:*env*)
-                           ((:verbose netica:*verbose*) netica:*verbose*))
+(defun get-beliefs (node
+                    &key ((:env netica:*env*) netica:*env*)
+                         ((:verbose netica:*verbose*) netica:*verbose*))
   "Get the belief vector for the node."
   (let ((beliefs (netica::GetNodeBeliefs node))
         (name (netica::GetNodeName_bn node)))
@@ -280,9 +273,9 @@
       (netica:check-errors))
     beliefs))
 
-(defun netica:enter-finding (net node state &key
-                             ((:env netica:*env*) netica:*env*)
-                             ((:verbose netica:*verbose*) netica:*verbose*))
+(defun enter-finding (net node state
+                      &key ((:env netica:*env*) netica:*env*)
+                           ((:verbose netica:*verbose*) netica:*verbose*))
   "Enter a finding by node and state names"
   (let* ((nd (netica::NodeNamed_bn node net))
          (st (netica::StateNamed_bn state nd)))
@@ -291,8 +284,8 @@
     (when netica:*verbose*
       (format netica:*verbose* "~&;; ~s: set to ~s~%" node state))))
 
-(defun open-dne-file (file &key ((:env netica:*env*) netica:*env*)
-                       ((:verbose netica:*verbose*) netica:*verbose*))
+(cl:defun open-dne-file (file &key ((:env netica:*env*) netica:*env*)
+                                   ((:verbose netica:*verbose*) netica:*verbose*))
   (let ((out (netica::NewStreamFile_ns
               (namestring (translate-logical-pathname
                            (merge-pathnames
@@ -303,16 +296,16 @@
     (netica:check-errors)
     out))
 
-(defmacro netica:with-open-dne-file
-    ((var file &rest opts &key &allow-other-keys) &body body)
+(defmacro with-open-dne-file ((var file &rest opts &key &allow-other-keys)
+                              &body body)
   `(let ((,var (open-dne-file ,file ,@opts)))
      (unwind-protect (progn ,@body)
        (netica::DeleteStream_ns ,var)
        (netica:check-errors))))
 
-(defun netica:save-net (net &key (file (netica::GetNetFileName_bn net))
-                        ((:env netica:*env*) netica:*env*)
-                        ((:verbose netica:*verbose*) netica:*verbose*))
+(defun save-net (net &key (file (netica::GetNetFileName_bn net))
+                          ((:env netica:*env*) netica:*env*)
+                          ((:verbose netica:*verbose*) netica:*verbose*))
   "Save the network to the file."
   (netica:with-open-dne-file (out file)
     (netica::WriteNet_bn net out)
@@ -321,13 +314,11 @@
       (format netica:*verbose* ";; saved ~s to ~s~%" net
               (netica::GetNetFileName_bn net)))))
 
-(defun netica:read-net (file &key ((:env netica:*env*) netica:*env*)
-                        ((:verbose netica:*verbose*) netica:*verbose*))
+(defun read-net (file &key ((:env netica:*env*) netica:*env*)
+                           ((:verbose netica:*verbose*) netica:*verbose*))
   (netica:with-open-dne-file (in file)
     (let ((net (netica::ReadNet_bn in netica::NO_WINDOW)))
       (netica:check-errors)
       net)))
 
-(push "NETICA" ext:*system-package-list*)
-(eval-when (compile load)
-  (setf (ext:package-lock ext:*system-package-list*) t))
+(push "NETICA" custom:*system-package-list*)




--__--__--

_______________________________________________
clisp-cvs mailing list
cli...@li...
https://lists.sourceforge.net/lists/listinfo/clisp-cvs


End of clisp-cvs Digest