Some correction and moving around.

Pascal J. Bourguignon [2013-06-16 19:35]
Some correction and moving around.
Filename
README
common-lisp/apple-file/apple-file.lisp
common-lisp/cesarum/list.lisp
common-lisp/cesarum/simple-test.lisp
common-lisp/cesarum/utility.lisp
languages/linc/c-syntax.lisp
languages/linc/linc.lisp
diff --git a/README b/README
index 88dbd50..ac31285 100644
--- a/README
+++ b/README
@@ -114,6 +114,12 @@ References
         git push gitorious master


+TODO
+==================
+
+- create a library for low level utilities (eg. proper-list-p) that
+  are used by several libraries to break circular dependencies.
+

           -------------------------------------------------
                            ---------------
diff --git a/common-lisp/apple-file/apple-file.lisp b/common-lisp/apple-file/apple-file.lisp
index 8516f6d..4ab58ce 100644
--- a/common-lisp/apple-file/apple-file.lisp
+++ b/common-lisp/apple-file/apple-file.lisp
@@ -254,19 +254,19 @@


 (defun check-ranges (header)
-  (let ((sorted-entries (sort (copy-list (header-entries header))
-                              (function <) :key (function entry-offset))))
-
-    )
   (let ((file-set  (make-instance 'index-set))
         (entry-set (make-instance 'index-set)))
     (dolist (entry (header-entries header))
       (assign-empty entry-set)
       (include entry-set  (make-range :start (entry-offset entry)
                                       :count (entry-length entry)))
-      (if (emptyp (intersection file-set entry-set))
+      (if (emptyp (intersection 'index-set file-set entry-set))
         (merge file-set entry-set)
-        (report-collision entry)))))
+        (report-collision header entry)))))
+
+(defun report-collision (header  entry)
+  ;; TODO:
+  (error "Some entries collide in ~S." header))


 (defun read-header (stream kind)
@@ -543,7 +543,7 @@
   (let* ((start            (resource-header-map-offset resource-header))
          (end              (+ start (resource-header-map-length resource-header)))
          (resource         (resource-header-resource resource-header))
-         (file-attributes  (get-ushort resource (+ start 22)))
+         ;; (file-attributes  (get-ushort resource (+ start 22)))
          (type-list-offset (+ start (get-short resource (+ start 24))))
          (name-list-offset (+ start (get-short resource (+ start 26))))
          (data-offset      (resource-header-data-offset resource-header)))
@@ -623,6 +623,7 @@ FORK:   (member :info :data :resource)
   (:method ((path string) format fork)
     (apple-file-fork-pathname (pathname path) format fork))
   (:method ((info-path pathname) (format (eql :apple-single)) fork)
+    (declare (ignore fork))
     info-path)
   (:method ((info-path pathname) (format (eql :apple-double)) fork)
     (let ((name (pathname-name info-path)))
@@ -644,16 +645,39 @@ FORK:   (member :info :data :resource)
                    :defaults info-path)))


+(defun tree-structure-and-leaf-difference (a b &key (test (function eql)))
+  (cond
+    ((and (null a) (null b)) '=)
+    ((or (null a) (null b)) `(/= ,a ,b))
+    ((and (atom a) (atom b))
+     (if (funcall test a b)
+         '=
+         `(/= ,a ,b)))
+    ((or (atom a) (atom b)) `(/= ,a ,b))
+    (t (cons (tree-structure-and-leaf-difference (car a) (car b) :test test)
+             (tree-structure-and-leaf-difference (cdr a) (cdr b) :test test)))))
+
 (defun test/apple-file-fork-pathname ()
-  (assert (equalp
-           (mapcar (lambda (format)
-                     (mapcar (lambda (fork)
-                               (apple-file-fork-pathname "test.single" format fork))
-                             '(:info :data :resource)))
-                   '(:apple-single :apple-double :apple-triple))
-           '((#P"test.single" #P"test.single" #P"test.single")
-             (#P"\\._test.single" #P"test.single" #P"\\._test.single")
-             (#P"test.info" #P"test.data" #P"test.rsrc"))))
+  #+unix
+  (let ((*default-pathname-defaults* #P"/"))
+    (assert
+     (tree-structure-and-leaf-difference
+      (mapcar (lambda (format)
+                (mapcar (lambda (fork)
+                          (apple-file-fork-pathname (make-pathname :name "test" :type "single" :case :local)
+                                                    format fork))
+                        '(:info :data :resource)))
+              '(:apple-single :apple-double :apple-triple))
+      (list (list (make-pathname :name "test" :type "single" :case :local)
+                  (make-pathname :name "test" :type "single" :case :local)
+                  (make-pathname :name "test" :type "single" :case :local))
+            (list (make-pathname :name "._test" :type "single" :case :local)
+                  (make-pathname :name "test" :type "single" :case :local)
+                  (make-pathname :name "._test" :type "single" :case :local))
+            (list (make-pathname :name "test" :type "info" :case :local)
+                  (make-pathname :name "test" :type "data" :case :local)
+                  (make-pathname :name "test" :type "rsrc" :case :local)))
+      :test 'pathname-match-p)))
   :success)


@@ -694,7 +718,7 @@ FORK:   (member :info :data :resource)

 (defgeneric close-apple-file (apple-file)
   (:method ((apple-file apple-file))
-    (close (apple-file-header-info-stream apple-file))))
+    (close (header-info-stream (apple-file-header apple-file)))))

 (defun apple-file-data-fork (apple-file
                              &key (direction :input)
@@ -763,10 +787,11 @@ FORK:   (member :info :data :resource)
 (define-attribute apple-file-prodos-auxiliary-type  :prodos-file-info    "RETURN: NIL or the PRODOS auxiliary type code of the APPLE-FILE."              file-auxiliary-type)
 (define-attribute apple-file-msdos-attributes       :msdos-file-info     "RETURN: NIL or the MSDOS attributes of the APPLE-FILE."                        file-msdos-attributes)
 (define-attribute apple-file-afp-backup-needed      :afp-file-info       "RETURN: NIL or the AFP backup needed flag of the APPLE-FILE."                  file-backup-needed)
-(define-attribute apple-file-afp-system             :afp-file-info       "RETURN: NIL or the AFP system flag of the APPLE-FILE."                         file-system)
-(define-attribute apple-file-afp-multi-user         :afp-file-info       "RETURN: NIL or the AFP multi-user flag of the APPLE-FILE."                     file-multi-user)
-(define-attribute apple-file-afp-invisible          :afp-file-info       "RETURN: NIL or the AFP invisible flag of the APPLE-FILE."                      file-invisible)
-(define-attribute apple-file-afp-directory-id       :afp-file-info       "RETURN: NIL or the AFP directory ID of the APPLE-FILE."                        file-directory-id)
+(define-attribute apple-file-afp-system             :afp-file-info       "RETURN: NIL or the AFP system flag of the APPLE-FILE."                         afp-file-system)
+(define-attribute apple-file-afp-multi-user         :afp-file-info       "RETURN: NIL or the AFP multi-user flag of the APPLE-FILE."                     afp-file-multi-user)
+(define-attribute apple-file-afp-invisible          :afp-file-info       "RETURN: NIL or the AFP invisible flag of the APPLE-FILE."                      afp-file-invisible)
+(define-attribute apple-file-afp-directory-id       :afp-file-info       "RETURN: NIL or the AFP directory ID of the APPLE-FILE."                        afp-file-directory-id)
+


 ;;----------------------------------------------------------------------
diff --git a/common-lisp/cesarum/list.lisp b/common-lisp/cesarum/list.lisp
index c780e92..6f5a2ad 100644
--- a/common-lisp/cesarum/list.lisp
+++ b/common-lisp/cesarum/list.lisp
@@ -775,6 +775,18 @@ EXAMPLE: (tree-difference '((a b c) 1 (d e f)) '((a b c) (1) (d x f)))
              (tree-difference (cdr a) (cdr b) :test test)))))


+(defun tree-structure-and-leaf-difference (a b &key (test (function eql)))
+  (cond
+    ((and (null a) (null b)) '=)
+    ((or (null a) (null b)) `(/= ,a ,b))
+    ((and (atom a) (atom b))
+     (if (funcall test a b)
+         '=
+         `(/= ,a ,b)))
+    ((or (atom a) (atom b)) `(/= ,a ,b))`(/= ,a ,b)
+    (t (cons (tree-structure-and-leaf-difference (car a) (car b) :test test)
+             (tree-structure-and-leaf-difference (cdr a) (cdr b) :test test)))))
+
 (defun replace-tree (dst src)
   "
 DO:     Copies the elements of the src tree into the dst tree.
diff --git a/common-lisp/cesarum/simple-test.lisp b/common-lisp/cesarum/simple-test.lisp
index ced2f22..35db03e 100644
--- a/common-lisp/cesarum/simple-test.lisp
+++ b/common-lisp/cesarum/simple-test.lisp
@@ -33,7 +33,8 @@
 ;;;;**************************************************************************

 (defpackage "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SIMPLE-TEST"
-  (:use "COMMON-LISP")
+  (:use "COMMON-LISP"
+        "COM.INFORMATIMAGO.COMMON-LISP.LISP-SEXP.SOURCE-FORM")
   (:export "*DEBUG-ON-ERROR*" "WITH-DEBUGGER-ON-ERROR"
            "DEFINE-TEST" "TEST" "ASSERT-TRUE" "EXPECT-CONDITION"

@@ -279,22 +280,25 @@ EXAMPLE:  (test equal (list 1 2 3) '(1 2 3))
                      :for param :in parameters
                      :while (symbolp param)
                      :collect param)))
-    `(defun ,name ,parameters
-       (multiple-value-bind (successes failures)
-           (let ((*success-count* 0)
-                 (*failure-count* 0)
-                 (*current-test-name*        ',name)
-                 (*current-test-parameters* (list ,@mandatory))
-                 (*current-test-printed-p*  nil))
-             (progress-start)
-             (locally ,@body)
-             (progress-tally *success-count* *failure-count*)
-             (values *success-count* *failure-count*))
-         (incf *success-count* successes)
-         (incf *failure-count* failures)
-         (if (zerop failures)
-             :success
-             :failure)))))
+    (multiple-value-bind (docstrings declarations forms) (parse-body :lambda body)
+      `(defun ,name ,parameters
+         ,@docstrings
+         ,@declarations
+         (multiple-value-bind (successes failures)
+             (let ((*success-count* 0)
+                   (*failure-count* 0)
+                   (*current-test-name*        ',name)
+                   (*current-test-parameters* (list ,@mandatory))
+                   (*current-test-printed-p*  nil))
+               (progress-start)
+               (progn ,@forms)
+               (progress-tally *success-count* *failure-count*)
+               (values *success-count* *failure-count*))
+           (incf *success-count* successes)
+           (incf *failure-count* failures)
+           (if (zerop failures)
+               :success
+               :failure))))))

 (defmacro with-debugger-on-error (&body body)
   `(let ((*debug-on-error* t))
diff --git a/common-lisp/cesarum/utility.lisp b/common-lisp/cesarum/utility.lisp
index fb8d7ed..5416a87 100644
--- a/common-lisp/cesarum/utility.lisp
+++ b/common-lisp/cesarum/utility.lisp
@@ -769,16 +769,14 @@ DO:       Execute the BODY with a handler for CONDITION and
 "
   `(handler-case (progn ,@body)
      (simple-condition  (err)
-       (format *error-output* "~&~A: ~%" (class-name (class-of err)))
-       (apply (function format) *error-output*
-              (simple-condition-format-control   err)
-              (simple-condition-format-arguments err))
-       (format *error-output* "~&")
-       (finish-output))
+       (format *error-output* "~&~A:~%~?~&"
+               (class-name (class-of err))
+               (simple-condition-format-control   err)
+               (simple-condition-format-arguments err))
+       (finish-output *error-output*))
      (condition (err)
-       (format *error-output* "~&~A: ~%  ~A~%" (class-name (class-of err)) err)
-       (finish-output))))
-
+       (format *error-output* "~&~A:~%~A~%" (class-name (class-of err)) err)
+       (finish-output *error-output*))))


 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -973,74 +971,8 @@ RETURN: A list of NODES sorted topologically according to
                    (push m q))))
      :finally (return (nreverse sorted))))

-(error "Check topological-sort")
-#-(and)
-(tree-difference
- '(defun topological-sort (nodes lessp)
-   "
-RETURN: A list of NODES sorted topologically according to
-        the partial order function LESSP.
-        If there are cycles (discounting reflexivity),
-        then the list returned won't contain all the NODES.
-"
-   (loop
-     :with sorted = '()
-     :with incoming = (map 'vector (lambda (to)
-                                     (loop
-                                       :for from :in nodes
-                                       :when (and (not (eq from to))
-                                                  (funcall lessp from to))
-                                       :sum 1))
-                           nodes)
-     :with q = (loop
-                 :for node :in nodes
-                 :for inco :across incoming
-                 :when (zerop inco)
-                 :collect node)
-     :while q
-     :do (let ((n (pop q)))
-           (push n sorted)
-           (loop
-             :for m :in nodes
-             :for i :from 0
-             :do (when (and (and (not (eq n m))
-                                 (funcall lessp n m))
-                            (zerop (decf (aref incoming i))))
-                   (push m q))))
-     :finally (return (nreverse sorted))))

- '(defun topological-sort (nodes lessp)
-   "
-RETURN: A list of NODES sorted topologically according to
-        the partial order function LESSP.
-        If there are cycles (discounting reflexivity),
-        then the list returned won't contain all the NODES.
-"
-   (loop
-     :with sorted = '()
-     :with incoming = (map 'vector (lambda (to)
-                                     (loop
-                                       :for from :in nodes
-                                       :when (and (not (eq from to))
-                                                  (funcall lessp from to))
-                                       :sum 1))
-                           nodes)
-     :with q = (loop
-                 :for node :in nodes
-                 :for inco :across incoming
-                 :when (zerop inco)
-                 :collect node)
-     :while q
-     :do (let ((n (pop q)))
-           (push n sorted)
-           (loop
-             :for m :in nodes
-             :for i :from 0
-             :do (when (and (and (not (eq n m))
-                                 (funcall lessp n m))
-                            (zerop (decf (aref incoming i))))
-                   (push m q))))
-     :finally (return (nreverse sorted)))))
+



diff --git a/languages/linc/c-syntax.lisp b/languages/linc/c-syntax.lisp
index e59f4fb..7e2e2b8 100644
--- a/languages/linc/c-syntax.lisp
+++ b/languages/linc/c-syntax.lisp
@@ -159,13 +159,16 @@ Defines two functions for each KIND:
                         (symbol-package kind))))
     `(progn
        (defun ,fname (name &key external)
+         ,@(list (format nil "Declare a C ~(~A~).~%~@[~A~]" kind docstring))
          (if (listp name)
              (map nil (function ,fname) name)
              (progn
                (when external (export name (symbol-package name)))
                (setf (get name ',kind) t)))
          name)
-       (defun ,pname (name)  (get name ',kind))
+       (defun ,pname (name)
+         ,@(list (format nil "Predicate whether NAME is a C ~(~A~).~%~@[~A~]" kind docstring))
+         (get name ',kind))
        ',kind)))


@@ -242,8 +245,7 @@ BUG: Correct C number syntax!
 (defun exactly-one-p   (list) (and       list  (not (cdr   list))))
 (defun exactly-two-p   (list) (and (cdr  list) (not (cddr  list))))
 (defun exactly-three-p (list) (and (cddr list) (not (cdddr list))))
-(defun proper-list-p (list)
-  (or (endp list) (proper-list-p (rest list))))
+


 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -370,8 +372,6 @@ BUG: Correct C number syntax!
        ,@(mapcar (lambda (arg) `(when ,arg (incf ,vcount))) args)
        ,vcount)))

-(defun xor (a b) (and (or a b) (not (and a b))))
-
 (defmethod initialize-instance :after ((self 2-arguments)
                                        &rest all-init-args
                                        &key (arguments nil argumentsp)
diff --git a/languages/linc/linc.lisp b/languages/linc/linc.lisp
index 83b90b9..bb82b7c 100644
--- a/languages/linc/linc.lisp
+++ b/languages/linc/linc.lisp
@@ -488,19 +488,6 @@



-(defmacro handling-errors (&body body)
-  `(HANDLER-CASE (progn ,@body)
-     (simple-condition  (ERR)
-       (format *error-output* "~&~A: ~%" (class-name (class-of err)))
-       (apply (function format) *error-output*
-              (simple-condition-format-control   err)
-              (simple-condition-format-arguments err))
-       (format *error-output* "~&")
-       (finish-output))
-     (condition (ERR)
-       (format *error-output* "~&~A: ~%  ~S~%" (class-name (class-of err)) err)
-       (finish-output))))
-
 (defun repl ()
   (catch 'repl     ; allow for emergency exit with (throw 'com.informatimago.linc::repl)
     (let ((*package* (find-package "C"))
ViewGit