Commit 892bd8b1 authored by Pascal J. Bourguignon's avatar Pascal J. Bourguignon

Merged.

parents 0cf75bdf 10db6f16
......@@ -732,13 +732,19 @@ License:
(defun get-slot-list (token-present)
"RETURN: a list of SLOT-IDs."
(with-foreign-object (count :ulong)
(check-rv (%ck:get-slot-list (ckbool token-present) (null-pointer) count) "C_GetSlotList")
(let ((slot-count (mem-ref count :ulong)))
(when (plusp slot-count)
(with-foreign-object (slot-ids '%ck:slot-id slot-count)
(check-rv (%ck:get-slot-list (ckbool token-present) slot-ids count))
(loop :for i :below slot-count
:collect (mem-aref slot-ids '%ck:slot-id i)))))))
(handler-case
(progn
(check-rv (%ck:get-slot-list (ckbool token-present) (null-pointer) count) "C_GetSlotList")
(let ((slot-count (mem-ref count :ulong)))
(when (plusp slot-count)
(with-foreign-object (slot-ids '%ck:slot-id slot-count)
(check-rv (%ck:get-slot-list (ckbool token-present) slot-ids count))
(loop :for i :below slot-count
:collect (mem-aref slot-ids '%ck:slot-id i))))))
(error (err)
(format *error-output* "ERROR: ~A~%" err)
'()))))
(defstruct slot-info
slot-description
......@@ -1786,12 +1792,10 @@ RETURN: TEMPLATE
(check-rv (%ck:get-attribute-value session object (cdr template) (car template)) "C_GetAttributeValue")
#+debug (ignore-errors (write-line "After 1st C_GetAttributeValue") (template-dump template))
(values))
(:no-error () #-(and)(pause () "Ok") :ok)
(:no-error () :ok)
(pkcs11-error (err)
(case (pkcs11-error-label err)
((:attribute-sensitive :attribute-type-invalid :buffer-too-small)
#-(and)(pause (list (list '*template* template)
(list '*error* err)) "pkcs11-error ~A" err)
(setf template (template-allocate-buffers (template-pack template)))
;; try again:
(handler-case
......@@ -1800,20 +1804,14 @@ RETURN: TEMPLATE
(check-rv (%ck:get-attribute-value session object (cdr template) (car template)) "C_GetAttributeValue")
#+debug (ignore-errors (write-line "After 2nd C_GetAttributeValue") (template-dump template))
(values))
(:no-error () #-(and)(pause () "Ok") :ok)
(:no-error () :ok)
(pkcs11-error (err)
(case (pkcs11-error-label err)
((:attribute-sensitive :attribute-type-invalid :buffer-too-small)
#-(and)(pause (list (list '*template* template)
(list '*error* err)) "pkcs11-error ~A" err)
(pkcs11-error-label err))
(otherwise (error err))))))
(otherwise (error err)))))))
#-(and) (pause (list (list '*template* template)
(list '*template* template)) "cleanup")
#-(and) (template-dump template)
(values (template-decode template) status))
#-(and)(pause (list (list '*template* template)) "cleanup")
(template-free template))))
(defun set-attribute-value (session object template)
......
......@@ -687,8 +687,13 @@ RETURN: true if there was such an entry, or false otherwise.
(defun indentation (level leftp)
(format nil "~{~A~}" (loop :repeat level :collect (if leftp "| " " "))))
(defun concat (&rest args)
(apply (function concatenate) 'string args))
(defun concat (&rest items)
(with-output-to-string (*standard-output*)
(dolist (item items)
(typecase item
(string (write-string item *standard-output*))
(sequence (write-sequence item *standard-output*))
(t (with-standard-io-syntax (format *standard-output* "~A" item)))))))
(defun string-butlast (str)
(if (plusp (length str))
......
......@@ -1432,29 +1432,67 @@ RETURN: The maximum value and the item in list for which predicate
'compute-closure 'transitive-closure)
(transitive-closure fun set))
(defun transitive-closure (fun set)
(defun transitive-closure (fun set &key (test 'eql) (use 'list))
"
FUN: set --> P(set)
x |--> { y }
RETURN: The closure of fun on the set.
NOTE: Not a lisp closure!
EXAMPLE: (compute-closure (lambda (x) (list (mod (* x 2) 5))) '(1)) --> (2 4 3 1)
SET: A sequence.
TEST: EQL, EQUAL or EQUALP
USE: Either HASH-TABLE or LIST; specifies the data structure used for the intermediary sets.
RETURN: A list containing closure of fun on the set.
EXAMPLE: (transitive-closure (lambda (x) (list (mod (* x 2) 5))) '(1)) --> (3 4 2 1)
NOTE: This version avoids calling FUN twice with the same argument.
"
(flet ((join (lists)
(loop
:with result = '()
:for list :in lists
:do (loop :for item :in list :do (push item result))
:finally (return result))))
(loop
:for follows = (delete-duplicates (join (mapcar fun set)))
:then (delete-duplicates (join (cons follows (mapcar fun newbies))))
:for newbies = (set-difference follows set)
:while newbies
;; :do (print (list 'newbies newbies))
:do (setf set (append newbies set))
:finally (return set))))
;; current -> fun -> follows
;; closure + current -> closure
;; follows - closures -> current
(ecase use
(list
(let ((closure '())
(current '())
(follows '()))
(macrolet ((enter (item list) `(pushnew ,item ,list :test test))
(enter-all (items list) `(setf ,list (delete-duplicates (append ,items ,list) :test test))))
(setf current (coerce set 'list))
(loop
:do (loop ;; current -> fun -> follows
:for item :in current
:initially (setf follows '())
:do (enter-all (funcall fun item) follows)
;; closure + current -> closure
(enter item closure))
(loop ;; follows - closures -> current
:for item :in follows
:initially (setf current '())
:unless (member item closure :test test)
:do (enter item current))
:while current
:finally (return-from transitive-closure closure)))))
(hash-table
(let ((closure (make-hash-table :test test))
(current (make-hash-table :test test))
(follows (make-hash-table :test test)))
(flet ((enter (item hash) (setf (gethash item hash) t))
(enter-all (items hash) (map nil (lambda (item) (setf (gethash item hash) t)) items)))
(declare (inline enter enter-all))
(enter-all set current)
(loop
:do (loop ;; current -> fun -> follows
:for item :being :each :hash-key :in current
:initially (clrhash follows)
:do (enter-all (funcall fun item) follows)
;; closure + current -> closure
(enter item closure))
(loop ;; follows - closures -> current
:for item :being :each :hash-key :in follows
:initially (clrhash current)
:unless (gethash item closure)
:do (enter item current))
:while (plusp (hash-table-count current))
:finally (return-from transitive-closure
(loop
:for item :being :each :hash-key :in closure
:collect item))))))))
;; (array->list array) --> (coerce array 'list)
......@@ -1630,17 +1668,15 @@ POST: (<= start index end)
(defmacro sconc (&rest args)
"Concatenate strings."
`(concatenate 'string ,@args))
(defun concat (&rest args)
"Concatenate anything into a string."
(apply (function concatenate) 'string
(mapcar (lambda (item)
(if (typep item 'sequence)
item
(format nil "~A" item))) args)))
`(concat ,@args))
(defun concat (&rest items)
(with-output-to-string (*standard-output*)
(dolist (item items)
(typecase item
(string (write-string item *standard-output*))
(sequence (write-sequence item *standard-output*))
(t (with-standard-io-syntax (format *standard-output* "~A" item)))))))
(defmacro scase (keyform &rest clauses)
"
......
......@@ -1049,7 +1049,13 @@ that are accessible by the user."
:name nil :type nil :version nil)
rootpath nil)))
(defun concat (&rest items) (apply (function concatenate) 'string items))
(defun concat (&rest items)
(with-output-to-string (*standard-output*)
(dolist (item items)
(typecase item
(string (write-string item *standard-output*))
(sequence (write-sequence item *standard-output*))
(t (with-standard-io-syntax (format *standard-output* "~A" item)))))))
(defun mapconcat (function sequence separator)
(etypecase sequence
......
......@@ -118,7 +118,7 @@ LEGAL
(format stream "Object to printable readably ~S"
(print-not-readable-object condition))))))
(defun ARRAY-DISPLACEMENT (array)
(defun array-displacement (array)
;; if not provided, then displaced array don't exist!
(declare (ignore array))
(values nil 0))
......@@ -126,27 +126,27 @@ LEGAL
;; COMPILE ;; required to implement minimal compilation.
(defun LOAD (filespec &key verbose print if-does-not-exist external-format)
(defun load (filespec &key verbose print if-does-not-exist external-format)
)
(defun ENSURE-DIRECTORIES-EXIST (pathspec &key verbose)
(error "~S not implemented yet" 'ENSURE-DIRECTORIES-EXIST)
(defun ensure-directories-exist (pathspec &key verbose)
(error "~S not implemented yet" 'ensure-directories-exist)
(let ((created nil))
(values pathspec created)))
(defun RENAME-FILE (filespec new-name)
(error "~S not implemented yet" 'RENAME-FILE)
(defun rename-file (filespec new-name)
(error "~S not implemented yet" 'rename-file)
(let (defaulted-new-name old-truename new-truename)
(values defaulted-new-name old-truename new-truename)))
(defun FILE-WRITE-DATE (pathspec)
(defun file-write-date (pathspec)
(declare (ignore pathspec))
nil)
(defvar *debugger-hook* nil)
(defun INVOKE-DEBUGGER (condition)
(defun invoke-debugger (condition)
(when *debugger-hook*
(let ((saved-hook *debugger-hook*)
(*debugger-hook* nil))
......@@ -156,10 +156,10 @@ LEGAL
(defvar *hosts* '())
(defun LOGICAL-PATHNAME-TRANSLATIONS (host)
(defun logical-pathname-translations (host)
(cdr (assoc host *hosts* :test (function equalp))))
(defun (setf LOGICAL-PATHNAME-TRANSLATIONS) (new-translations host)
(defun (setf logical-pathname-translations) (new-translations host)
(let ((entry (assoc host *hosts* :test (function equalp))))
(if entry
(setf (cdr entry) (copy-tree new-translations))
......@@ -167,16 +167,16 @@ LEGAL
(copy-tree new-translations))
*hosts*))))
(defun TRANSLATE-LOGICAL-PATHNAME (pathname &key &allow-other-keys)
(error "~S not implemented yet" 'TRANSLATE-LOGICAL-PATHNAME)
(defun translate-logical-pathname (pathname &key &allow-other-keys)
(error "~S not implemented yet" 'translate-logical-pathname)
pathname)
(defun MACHINE-INSTANCE ()
(defun machine-instance ()
;; TODO: find the hostname of the machine, or some other machine identification.
#+android "Android"
#+ios "iOS")
(defun MACHINE-VERSION ()
(defun machine-version ()
;; TODO: find the hardware version, or some other machine version.
#+android "0.0"
#+ios "0.0")
......@@ -187,7 +187,7 @@ LEGAL
;; SBCL --> ("larissa.local" "Intel(R) Core(TM) i7-4650U CPU @ 1.70GHz")
(defun NSET-DIFFERENCE (list-1 list-2 &rest rest &key key test test-not)
(defun nset-difference (list-1 list-2 &rest rest &key key test test-not)
(declare (ignore key test test-not))
(apply (function set-difference) list-1 list-2 rest))
......@@ -248,13 +248,13 @@ LEGAL
(setf (aref sequence i) new-item)))))))
sequence))
(defun SUBSTITUTE-IF (new-item predicate sequence &rest rest &key from-end start end count key)
(defun substitute-if (new-item predicate sequence &rest rest &key from-end start end count key)
(apply (function nsubstitute-if) new-item predicate (copy-seq sequence) rest))
(defun NSUBSTITUTE-IF-NOT (new-item predicate sequence &rest rest &key from-end start end count key)
(defun nsubstitute-if-not (new-item predicate sequence &rest rest &key from-end start end count key)
(apply (function nsubstitute-if) new-item (complement predicate) sequence rest))
(defun SUBSTITUTE-IF-NOT (new-item predicate sequence &rest rest &key from-end start end count key)
(defun substitute-if-not (new-item predicate sequence &rest rest &key from-end start end count key)
(apply (function nsubstitute-if) new-item (complement predicate) (copy-seq sequence) rest))
......
......@@ -19,7 +19,7 @@
;;;;LEGAL
;;;; AGPL3
;;;;
;;;; Copyright Pascal J. Bourguignon 2013 - 2016
;;;; Copyright Pascal J. Bourguignon 2013 - 2018
;;;;
;;;; This program is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU Affero General Public License as published by
......@@ -51,13 +51,18 @@
"ASDF-FILE" "ASDF-FILE-P" "MAKE-ASDF-FILE" "COPY-ASDF-FILE"
"ASDF-FILE-PATH" "ASDF-FILE-DEPENDS-ON" "ASDF-FILE-REACHABLE"
"SYSTEM-DIRECT-DEPENDENCIES"
"SYSTEM-DEPENDS-ON"
"SYSTEM-ALL-DEPENDENCIES"
;; Generate dot file from a asdf-file graphs
"GENERATE-DOT" "DOT"
"ADJACENCY-LIST" "REACHABLE-LIST"
"DEPENDENCIES"
;; Check asdf files
"CHECK-ASDF-SYSTEM-FILE")
"CHECK-ASDF-SYSTEM-FILE"
"CHECK-ASDF-SYSTEM-DEPENDENCIES")
(:documentation "
Check an asdf file for circular dependencies.
......@@ -71,7 +76,7 @@ License:
AGPL3
Copyright Pascal J. Bourguignon 2013 - 2013
Copyright Pascal J. Bourguignon 2013 - 2018
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Affero General Public License as published by
......@@ -241,4 +246,35 @@ RETURN: A string containing the dot file data for this graph.
~%It should be a tree.~%"))
(report-problems (hash-table-values asdf-files) :report report)))
;; Note: we need to cache those dependencies to go faster:
(defun system-direct-dependencies (system)
(let ((system (asdf:find-system system)))
(delete-duplicates (mapcan (lambda (depend)
(copy-list (funcall depend system)))
'(asdf:system-defsystem-depends-on
asdf:system-depends-on
asdf:system-weakly-depends-on))
:test (function equal))))
(defun system-depends-on (a b)
(member b (system-direct-dependencies a)))
(defun system-all-dependencies (system)
(com.informatimago.common-lisp.cesarum.utility:transitive-closure
(function system-direct-dependencies)
(list system)))
(defun check-asdf-system-dependencies (system &key (report *standard-output*))
(let* ((all-systems (system-all-dependencies :smart-integrated-sensors.main))
(sorted-systems (topological-sort all-systems (function system-depends-on))))
(if (= (length sorted-systems) (length all-systems))
(format report "~&No cycle among system dependencies.~%")
(format report "~&The system dependencies graph of ~S contains cycles! ~
~%It should be a tree.~%" system))
(report-problems all-systems :report report)))
;;;; THE END ;;;;
;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE: dependency.asd
;;;;LANGUAGE: Common-Lisp
;;;;SYSTEM: Common-Lisp
;;;;USER-INTERFACE: NONE
;;;;DESCRIPTION
;;;;
;;;; Check for circular dependencies.
;;;;
;;;;AUTHORS
;;;; <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;; 2013-03-25 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;; AGPL3
;;;;
;;;; Copyright Pascal J. Bourguignon 2013 - 2018
;;;;
;;;; This program is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU Affero General Public License as published by
;;;; the Free Software Foundation, either version 3 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU Affero General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Affero General Public License
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************
(asdf:defsystem "com.informatimago.tools.dependency"
:description "Reads sources and headers to perform some analysis."
:description "Checks for circular dependencies."
:author "Pascal J. Bourguignon"
:version "1.3.0"
:version "1.3.1"
:license "AGPL3"
:depends-on ("com.informatimago.common-lisp.cesarum"
"com.informatimago.common-lisp.picture"
"com.informatimago.common-lisp.graphviz" ; used by dependency-cycles
"com.informatimago.clext"
"closer-mop"
"split-sequence")
:components ((:file "dependency-cycles"))
"com.informatimago.tools.source"
#-abcl "com.informatimago.tools.script")
:components (#-abcl (:file "dependency-cycles" :depends-on ()))
#+asdf-unicode :encoding #+asdf-unicode :utf-8)
;;;; THE END ;;;;
......@@ -156,7 +156,7 @@ are listed."
(defun quick-where (system &rest systems)
"Says where the given systems are."
(apply (function quick-where-is) (cons system systems)))
(apply (function quick-where-is) system systems))
(defun quick-delete (system &rest systems)
......
......@@ -715,13 +715,13 @@ that are accessible by the user."
:name nil :type nil :version nil)
rootpath nil)))
(defun concat (&rest args)
"Concatenate anything into a string."
(apply (function concatenate) 'string
(mapcar (lambda (item)
(if (typep item 'sequence)
item
(format nil "~A" item))) args)))
(defun concat (&rest items)
(with-output-to-string (*standard-output*)
(dolist (item items)
(typecase item
(string (write-string item *standard-output*))
(sequence (write-sequence item *standard-output*))
(t (with-standard-io-syntax (format *standard-output* "~A" item)))))))
(defun mapconcat (function sequence separator)
;; 1- mon_key on irc://irc.freenode.org/#lisp signaled that nil are
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment