├── walker ├── .svn │ ├── empty-file │ ├── format │ ├── props │ │ ├── mcl.html.svn-work │ │ ├── mcl.lisp.svn-work │ │ ├── ncsl.html.svn-work │ │ ├── sysdcl.lisp.svn-work │ │ ├── test.lisp.svn-work │ │ ├── walker.html.svn-work │ │ ├── walker.lisp.svn-work │ │ ├── class-graph.lisp.svn-work │ │ ├── package.lisp.svn-work │ │ ├── function-graph.lisp.svn-work │ │ └── package-graph.lisp.svn-work │ ├── prop-base │ │ ├── mcl.html.svn-base │ │ ├── mcl.lisp.svn-base │ │ ├── ncsl.html.svn-base │ │ ├── package.lisp.svn-base │ │ ├── sysdcl.lisp.svn-base │ │ ├── test.lisp.svn-base │ │ ├── walker.html.svn-base │ │ ├── walker.lisp.svn-base │ │ ├── class-graph.lisp.svn-base │ │ ├── function-graph.lisp.svn-base │ │ └── package-graph.lisp.svn-base │ ├── README.txt │ ├── text-base │ │ ├── sysdcl.lisp.svn-base │ │ ├── package.lisp.svn-base │ │ ├── ncsl.html.svn-base │ │ ├── package-graph.lisp.svn-base │ │ ├── mcl.lisp.svn-base │ │ └── class-graph.lisp.svn-base │ └── entries ├── walker.asd ├── source-walker.lisp ├── parameters.lisp ├── package.lisp ├── package-graph.lisp ├── class-graph.lisp └── function-graph.lisp ├── dot ├── examples │ └── tsl.pdf ├── tests │ ├── tests.asd │ ├── dot-model-1.dot │ └── dot.lisp └── dot.asd ├── .gitignore ├── .gitattributes ├── test ├── rspec │ ├── rspec.asd │ ├── package.lisp │ ├── rspec-lisp.rb │ └── rspec.lisp ├── test.asd ├── test │ ├── test-unit.lisp │ └── monitor.lisp └── package.lisp ├── codecs ├── bert │ ├── bert.asd │ └── bert.lisp ├── test │ ├── vector-stream.lisp │ ├── test.asd │ ├── types.lisp │ ├── utilities.lisp │ ├── float-codecs.lisp │ └── character-codecs.lisp ├── etf │ ├── etf.asd │ └── package.lisp ├── codecs.asd ├── meta │ └── float.lisp ├── utilities.lisp └── types.lisp ├── asdf ├── asdf.asd ├── patches.lisp ├── operators.lisp └── contingent-on.lisp ├── bsd └── bsd.asd ├── graph ├── graph.asd ├── package.lisp └── classes.lisp ├── mime ├── mime.asd └── package.lisp ├── documentation-stub.lisp ├── README.md ├── utility.asd ├── clos ├── clos.asd └── print-object-slots.lisp ├── package.lisp ├── string.lisp ├── lock.lisp └── lgpl.txt /walker/.svn/empty-file: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /walker/.svn/format: -------------------------------------------------------------------------------- 1 | 4 2 | -------------------------------------------------------------------------------- /walker/.svn/props/mcl.html.svn-work: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /walker/.svn/props/mcl.lisp.svn-work: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /walker/.svn/props/ncsl.html.svn-work: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /walker/.svn/props/sysdcl.lisp.svn-work: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /walker/.svn/props/test.lisp.svn-work: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /walker/.svn/props/walker.html.svn-work: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /walker/.svn/props/walker.lisp.svn-work: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /walker/.svn/prop-base/mcl.html.svn-base: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /walker/.svn/prop-base/mcl.lisp.svn-base: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /walker/.svn/prop-base/ncsl.html.svn-base: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /walker/.svn/prop-base/package.lisp.svn-base: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /walker/.svn/prop-base/sysdcl.lisp.svn-base: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /walker/.svn/prop-base/test.lisp.svn-base: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /walker/.svn/prop-base/walker.html.svn-base: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /walker/.svn/prop-base/walker.lisp.svn-base: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /walker/.svn/props/class-graph.lisp.svn-work: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /walker/.svn/props/package.lisp.svn-work: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /walker/.svn/prop-base/class-graph.lisp.svn-base: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /walker/.svn/props/function-graph.lisp.svn-work: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /walker/.svn/props/package-graph.lisp.svn-work: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /walker/.svn/prop-base/function-graph.lisp.svn-base: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /walker/.svn/prop-base/package-graph.lisp.svn-base: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /dot/examples/tsl.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/html/de.setf.utility/master/dot/examples/tsl.pdf -------------------------------------------------------------------------------- /walker/.svn/README.txt: -------------------------------------------------------------------------------- 1 | This is a Subversion working copy administrative directory. 2 | Visit http://subversion.tigris.org/ for more information. 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | tmp/ 2 | *.dribble 3 | *.fasl 4 | *.dfsl 5 | *.cfsl 6 | *.fas 7 | *.lib 8 | *.o 9 | *.*fsl 10 | *.bak 11 | *~ 12 | bin/ 13 | 14 | #Mac stuff 15 | Icon? 16 | .DS_Store -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | *.html -crlf 2 | *.htm -crlf 3 | *.dot -crlf 4 | *.svg -crlf 5 | *.ent -crlf 6 | *.css -crlf 7 | *.dtd -crlf 8 | *.xs -crlf 9 | *.xsl -crlf 10 | *.xml -crlf 11 | *.xmlq -crlf 12 | -------------------------------------------------------------------------------- /dot/tests/tests.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: common-lisp-user; -*- 2 | 3 | (in-package :common-lisp-user) 4 | 5 | (asdf:defsystem :de.setf.utility.dot.test 6 | :nicknames (:setf.dot.test) 7 | :serial t 8 | :depends-on (:de.setf.utility.dot) 9 | :components ((:file "dot"))) 10 | 11 | :de.setf.utility.dot.tests 12 | -------------------------------------------------------------------------------- /dot/tests/dot-model-1.dot: -------------------------------------------------------------------------------- 1 | graph test { rankdir=lr;a [label=node1, fontsize="9", fontname=courier];b [label=node2, fontsize="9", fontname=courier];c [label=node3, fontsize="9", fontname=courier];d [label=node4, fontsize="9", fontname=courier];a -- b [fontname=courier, fontsize="9", label=edge1];a -- c [fontname=courier, fontsize="9", label=edge2];b -- c [fontname=courier, fontsize="9", label=edge3];b -- d [fontname=courier, fontsize="9", label=edge4];c -- b [fontname=courier, fontsize="9", label=edge5];} -------------------------------------------------------------------------------- /walker/.svn/text-base/sysdcl.lisp.svn-base: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: common-lisp-user; -*- 2 | 3 | (in-package :common-lisp-user) 4 | 5 | (define-system 6 | (:walker) 7 | () 8 | "library:de;setf;utility;walker;package" 9 | "library:de;setf;utility;walker;walker" 10 | "library:de;setf;utility;walker;package-graph" 11 | "library:de;setf;utility;walker;class-graph" 12 | "library:de;setf;utility;walker;function-graph" 13 | #+mcl "library:edu;umass;cs;bburns;bsd" 14 | #+mcl "library:de;setf;utility;walker;mcl" 15 | ) 16 | 17 | :EOF 18 | -------------------------------------------------------------------------------- /test/rspec/rspec.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: common-lisp-user; -*- 2 | 3 | (in-package :common-lisp-user) 4 | 5 | (asdf:defsystem :de.setf.utility.test.rspec 6 | :depends-on (:de.setf.utility.test 7 | :de.setf.utility.codecs.etf 8 | #+sbcl 9 | :sb-posix) 10 | :serial t 11 | :components ((:file "package") 12 | (:file "rspec")) 13 | :long-description 14 | "These files implement a primitive BERT-coded repl to permit to drive 15 | a LISP process from Ruby for rspec-driven tests. See `rspec-lisp.rb` for 16 | a sketch of the connection mechanism.") 17 | 18 | -------------------------------------------------------------------------------- /test/test.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: common-lisp-user; -*- 2 | 3 | (in-package :common-lisp-user) 4 | 5 | (asdf:defsystem :de.setf.utility.test 6 | :nicknames (:setf.test) 7 | :depends-on (:de.setf.utility.dot 8 | :de.setf.utility.walker 9 | :de.setf.utility.mime) 10 | :serial t 11 | :components ((:file "package") 12 | (:file "test-unit") 13 | #+(or digitool clozure) (:file "monitor") 14 | #+(or digitool clozure) (:file "profiler"))) 15 | 16 | ;;; needs to be in this file rather than its own. 17 | ;;; otherwise it shadows the .asd from the test module 18 | 19 | (asdf:defsystem :de.setf.utility.test.test 20 | :depends-on (:de.setf.utility.test) 21 | :components ((:module "test" 22 | :components ((:file "test-unit") 23 | (:file "monitor"))))) 24 | 25 | 26 | :de.setf.utility.test 27 | -------------------------------------------------------------------------------- /codecs/bert/bert.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: cl-user; -*- 2 | 3 | ;;; This file is the system definition for the BERT codec module for the 'de.setf.utility' Common Lisp library. 4 | ;;; 5 | ;;; Copyright 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved 6 | ;;; `de.setf.utility` is free software: you can redistribute it and/or modify it under the terms of version 3 7 | ;;; of the the GNU Lesser General Public License as published by the Free Software Foundation. 8 | ;;; 9 | ;;; `de.setf.utility` is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 10 | ;;; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 11 | ;;; See the the GNU Lesser General Public License for more details. 12 | ;;; 13 | ;;; A copy of the GNU Lesser General Public License should be included with `de.setf.utility`, as `lgpl.txt`. 14 | ;;; If not, see the GNU [site](http://www.gnu.org/licenses/). 15 | 16 | 17 | (in-package :cl-user) 18 | 19 | (asdf:defsystem :de.setf.utility.codecs.bert 20 | :version "0.1" 21 | :depends-on (:de.setf.utility.codecs) 22 | :serial t 23 | :description "BERT stream and buffer codecs." 24 | :components ((:file "bert")) 25 | :long-description) 26 | 27 | 28 | -------------------------------------------------------------------------------- /asdf/asdf.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: common-lisp-user; -*- 2 | 3 | (in-package :common-lisp-user) 4 | 5 | (asdf:defsystem :de.setf.utility.asdf 6 | :description "Patches and additions for ASDF" 7 | :long-description "Patches and additions for ASDF : 8 | hierarchical-names : interprets names such as that for this system as system location designators relative 9 | to the registered search roots. 10 | contingent-on : adds that dependency form to the operation process. 11 | dependency : adds form-level definition dependency to asdf models post-facto. analyzes an active 12 | image to compute operator dependency and impute effective modules. uses the results to 13 | genereate the effective asdf system description. 14 | graph : encode a system dependency model as a .dot graph. 15 | 16 | See graph.lisp for an example." 17 | 18 | :depends-on (:de.setf.utility.dot 19 | :de.setf.utility.walker) 20 | :serial t 21 | 22 | :components ((:file "patches") 23 | (:file "operators") 24 | (:file "hierarchical-names") 25 | (:file "contingent-on") 26 | (:file "dependency") 27 | (:file "graph"))) 28 | 29 | 30 | -------------------------------------------------------------------------------- /bsd/bsd.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: common-lisp-user; -*- 2 | 3 | (in-package :common-lisp-user) 4 | 5 | ;;; 6 | ;;; This file is the system definition for the 'bsd' component of the 'de.setf.utility' Common Lisp library. 7 | ;;; 8 | ;;; Copyright 2003, 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved 9 | ;;; 'de.setf.utility' is free software: you can redistribute it and/or modify 10 | ;;; it under the terms of version 3 of the GNU Lesser General Public License as published by 11 | ;;; the Free Software Foundation. 12 | ;;; 13 | ;;; 'de.setf.utility' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 14 | ;;; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU Lesser General Public License for more details. 16 | ;;; 17 | ;;; A copy of the GNU Lesser General Public License should be included with 'de.setf.utility, as `lgpl.txt`. 18 | ;;; If not, see the GNU [site](http://www.gnu.org/licenses/). 19 | 20 | 21 | (asdf:defsystem :de.setf.utility.bsd 22 | :version "20100425-1.0" 23 | :serial t 24 | :components ((:file "bsd")) 25 | :description 26 | "This is a one-component system to make the bsd support available for mcl 27 | independent of any other utility code.") 28 | -------------------------------------------------------------------------------- /graph/graph.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: common-lisp-user; -*- 2 | 3 | (in-package :common-lisp-user) 4 | 5 | ;;; This file is the system definition for the graph module for the 'de.setf.utility' Common Lisp library. 6 | ;;; 7 | ;;; Copyright 2003, 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved 8 | ;;; 'de.setf.utility' is free software: you can redistribute it and/or modify 9 | ;;; it under the terms of version 3 of the GNU Lesser General Public License as published by 10 | ;;; the Free Software Foundation. 11 | ;;; 12 | ;;; 'de.setf.utility' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 13 | ;;; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 14 | ;;; See the GNU Lesser General Public License for more details. 15 | ;;; 16 | ;;; A copy of the GNU Lesser General Public License should be included with 'de.setf.utility, as `lgpl.txt`. 17 | ;;; If not, see the GNU [site](http://www.gnu.org/licenses/). 18 | 19 | 20 | (asdf:defsystem :de.setf.utility.graph 21 | :nicknames (:setf.graph) 22 | :depends-on (:de.setf.utility.clos) 23 | :components ((:file "package") 24 | (:file "classes" :depends-on ("package")) 25 | (:file "walk" :depends-on ("classes")) 26 | (:file "generate" :depends-on ("walk")))) 27 | 28 | :de.setf.utility.graph 29 | -------------------------------------------------------------------------------- /codecs/test/vector-stream.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: de.setf.utility.implementation; -*- 2 | 3 | (in-package :de.setf.utility.implementation) 4 | 5 | 6 | (:documentation 7 | "This file tests vector streams for the `de.setf.utility.codecs` library." 8 | 9 | (:copyright 10 | "Copyright 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved 11 | 'de.setf.utility.codecs' is free software: you can redistribute it and/or modify 12 | it under the terms of version 3 of the GNU Lesser General Public License as published by 13 | the Free Software Foundation. 14 | 15 | 'de.setf.utility.codecs' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 16 | without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 17 | See the GNU Lesser General Public License for more details. 18 | 19 | A copy of the GNU Lesser General Public License should be included with 'de.setf.utility.codecs, as `lgpl.txt`. 20 | If not, see the GNU [site](http://www.gnu.org/licenses/).")) 21 | 22 | 23 | (test:test codecs.vector-stream.byte-codecs 24 | (let* ((stream (make-instance 'vector-io-stream :length 256))) 25 | (dotimes (i 256) (stream-write-byte stream i)) 26 | (stream-position stream 0) 27 | (dotimes (i 256 t) 28 | (unless (eql i (stream-read-byte stream)) (return nil))))) 29 | 30 | 31 | -------------------------------------------------------------------------------- /test/rspec/package.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: cl-user; -*- 2 | 3 | ;;; This file is the package definition for the rspec module for the 'de.setf.utility' 4 | ;;; Common Lisp library. 5 | ;;; 6 | ;;; Copyright 2003, 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved 7 | ;;; 'de.setf.utility' is free software: you can redistribute it and/or modify 8 | ;;; it under the terms of version 3 of the GNU Lesser General Public License as published by 9 | ;;; the Free Software Foundation. 10 | ;;; 11 | ;;; 'de.setf.utility' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 12 | ;;; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;;; See the GNU Lesser General Public License for more details. 14 | ;;; 15 | ;;; A copy of the GNU Lesser General Public License should be included with 'de.setf.utility, as `lgpl.txt`. 16 | ;;; If not, see the GNU [site](http://www.gnu.org/licenses/). 17 | 18 | 19 | (in-package :cl-user) 20 | 21 | (eval-when (:load-toplevel :compile-toplevel :execute) 22 | (macrolet ((extern (symbol) 23 | (let ((name (symbol-name symbol))) 24 | `(export (intern ,name :de.setf.utility.test) :de.setf.utility.test))) 25 | (externs (&rest symbols) 26 | `(progn ,@(mapcar #'(lambda (s) `(extern ,s)) symbols)))) 27 | 28 | (externs :*rspec-input* :*rspec-output*))) 29 | 30 | -------------------------------------------------------------------------------- /dot/dot.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: common-lisp-user; -*- 2 | 3 | #| 4 | 5 | 6 | This file is the system definition for the 'de.setf.utility.dot' (or 'setf.dot') library component. 7 | 8 | 9 | 'setf.dot' is free software: you can redistribute it and/or modify 10 | it under the terms of the GNU Lesser General Public License as published by 11 | the Free Software Foundation, either version 3 of the License, or 12 | (at your option) any later version. 13 | 14 | 'setf.dot' is distributed in the hope that it will be useful, 15 | but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | GNU Lesser General Public License for more details. 18 | 19 | You should have received a copy of the GNU Lesser General Public License 20 | along with 'setf.dot'. If not, see the GNU site. 21 | 22 | 23 | |# 24 | 25 | (in-package :common-lisp-user) 26 | 27 | (asdf:defsystem :de.setf.utility.dot 28 | :depends-on (:de.setf.utility) 29 | :serial t 30 | :components ((:file "package") 31 | (:file "dot")) 32 | :description 33 | "setf.dot implements various encoding interfaces and a model for graphvis graphic 34 | descriptions." 35 | :long-description 36 | "See index.html for a complete description.") 37 | 38 | :de.setf.utility.dot 39 | -------------------------------------------------------------------------------- /walker/.svn/text-base/package.lisp.svn-base: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: de.setf.utility.implementation; -*- 2 | 3 | ;;; 4 | ;;; packages for generic walker 5 | ;;; 6 | ;;; (c)2003 james anderson 7 | ;;; all rights reserved 8 | ;;; see ncsl.html or http://www.setf.de/library/ncsl.html 9 | 10 | (in-package :common-lisp-user) 11 | 12 | (modPackage :de.setf.utility.walker 13 | (:use-only ) 14 | (:ensure :de.setf.utility.dot) 15 | (:ensure :de.setf.utility.clos) 16 | (:use-by :de.setf.utility.implementation) 17 | (:export-only 18 | :*walker* 19 | :caching-walker 20 | :cyclic-walker 21 | :endorder-node-walker 22 | :link-navigator 23 | :link-relation-operator 24 | :make-walker-cache-entry 25 | :map-walk-link 26 | :node-navigator 27 | :node-operator 28 | :node-predecessor-navigator 29 | :node-successor-navigator 30 | :preorder-link-walker 31 | :preorder-node-walker 32 | :symmetric-node-walker 33 | :walk-link 34 | :walk-link-qualifier 35 | :walk-link-relation 36 | :walk-model 37 | :walk-navigate-link 38 | :walk-navigator 39 | :walk-node 40 | :walk-node-predecessors 41 | :walk-node-qualifier 42 | :walk-node-self 43 | :walk-node-successors 44 | :walk-operator 45 | :walk-qualifiers 46 | :walker 47 | :walker-clear-cache 48 | :walker-entry 49 | :walker-entry-node 50 | :walker-entry-properties 51 | :walker-entry-visited 52 | :walker-initialize-cache 53 | :walker-link-qualifiers 54 | :walker-node-cache-entry 55 | :walker-node-properties 56 | :walker-node-qualifiers 57 | :walker-node-visited 58 | :walker-node-visited-p 59 | :walker-relations 60 | )) 61 | 62 | 63 | :EOF 64 | -------------------------------------------------------------------------------- /codecs/etf/etf.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: cl-user; -*- 2 | 3 | ;;; This file is the system definition for the ETF codec module for the 'de.setf.utility' Common Lisp library. 4 | ;;; 5 | ;;; Copyright 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved 6 | ;;; `de.setf.utility` is free software: you can redistribute it and/or modify it under the terms of version 3 7 | ;;; of the the GNU Lesser General Public License as published by the Free Software Foundation. 8 | ;;; 9 | ;;; `de.setf.utility` is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 10 | ;;; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 11 | ;;; See the the GNU Lesser General Public License for more details. 12 | ;;; 13 | ;;; A copy of the GNU Lesser General Public License should be included with `de.setf.utility`, as `lgpl.txt`. 14 | ;;; If not, see the GNU [site](http://www.gnu.org/licenses/). 15 | 16 | 17 | (in-package :cl-user) 18 | 19 | (asdf:defsystem :de.setf.utility.codecs.etf 20 | :version "0.1" 21 | :depends-on (:de.setf.utility.codecs) 22 | :serial t 23 | :description "ETF/BERT stream and buffer codecs." 24 | :components ((:file "package") 25 | (:file "etf")) 26 | :long-description "This module implements BERT[[1]] codecs based on the `de.setf.utility.codecs` operators 27 | for streams and byte buffer coding. It supports just those aspects of 'Erlang term format' required for to encode 28 | call requests and responses consistent with BERT, but does define operators for the entire RPC protocol. 29 | This means that it is, by intention, much less complete than cleric[[2]]. 30 | --- 31 | [1] : [bert-rpc.org](http://bert-rpc.org/) 32 | [2] : [CLERIC](http://github.com/flambard/CLERIC)") 33 | -------------------------------------------------------------------------------- /codecs/test/test.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: common-lisp-user; -*- 2 | 3 | (in-package :common-lisp-user) 4 | 5 | (:documentation 6 | "This file is the system definition for tests for the `de.setf.utility.codecs` Connon Lisp library." 7 | 8 | (copyright 9 | "Copyright 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved 10 | 'de.setf.utility.codecs' is free software: you can redistribute it and/or modify 11 | it under the terms of version 3 of the GNU Lesser General Public License as published by 12 | the Free Software Foundation. 13 | 14 | 'de.setf.utility.codecs' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 15 | without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 16 | See the GNU Lesser General Public License for more details. 17 | 18 | A copy of the GNU Lesser General Public License should be included with 'de.setf.utility.codecs, as `lgpl.txt`. 19 | If not, see the GNU [site](http://www.gnu.org/licenses/).") 20 | 21 | (:history 22 | (20101028 "extractd and extended from amqp codec tests to match the independent library interface."))) 23 | 24 | 25 | (asdf:defsystem :de.setf.utility.codecs.test 26 | :serial t 27 | :version 20101026 28 | :depends-on (:de.setf.utility.codecs 29 | :de.setf.utility.test) 30 | :components ((:file "types") 31 | (:file "utilities") 32 | (:file "vector-stream") 33 | (:file "byte-codecs") 34 | (:file "character-codecs") 35 | (:file "float-codecs")) 36 | 37 | :description 38 | "This is the sub-library for testing :de.setf.utility.codecs") 39 | 40 | 41 | 42 | ;;; (asdf:load-system :de.setf.utility.codecs.test) 43 | ;;; (test:execute-test :codecs.* :mode :report) 44 | 45 | 46 | -------------------------------------------------------------------------------- /walker/walker.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: common-lisp-user; -*- 2 | 3 | (in-package :common-lisp-user) 4 | 5 | ;;; 6 | ;;; This file is the system definition for the walker module for the 'de.setf.utility' Common Lisp library. 7 | ;;; 8 | ;;; Copyright 2003, 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved 9 | ;;; 'de.setf.utility' is free software: you can redistribute it and/or modify 10 | ;;; it under the terms of version 3 of the GNU Lesser General Public License as published by 11 | ;;; the Free Software Foundation. 12 | ;;; 13 | ;;; 'de.setf.utility' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 14 | ;;; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU Lesser General Public License for more details. 16 | ;;; 17 | ;;; A copy of the GNU Lesser General Public License should be included with 'de.setf.utility, as `lgpl.txt`. 18 | ;;; If not, see the GNU [site](http://www.gnu.org/licenses/). 19 | 20 | (asdf:defsystem :de.setf.utility.walker 21 | :depends-on (:de.setf.utility.dot 22 | :de.setf.utility.clos 23 | :net.common-lisp.closer-mop 24 | #+sbcl 25 | :sb-introspect 26 | #+mcl 27 | :de.setf.utility.bsd 28 | ) 29 | :serial t 30 | :components ((:file "package") 31 | (:file "parameters") 32 | (:file "introspection") 33 | (:file "walker") 34 | (:file "introspective-walker") 35 | (:file "source-walker") 36 | (:file "class-graph") 37 | (:file "function-graph") 38 | (:file "package-graph") 39 | #+mcl 40 | (:file "mcl"))) 41 | 42 | :de.setf.utility.walker 43 | -------------------------------------------------------------------------------- /test/test/test-unit.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: de.setf.utility.implementation; -*- 2 | 3 | ;;; This file is part of the 'de.setf.utility' library component. 4 | ;;; (c) 2002, 2009 james anderson 5 | ;;; 6 | ;;; 'de.setf.utility' is free software: you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Lesser General Public License as published by 8 | ;;; the Free Software Foundation, either version 3 of the License, or 9 | ;;; (at your option) any later version. 10 | ;;; 11 | ;;; 'de.setf.utility' is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU Lesser General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Lesser General Public License 17 | ;;; along with 'de.setf.utility'. If not, see the GNU site. 18 | 19 | ;;; tests for :de.setf.utility.test 20 | 21 | ;;; 20090505 ja : new 22 | 23 | (in-package :de.setf.utility.implementation) 24 | 25 | (dsu:test test-unit-prerequisite 26 | (eq (test-unit-name *test-unit*) :test-unit-prerequisite)) 27 | 28 | (dsu:test test-unit.1 29 | (equal 1 1) 30 | :mode :verbose) 31 | 32 | (dsu:test test-unit.1 33 | (equal 1 1) 34 | :mode :report) 35 | 36 | (dsu:test test-unit.1 37 | (equal 1 1) 38 | :mode :silent) 39 | 40 | (dsu:test test-unit.1 41 | (equal 1 1) 42 | :mode nil 43 | :prerequisites '(test-unit-prerequisite)) 44 | 45 | (dsu:test test-unit.2 46 | (equal 1 0)) 47 | 48 | 49 | (dsu:test execute-test.1 50 | "test with a wild-card test name, that passed/failed count is correct 51 | and include the prerequisite," 52 | (dsu:execute-test :test-unit.** :force-p t) 53 | :values '(:failed 2 1 0 0)) 54 | 55 | ;;(dsu:execute-test :execute-test.1) 56 | 57 | :de.setf.utility 58 | -------------------------------------------------------------------------------- /mime/mime.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: common-lisp-user; -*- 2 | 3 | (in-package :common-lisp-user) 4 | 5 | ;;; 6 | ;;; This file is the system definition for the mime module for the 'de.setf.utility' Common Lisp library. 7 | ;;; 8 | ;;; Copyright 2003, 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved 9 | ;;; 'de.setf.utility' is free software: you can redistribute it and/or modify 10 | ;;; it under the terms of version 3 of the GNU Lesser General Public License as published by 11 | ;;; the Free Software Foundation. 12 | ;;; 13 | ;;; 'de.setf.utility' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 14 | ;;; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU Lesser General Public License for more details. 16 | ;;; 17 | ;;; A copy of the GNU Lesser General Public License should be included with 'de.setf.utility, as `lgpl.txt`. 18 | ;;; If not, see the GNU [site](http://www.gnu.org/licenses/). 19 | 20 | 21 | (asdf:defsystem :de.setf.utility.mime 22 | :nicknames (:setf.mime) 23 | :depends-on (:de.setf.utility) 24 | :description "de.setf.utility.mime defines singletons to designate mime content types and 25 | codecs for the related content encodings." 26 | :serial t 27 | :components ((:file "package") 28 | (:file "mime") 29 | (:file "content-encoding")) 30 | 31 | :long-description 32 | "See : (among others) 33 | 34 | - [wikipedia](http://en.wikipedia.org/wiki/MIME) 35 | - [rfc2046](http://tools.ietf.org/html/rfc2046) : (MIME) Part Two: Media Types 36 | - [rfc2049](http://tools.ietf.org/html/rfc2049) : (MIME) Part Five: Conformance Criteria and Examples 37 | 38 | Each type is defined as a singleton in a major/minor type lattice and bound to a 39 | global variable with the same name. The `text/*` types include a slot for a content encoding 40 | name.") 41 | 42 | 43 | 44 | :de.setf.utility.mime 45 | -------------------------------------------------------------------------------- /codecs/test/types.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: de.setf.utility.implementation; -*- 2 | 3 | (in-package :de.setf.utility.implementation) 4 | 5 | (:documentation 6 | "This file tests type definitions for the `de.setf.utility.codecs` library." 7 | 8 | (:copyright 9 | "Copyright 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved 10 | 'de.setf.utility.codecs' is free software: you can redistribute it and/or modify 11 | it under the terms of version 3 of the GNU Lesser General Public License as published by 12 | the Free Software Foundation. 13 | 14 | 'de.setf.utility.codecs' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 15 | without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 16 | See the GNU Lesser General Public License for more details. 17 | 18 | A copy of the GNU Lesser General Public License should be included with 'de.setf.utility.codecs, as `lgpl.txt`. 19 | If not, see the GNU [site](http://www.gnu.org/licenses/).")) 20 | 21 | (test:test codec.types.float 22 | (and (typep double-float-positive-infinity 'double-float) 23 | (typep double-float-negative-infinity 'double-float) 24 | (typep (symbol-value 'double-float-nan) 'double-float) 25 | (typep (symbol-value 'single-float-nan) 'single-float) 26 | (typep single-float-positive-infinity 'single-float) 27 | (typep single-float-negative-infinity 'single-float))) 28 | 29 | (test:test codecs.types.buffer 30 | (and (typep (make-array 4 :element-type '(unsigned-byte 8)) 'simple-byte-buffer) 31 | (typep (make-array 4 :element-type '(unsigned-byte 8)) 'byte-buffer) 32 | (typep (make-array 4 :element-type '(unsigned-byte 8) :fill-pointer 0) 'byte-buffer) 33 | (typep (make-array 4 :element-type 'character) 'simple-character-buffer) 34 | (typep (make-array 4 :element-type 'character) 'character-buffer) 35 | (typep (make-array 4 :element-type 'character :fill-pointer 0) 'character-buffer))) 36 | 37 | -------------------------------------------------------------------------------- /documentation-stub.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: de.setf.utility.implementation; -*- 2 | 3 | 4 | (in-package :de.setf.utility.implementation) 5 | 6 | ;;; This file is part of the 'de.setf.utility' Common Lisp library. 7 | ;;; It file defines a 'null' macro-expansion for the top-level documention operator. 8 | ;;; It is loaded by the minimal utility module to render documentation forms invisible. 9 | ;;; 10 | ;;; Copyright 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved 11 | ;;; 'de.setf.utility' is free software: you can redistribute it and/or modify 12 | ;;; it under the terms of version 3 of the GNU Lesser General Public License as published by 13 | ;;; the Free Software Foundation. 14 | ;;; 15 | ;;; 'de.setf.utility' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 16 | ;;; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 17 | ;;; See the GNU Lesser General Public License for more details. 18 | ;;; 19 | ;;; A copy of the GNU Lesser General Public License should be included with 'de.setf.utility, as `lgpl.txt`. 20 | ;;; If not, see the GNU [site](http://www.gnu.org/licenses/). 21 | 22 | 23 | (in-package :de.setf.utility.implementation) 24 | 25 | (defmacro :documentation (&rest arguments) 26 | (declare (ignore arguments)) 27 | (values)) 28 | 29 | #+mcl 30 | (progn 31 | (setf (ccl:assq ':documentation *fred-special-indent-alist*) 1)) 32 | 33 | (defgeneric test-features (specification) 34 | (:method ((spec symbol)) 35 | (when (member spec *features*) t)) 36 | (:method ((spec null)) 37 | t) 38 | (:method ((spec cons)) 39 | (ecase (pop spec) 40 | (and (every #'test-features spec)) 41 | (or (some #'test-features spec)) 42 | (not (not (test-features (first spec))))))) 43 | 44 | (defmacro require-features ((&rest features) message &rest args) 45 | `(eval-when (:compile-toplevel :load-toplevel :execute) 46 | (unless (test-features ',features) 47 | (cerror "Continue anyway." ,message ,@args)))) 48 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | # DE.SETF.UTILITY: a collection of Common Lisp utilities 4 | 5 | 6 | `de.setf.utility` is a collection of Common Lisp utility functions and several purpose-specific libraries. 7 | 8 | The extension libraries include 9 | 10 | * stream and buffer serialization : `de.setf.utility.codecs` 11 | * Erlang Term Format serialization : `de.setf.utility.codecs.etf` 12 | * date coding : `de.setf.utility.date` 13 | * graphiz `.dot` graph generation : `de.setf.utility.dot` 14 | * mime content types and simple utf coding : `de.setf.utility.mime` 15 | * unit tests : `de.setf.utility.test` 16 | * an rspec interface : `de.setf.utility.test.rspec` 17 | * code, image, package, system walkers : `de.setf.utility.walker` 18 | 19 | ## Status 20 | 21 | 22 | ### Downloading 23 | 24 | The core library and all extensions are available from [GitHub](http://github.com/lisp/de.setf.utility). 25 | 26 | ### Building 27 | 28 | `de.set.utility` and its extensions are built with [`asdf`](http://www.common-lisp.net/projects/asdf). 29 | The core library can be built by adding its the `utility.asd` system definition file to the asdf registry and executing 30 | 31 | (asdf:load-system :de.setf.utility) 32 | 33 | The extension libraries require support for hierarchical system names in order to locate their prerequistes. 34 | The file `build-init.lisp` does the necessary to permit a build from the command-line. For example 35 | 36 | $ cd $SOURCE_ROOT 37 | $ sbcl --userinit build-init.lisp \ 38 | --eval "(asdf:load-system :de.setf.utility.test.rspec)" \ 39 | --eval '(cl-user::save-image "sbcl-rspec.core")' 40 | 41 | 42 | ## Licensing 43 | 44 | This version is released under version 3 of the GNU Lesser General Public License ([LGPL](http://www.gnu.org/licenses/gpl.html)). 45 | The core library has no external dependencies. `de.set.utility.walker` depends on runtime-sepecific introspection 46 | extensions. `de.setf.utility.tst.rspec` depends on posix extensions for access to syslog. 47 | 48 | -------- 49 | ![made with mcl](http://www.digitool.com/img/mcl-made-1.gif "Made With MCL") 50 | 51 | 52 | -------------------------------------------------------------------------------- /codecs/codecs.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: cl-user; -*- 2 | 3 | ;;; This file is the system definition for the codec module for the 'de.setf.utility' Common Lisp library. 4 | ;;; 5 | ;;; Copyright 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved 6 | ;;; `de.setf.utility` is free software: you can redistribute it and/or modify it under the terms of version 3 7 | ;;; of the the GNU Lesser General Public License as published by the Free Software Foundation. 8 | ;;; 9 | ;;; `de.setf.utility` is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 10 | ;;; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 11 | ;;; See the the GNU Lesser General Public License for more details. 12 | ;;; 13 | ;;; A copy of the GNU Lesser General Public License should be included with `de.setf.utility`, as `lgpl.txt`. 14 | ;;; If not, see the GNU [site](http://www.gnu.org/licenses/). 15 | 16 | 17 | (in-package :cl-user) 18 | 19 | (asdf:defsystem :de.setf.utility.codecs 20 | :version "0.1" 21 | :depends-on (:de.setf.utility.mime) 22 | :serial t 23 | :description "binary stream and buffer elementary codecs." 24 | :components ((:file "package") 25 | (:file "types") 26 | (:file "utilities") 27 | (:file "byte-codecs") 28 | (:file "character-codecs") 29 | (:file "float-codecs") 30 | (:file "vector-stream") 31 | (:module "meta" 32 | :serial t 33 | :components ((:file "meta") 34 | (:file "float")))) 35 | :long-description 36 | "`de.setf.utility.codecs` implements binary codecs for Lisp data, buffers, and streams. 37 | The primitive types are integers and float values, and character sequences. The operators combine the 38 | core capabilities of the AMQP[[1]] data-wire-coding and Apache Thrft[[2]] binary protocol to serve as the 39 | base implementation for further codecs, such as BERT[[3]] and Apache Avro[[4]]. 40 | ---- 41 | 42 | [1]: http://www.amqp.org/ 43 | [2]: http://incubator.apache.org/thrift/ 44 | [3]: http://bert-rpc.org/ 45 | [4]: http://avro.apache.org/ ") 46 | 47 | 48 | -------------------------------------------------------------------------------- /test/package.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: common-lisp-user; -*- 2 | 3 | ;;; This file is part of the 'de.setf.utility' Common Lisp library. 4 | ;;; It is the package definition for the test utilities. 5 | 6 | ;;; Copyright 2002, 2009, 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved 7 | ;;; 'de.setf.utility' is free software: you can redistribute it and/or modify 8 | ;;; it under the terms of version 3 of the GNU Lesser General Public License as published by 9 | ;;; the Free Software Foundation. 10 | ;;; 11 | ;;; 'de.setf.utility' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 12 | ;;; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;;; See the GNU Lesser General Public License for more details. 14 | ;;; 15 | ;;; A copy of the GNU Lesser General Public License should be included with 'de.setf.utility, as `lgpl.txt`. 16 | ;;; If not, see the GNU [site](http://www.gnu.org/licenses/). 17 | 18 | (in-package :common-lisp-user) 19 | 20 | ;; this is already present for some load orders 21 | ;; for other this guarantees it 22 | (eval-when (:compile-toplevel :load-toplevel :execute) 23 | (intern #.(string :test) :de.setf.utility.implementation)) 24 | 25 | (defpackage :de.setf.utility.test 26 | (:use ) 27 | (:nicknames :test) 28 | (:import-from :de.setf.utility.implementation 29 | :test) 30 | (:export 31 | :*class.test-unit* 32 | :*test-unit-mode* 33 | :*test-output* 34 | :*test-unit* 35 | :define-test 36 | :deftest 37 | :deftests 38 | :execute-test 39 | :execute-tests 40 | :find-monitor 41 | :find-tests 42 | :find-test 43 | :function-monitor 44 | :generic-function-monitor 45 | :ignored-error 46 | :initialize-monitor 47 | :make-test-unit 48 | :method-monitor 49 | :monitor 50 | :report-monitor 51 | :test-unit 52 | :test-unit-path 53 | :test-unit-status 54 | :test-unit-verbose-p 55 | :unintern-test 56 | :unmonitor 57 | :test 58 | :test-and 59 | :test-equal 60 | :test-unit-situation 61 | :time-and-memory 62 | :with-test-situation 63 | )) 64 | 65 | (modpackage :de.setf.utility 66 | (:export-from :test)) 67 | 68 | (pushnew :de.setf.utility.test *features*) 69 | 70 | -------------------------------------------------------------------------------- /utility.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: common-lisp-user; -*- 2 | 3 | (in-package :common-lisp-user) 4 | 5 | ;;; 6 | ;;; This file is the system definition for the 'de.setf.utility' Common Lisp library. 7 | ;;; 8 | ;;; Copyright 2003, 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved 9 | ;;; 'de.setf.utility' is free software: you can redistribute it and/or modify 10 | ;;; it under the terms of version 3 of the GNU Lesser General Public License as published by 11 | ;;; the Free Software Foundation. 12 | ;;; 13 | ;;; 'de.setf.utility' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 14 | ;;; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU Lesser General Public License for more details. 16 | ;;; 17 | ;;; A copy of the GNU Lesser General Public License should be included with 'de.setf.utility, as `lgpl.txt`. 18 | ;;; If not, see the GNU [site](http://www.gnu.org/licenses/). 19 | 20 | #+lispworks 21 | (setq hcl:*packages-for-warn-on-redefinition* 22 | (remove "KEYWORD" hcl:*packages-for-warn-on-redefinition* :test 'string-equal)) 23 | 24 | (asdf:defsystem :de.setf.utility 25 | :version "20100214-1.0" 26 | ;;:pathname (when (ignore-errors (logical-pathname-translations "LIBRARY")) 27 | ;; (make-pathname :host "LIBRARY" 28 | ;; :directory '(:absolute "de" "setf" "utility"))) 29 | :serial t 30 | :components ((:file "package") 31 | (:file "pathnames") 32 | (:file "modpackage") 33 | (:file "documentation-stub" 34 | :depends-on ("modpackage")) 35 | (:file "string") 36 | (:file "conditions") 37 | (:module "clos" ; minimal clos utilities 38 | :depends-on ("string") 39 | :components ((:file "clos-classes"))) 40 | (:module "test" ; minimal test unit utilities 41 | :components ((:file "package") 42 | (:file "test-unit" :depends-on ("package")))) 43 | (:file "date" 44 | :depends-on ("modpackage")) 45 | (:file "list" 46 | :depends-on ("modpackage")))) 47 | -------------------------------------------------------------------------------- /asdf/patches.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: asdf; -*- 2 | 3 | ;;; This file is is a constituent of the 'de.setf.utility' library component. 4 | ;;; It contains patches for ASDF. 5 | ;;; (c) 2009 james anderson 6 | ;;; 7 | ;;; 'de.setf.utility' is free software: you can redistribute it and/or modify 8 | ;;; it under the terms of the GNU Lesser General Public License as published by 9 | ;;; the Free Software Foundation, either version 3 of the License, or 10 | ;;; (at your option) any later version. 11 | ;;; 12 | ;;; 'de.setf.utility' is distributed in the hope that it will be useful, 13 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;;; GNU Lesser General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU Lesser General Public License 18 | ;;; along with 'de.setf.utility'. If not, see the GNU [site](http://www.gnu.org/licenses/). 19 | 20 | ;;; 21 | ;;; 2009-00-00 janderson patches as they appeared 22 | 23 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 24 | 25 | (in-package :asdf) 26 | 27 | 28 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 | ;;; 30 | ;;; content 31 | ;;; 32 | ;;; patches to asdf operators 33 | ;;; 34 | 35 | ;;; relative pathname computation 36 | ;;; at least in clozure, it requires the null directory to avoid 37 | ;;; being created with (:absolute) and thereby intefereing with any merge. 38 | 39 | (defun merge-component-relative-pathname (pathname name type) 40 | (multiple-value-bind (relative path filename) 41 | (split-path-string name) 42 | (merge-pathnames 43 | (or pathname (make-pathname :directory `(,relative ,@path))) 44 | (if type 45 | (make-pathname :directory nil :name filename :type type) 46 | filename)))) 47 | 48 | ;;; 49 | ;;; correct setf to return the passed value 50 | 51 | (defmethod (setf component-property) (new-value (c component) property) 52 | (let ((a (assoc property (component-properties c) :test #'equal))) 53 | (cond (a 54 | (setf (cdr a) new-value)) 55 | (t 56 | (setf (component-properties c) 57 | (acons property new-value (slot-value c 'properties))) 58 | new-value)))) 59 | -------------------------------------------------------------------------------- /clos/clos.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: common-lisp-user; -*- 2 | 3 | (in-package :common-lisp-user) 4 | 5 | ;;; 6 | ;;; This file is the system definition for the clos module for the 'de.setf.utility' Common Lisp library. 7 | ;;; 8 | ;;; Copyright 2003, 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved 9 | ;;; 'de.setf.utility' is free software: you can redistribute it and/or modify 10 | ;;; it under the terms of version 3 of the GNU Lesser General Public License as published by 11 | ;;; the Free Software Foundation. 12 | ;;; 13 | ;;; 'de.setf.utility' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 14 | ;;; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU Lesser General Public License for more details. 16 | ;;; 17 | ;;; A copy of the GNU Lesser General Public License should be included with 'de.setf.utility, as `lgpl.txt`. 18 | ;;; If not, see the GNU [site](http://www.gnu.org/licenses/). 19 | 20 | (asdf:defsystem :de.setf.utility.clos 21 | :depends-on (:de.setf.utility) 22 | :description "CLOS utilities for the de.setf.utility library" 23 | :components ((:file "package") 24 | (:file "clos-classes" :depends-on ("package")) 25 | (:file "clos-methods" :depends-on ("package")) 26 | (:file "clone-instance" :depends-on ("package")) 27 | (:file "denominated" :depends-on ("package")) 28 | (:file "print-object-slots" :depends-on ("package"))) 29 | 30 | :long-description 31 | "`de.setf.utility.clos` adds several utilities for CLOS models: 32 | 33 | - `abstract-standard-class`, `abstract-standard-method`, `abstract-standard-generic-function` 34 | define a protocol to require method definitions for concrete classes. 35 | - `clone-instance` generic function defines deep cloning protocol for objects 36 | - `denominated` standard method combination variation permits a specializing class to elect and order 37 | the effective method's constituents 38 | - `denominated-progn` similar variation on the `progn` combination 39 | - `locked-standard` a `standard` method combination with a lock 40 | - `print-object-slots` defines a base method and a definition form (`def-print-object-slots`) to 41 | support printing objects.") 42 | 43 | :de.setf.utility.clos 44 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: common-lisp-user; -*- 2 | 3 | ;;; This file is the core package definition for the 'de.setf.utility' Common Lisp library. 4 | ;;; 5 | ;;; Copyright 2003, 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved 6 | ;;; 'de.setf.utility' is free software: you can redistribute it and/or modify 7 | ;;; it under the terms of version 3 of the GNU Lesser General Public License as published by 8 | ;;; the Free Software Foundation. 9 | ;;; 10 | ;;; 'de.setf.utility' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 11 | ;;; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 12 | ;;; See the GNU Lesser General Public License for more details. 13 | ;;; 14 | ;;; A copy of the GNU Lesser General Public License should be included with 'de.setf.utility, as `lgpl.txt`. 15 | ;;; If not, see the GNU [site](http://www.gnu.org/licenses/). 16 | 17 | 18 | ;;; 19 | ;;; content : the utility package definition 20 | 21 | ;;; 20100210.janderson : establised as its own file 22 | 23 | (in-package :common-lisp-user) 24 | 25 | (defpackage :de.setf.utility 26 | (:use ) 27 | (:nicknames :d.s.u :dsu) 28 | #+mcl 29 | (:import-from :ccl 30 | :stream-reader 31 | :stream-writer 32 | :stream-tyi 33 | :stream-tyo) 34 | (:export 35 | :*logical-source-type* 36 | :*logical-binary-type* 37 | :*package-host-name* 38 | :*package-operations* 39 | :*physical-source-type* 40 | :check-feature 41 | :clean-package 42 | :define-library-host 43 | :defvarconstant 44 | :edit-package 45 | :ensure-package 46 | :find-packages 47 | :load-package 48 | :make-binary-translation-target 49 | :modpackage 50 | :modify-package 51 | :modify-package-operation 52 | :package-not-found 53 | :package-pathname 54 | :package-version 55 | :purge-package 56 | :require-features 57 | :runtime-directory-name 58 | :set-relative-logical-pathname-translations 59 | :stream-reader 60 | :stream-writer 61 | :stream-tyi 62 | :stream-tyo)) 63 | 64 | (defpackage :de.setf.utility.implementation 65 | (:use #+:CCL :ccl 66 | :common-lisp 67 | :de.setf.utility) 68 | #+sbcl 69 | (:import-from :sb-gray 70 | :stream-line-column 71 | :stream-write-char 72 | :stream-write-sequence 73 | :stream-write-string) 74 | (:documentation "This is the package for source files in the :de.setf.utility library module.")) 75 | 76 | 77 | (pushnew :de.setf.utility *features*) 78 | -------------------------------------------------------------------------------- /walker/source-walker.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: de.setf.utility.implementation; -*- 2 | 3 | (in-package :de.setf.utility.implementation) 4 | 5 | (:documentation "This file is a place-holder for source walking operators for the 'de.setf.utility' library." 6 | 7 | (copyright 8 | "Copyright 2003, 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved" 9 | "'de.setf.utility' is free software: you can redistribute it and/or modify 10 | it under the terms of version 3 of the GNU Lesser General Public License as published by 11 | the Free Software Foundation. 12 | 13 | 'de.setf.utility' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 14 | without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | See the GNU Lesser General Public License for more details. 16 | 17 | A copy of the GNU Lesser General Public License should be included with 'de.setf.utility, as `lgpl.txt`. 18 | If not, see the GNU [site](http://www.gnu.org/licenses/).")) 19 | 20 | ;;; 21 | ;;; utilities 22 | 23 | (defun read-file-package-names (pathname &aux names form (eof (gensym)) (error (gensym))) 24 | (labels ((extract-name (form) 25 | (when (consp form) 26 | (let ((operator (first form))) 27 | (cond ((eq operator 'eval-when) 28 | (mapcar #'extract-name (cddr form))) 29 | ((and (search "package" (string operator) :test #'char-equal) 30 | (symbolp (second form))) 31 | (pushnew (string (second form)) names :test #'string=))))))) 32 | (when (pathname-name pathname) 33 | (with-open-file (stream pathname :direction :input) 34 | (loop (setf form (handler-case (read stream nil eof) 35 | (error () error))) 36 | (when (or (eq eof form) (eq form error)) (return)) 37 | (when (consp form) (extract-name form))) 38 | names)))) 39 | 40 | ;(mapcar #'read-file-package-names (directory "LIBRARY:de;setf;utility;*;*.lisp")) 41 | 42 | (defmethod walk-packages ((root t) (packages pathname) op &rest options) 43 | (apply #'walk-packages root 44 | (remove-duplicates (apply #'append 45 | (mapcar #'read-file-package-names 46 | (if (directory-pathname-p packages) 47 | (directory (make-pathname :name :wild :type :wild :defaults packages)) 48 | (list packages))))) 49 | op 50 | options)) 51 | 52 | :de.setf.utility.walker 53 | -------------------------------------------------------------------------------- /asdf/operators.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: asdf; -*- 2 | 3 | ;;; This file is is a constituent of the 'de.setf.utility' library component. 4 | ;;; It contains patches for ASDF. 5 | ;;; (c) 2009 james anderson 6 | ;;; 7 | ;;; 'de.setf.utility' is free software: you can redistribute it and/or modify 8 | ;;; it under the terms of the GNU Lesser General Public License as published by 9 | ;;; the Free Software Foundation, either version 3 of the License, or 10 | ;;; (at your option) any later version. 11 | ;;; 12 | ;;; 'de.setf.utility' is distributed in the hope that it will be useful, 13 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;;; GNU Lesser General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU Lesser General Public License 18 | ;;; along with 'de.setf.utility'. If not, see the GNU [site](http://www.gnu.org/licenses/). 19 | 20 | ;;; 21 | ;;; 2010-02-03 janderson independent file 22 | 23 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 24 | 25 | (in-package :asdf) 26 | 27 | 28 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 | ;;; 30 | ;;; content 31 | ;;; 32 | ;;; additional to asdf operators 33 | ;;; (setf find-system) 34 | ;;; load-op (system &rest args) 35 | ;;; edit (system) 36 | ;;; 37 | 38 | (eval-when (:compile-toplevel :load-toplevel :execute) 39 | (export '(edit-op) :asdf)) 40 | 41 | 42 | 43 | (defun (setf find-system) (system name) 44 | (if system 45 | (setf (gethash (coerce-name name) *defined-systems*) 46 | (cons (get-universal-time) system)) 47 | (remhash (coerce-name name) *defined-systems*)) 48 | system) 49 | 50 | (unless (fboundp 'load-op) 51 | (defun load-op (system &rest args) 52 | (apply #'operate 'load-op system args))) 53 | 54 | (defclass edit-op (operation) 55 | ()) 56 | 57 | (defmethod perform ((operation edit-op) (system system)) 58 | (ed (or (system-source-file system) 59 | (let ((system-name (component-name system))) 60 | (make-pathname :name (subseq system-name (1+ (or (position #\. system-name :from-end t) -1))) 61 | :type "asd" 62 | :defaults (component-relative-pathname system)))))) 63 | 64 | (defmethod perform ((operation edit-op) (file source-file)) 65 | (ed (component-pathname file))) 66 | 67 | 68 | (defgeneric edit-op (component) 69 | (:method ((component t)) 70 | (operate 'edit-op component)) 71 | 72 | (:method ((pathname pathname)) 73 | (ed pathname))) 74 | 75 | 76 | ;;; (edit-op :de.setf.amqp) 77 | -------------------------------------------------------------------------------- /walker/parameters.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: de.setf.utility.implementation; -*- 2 | ;;; 3 | 4 | (in-package :de.setf.utility.implementation) 5 | 6 | (:documentation "This file defines a parameters for the walking/graphic operators for the 'de.setf.utility' 7 | library." 8 | 9 | (copyright 10 | "Copyright 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved" 11 | "'de.setf.utility' is free software: you can redistribute it and/or modify 12 | it under the terms of version 3 of the GNU Lesser General Public License as published by 13 | the Free Software Foundation. 14 | 15 | 'de.setf.utility' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 16 | without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 17 | See the GNU Lesser General Public License for more details. 18 | 19 | A copy of the GNU Lesser General Public License should be included with 'de.setf.utility, as `lgpl.txt`. 20 | If not, see the GNU [site](http://www.gnu.org/licenses/).") 21 | 22 | (history 23 | (delta 20100310 "janderson" "reorganized to consolidate image/runtime operators and 24 | isolate the runtime-depencies."))) 25 | 26 | 27 | (defparameter *graph-rankdir* "LR" 28 | "The graphviz graph orientation (rank direction) for function, packages, etc. graphs.") 29 | 30 | (defparameter *graph-size* "8.5,11" 31 | "The graphviz page size for function, package, etc. graphs") 32 | 33 | (defparameter *graph-ratio* "compress" 34 | "The graphviz ratio for function, package, etc. graphs") 35 | 36 | (defparameter *graph-margin* ".5" 37 | "The graphviz page margin for function, package, etc. graphs") 38 | 39 | 40 | (defparameter *walk-extent* nil 41 | "The collection of objects within which navigition is to remain. Can be instances or packages. 42 | If *walk-extent-boundary* is :open, this restricts link operations as well. If the boundary is :closed, 43 | then the link operation is included, but the respective node is not.") 44 | 45 | (defparameter *walk-extent-boundary* :open 46 | "See *walk-extent*.") 47 | 48 | (defparameter *walk-depth* nil 49 | "bound when walking to permit applications to constrain depth.") 50 | 51 | ;; dot-graphing for classes 52 | 53 | (defvar *walk-superclass-link* 'superclass 54 | "binds the link identifier for class-to-superclass links. the default value is superclass") 55 | 56 | (defvar *walk-subclass-link* 'subclass 57 | "binds the link identifier for class-to-superclass links. the default value is subclass") 58 | 59 | (defvar *walker* nil 60 | "binds the current walker within walk-model.") 61 | 62 | (defvar *walker-cache* nil 63 | "bound to the the current walker's cache - or some variation thereof during documentation generation.") 64 | 65 | (defparameter *walker-cycle* ()) 66 | 67 | 68 | :de.setf.utility.walker 69 | 70 | -------------------------------------------------------------------------------- /codecs/etf/package.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: de.setf.utility.implementation; -*- 2 | 3 | (in-package :de.setf.utility.implementation) 4 | 5 | ;;; This file is the system definition for the ETF codec module for the 'de.setf.utility' Common Lisp library. 6 | ;;; 7 | ;;; Copyright 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved 8 | ;;; `de.setf.utility` is free software: you can redistribute it and/or modify it under the terms of version 3 9 | ;;; of the the GNU Lesser General Public License as published by the Free Software Foundation. 10 | ;;; 11 | ;;; `de.setf.utility` is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 12 | ;;; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;;; See the the GNU Lesser General Public License for more details. 14 | ;;; 15 | ;;; A copy of the GNU Lesser General Public License should be included with `de.setf.utility`, as `lgpl.txt`. 16 | ;;; If not, see the GNU [site](http://www.gnu.org/licenses/). 17 | 18 | 19 | 20 | (defpackage :de.setf.utility.etf 21 | (:use :de.setf.utility.codecs) 22 | (:nicknames :etf) 23 | (:export :*intern-operator* 24 | :*package* 25 | :*buffer-get-term-hook* 26 | :*buffer-set-term-hook* 27 | :*stream-read-term-hook* 28 | :*stream-write-term-hook* 29 | :atom_cache_ref 30 | :atom_ext 31 | :binary_ext 32 | :bit_binary_ext 33 | :export_ext 34 | :float_ext 35 | :fun_ext 36 | :integer_ext 37 | :large_tuple_ext 38 | :new_float_ext 39 | :new_fun_ext 40 | :nil_ext 41 | :large_big_ext 42 | :list_ext 43 | :new_reference_ext 44 | :pid_ext 45 | :port_ext 46 | :reference_ext 47 | :small_atom_ext 48 | :small_big_ext 49 | :small_integer_ext 50 | :small_tuple_ext 51 | :string_ext 52 | 53 | :nil 54 | :true 55 | :false 56 | 57 | :decode-term 58 | :decode-bert-term 59 | :encode-term 60 | :encode-bert-term 61 | :term-to-binary ; NYI - need to promote vector streams 62 | :binary-to-term ; NYI 63 | 64 | :stream-read-term 65 | :stream-write-term 66 | :buffer-set-term 67 | :buffer-get-term) 68 | 69 | (:documentation "The home package for the Erlang 'external term format' tag names, and interface 70 | operators names. It includes all tag names, internal and api coding operator names and the 71 | also uses the :de.setf.utility.codecs package for abbreviated access to its operator names. 72 | It exports the api and all standard term tag names, even though not all are implemented.")) 73 | -------------------------------------------------------------------------------- /codecs/test/utilities.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: de.setf.utility.implementation; -*- 2 | 3 | (in-package :de.setf.utility.implementation) 4 | 5 | (:documentation 6 | "This file tests utilities for the `de.setf.utility.codecs` library." 7 | 8 | (:copyright 9 | "Copyright 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved 10 | 'de.setf.utility.codecs' is free software: you can redistribute it and/or modify 11 | it under the terms of version 3 of the GNU Lesser General Public License as published by 12 | the Free Software Foundation. 13 | 14 | 'de.setf.utility.codecs' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 15 | without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 16 | See the GNU Lesser General Public License for more details. 17 | 18 | A copy of the GNU Lesser General Public License should be included with 'de.setf.utility.codecs, as `lgpl.txt`. 19 | If not, see the GNU [site](http://www.gnu.org/licenses/).")) 20 | 21 | (test:test codecs.signed-byte 22 | (flet ((test-sign (op specs) 23 | (loop for (bytes value) in specs 24 | unless (= (funcall op bytes) value) 25 | return nil 26 | finally (return t)))) 27 | (let ((l 0)) 28 | (and (test-sign 'sign-byte-8 '((#x80 -128) (#xfe -2) (#x00 0) (#x01 1) (#x7f 127))) 29 | (test-sign 'sign-byte-16 `((#x8000 ,(- (expt 2 15))) (#xfffe -2) 30 | (#x00 0) 31 | (#x0001 1) (#x7fff ,(1- (expt 2 15))))) 32 | (test-sign 'sign-byte-32 `((#x80000000 ,(- (expt 2 31))) (#xfffffffe -2) 33 | (#x00000000 0) 34 | (#x00000001 1) (#x7fffffff ,(1- (expt 2 31))))) 35 | (test-sign 'sign-byte-64 `((#x8000000000000000 ,(- (expt 2 63)) (#xfffffffffffffffe -2) 36 | (#x0000000000000000 0) 37 | (#x0000000000000001 1) (#x7fffffffffffffff ,(1- (expt 2 63)))))) 38 | (setf l 8) 39 | (= (sign-byte #xfe 8) -2 (sign-byte #xfe l)) 40 | (setf l 16) 41 | (= (sign-byte #xfffe 16) -2 (sign-byte #xfffe l)) 42 | (setf l 32) 43 | (= (sign-byte #xfffffffe 32) -2 (sign-byte #xfffffffe l)) 44 | (setf l 64) 45 | (= (sign-byte #xfffffffffffffffe 64) -2 (sign-byte #xfffffffffffffffe l)))))) 46 | 47 | 48 | (test:test codecs.ensure-buffer-length 49 | (let ((buffer (make-array 32 :adjustable t :fill-pointer 7))) 50 | (setf buffer (ensure-buffer-length buffer 63)) 51 | (and (= (length buffer) 7) 52 | (>= (array-dimension buffer 0) 63)))) 53 | 54 | (test:test codecs.cons-length 55 | (and (= (cons-length '(a s d f)) 4) 56 | (= (cons-length '(a s d . f)) 3))) 57 | -------------------------------------------------------------------------------- /walker/package.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: cl-user; -*- 2 | 3 | ;;; This file is the package definition for the walker module for 'de.setf.utility' 4 | ;;; Common Lisp library. 5 | ;;; 6 | ;;; Copyright 2003, 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved 7 | ;;; 'de.setf.utility' is free software: you can redistribute it and/or modify 8 | ;;; it under the terms of version 3 of the GNU Lesser General Public License as published by 9 | ;;; the Free Software Foundation. 10 | ;;; 11 | ;;; 'de.setf.utility' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 12 | ;;; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;;; See the GNU Lesser General Public License for more details. 14 | ;;; 15 | ;;; A copy of the GNU Lesser General Public License should be included with 'de.setf.utility, as `lgpl.txt`. 16 | ;;; If not, see the GNU [site](http://www.gnu.org/licenses/). 17 | 18 | 19 | ;;; 20 | ;;; content : packages for generic walker 21 | ;;; 22 | 23 | (in-package :cl-user) 24 | 25 | (de.setf.utility:modpackage :de.setf.utility.walker 26 | (:nicknames :dsw) 27 | (:use-only ) 28 | (:use :de.setf.utility.dot) 29 | (:use :de.setf.utility) 30 | (:use-by :de.setf.utility.implementation) 31 | #+ccl 32 | (:import-from :ccl :function-name) 33 | (:export-only 34 | :*graph-rankdir* 35 | :*graph-size* 36 | :*graph-ratio* 37 | :*graph-margin* 38 | :*walker* 39 | :*walker-cache* 40 | :*walk-depth* 41 | :*walk-extent* 42 | :*walk-superclass-link* 43 | :*walk-subclass-link* 44 | :caching-walker 45 | :cyclic-walker 46 | :endorder-node-walker 47 | :find-definition 48 | :in-extent-p 49 | :link-navigator 50 | :link-relation-operator 51 | :make-walker-cache-entry 52 | :map-walk-link 53 | :node-navigator 54 | :node-operator 55 | :node-predecessor-navigator 56 | :node-successor-navigator 57 | :object-designator 58 | :object-source-information 59 | :preorder-link-walker 60 | :preorder-node-walker 61 | :symmetric-node-walker 62 | :function-walker 63 | :walk-function 64 | :graph-function 65 | :print-function 66 | :function-lambda-list 67 | :function-name 68 | :function-callers 69 | :function-calls 70 | :function-package 71 | :package-walker 72 | :graph-packages 73 | :print-packages 74 | :walk-classes 75 | :walk-functions 76 | :walk-image 77 | :walk-link 78 | :walk-link-qualifier 79 | :walk-link-relation 80 | :walk-model 81 | :walk-navigate-link 82 | :walk-navigator 83 | :walk-node 84 | :walk-node-constituents 85 | :walk-node-predecessors 86 | :walk-node-qualifier 87 | :walk-node-self 88 | :walk-node-successors 89 | :walk-operator 90 | :walk-packages 91 | :walk-qualifiers 92 | :walker 93 | :walker-clear-cache 94 | :walker-entry 95 | :walker-entry-node 96 | :walker-entry-properties 97 | :walker-entry-visited 98 | :walker-initialize-cache 99 | :walker-link-qualifiers 100 | :walker-node-cache-entry 101 | :walker-node-properties 102 | :walker-node-property 103 | :walker-node-qualifiers 104 | :walker-node-visited 105 | :walker-node-visited-p 106 | :walker-relations 107 | )) 108 | 109 | 110 | :de.setf.utility.walker 111 | 112 | -------------------------------------------------------------------------------- /graph/package.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: common-lisp-user; -*- 2 | 3 | (in-package :common-lisp-user) 4 | 5 | ;;; This file ist the package definition for graph module for the 'de.setf.utility' Common Lisp library. 6 | ;;; 7 | ;;; Copyright 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved 8 | ;;; 'de.setf.utility' is free software: you can redistribute it and/or modify 9 | ;;; it under the terms of version 3 of the GNU Lesser General Public License as published by 10 | ;;; the Free Software Foundation. 11 | ;;; 12 | ;;; 'de.setf.utility' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 13 | ;;; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 14 | ;;; See the GNU Lesser General Public License for more details. 15 | ;;; 16 | ;;; A copy of the GNU Lesser General Public License should be included with 'de.setf.utility, as `lgpl.txt`. 17 | ;;; If not, see the GNU [site](http://www.gnu.org/licenses/). 18 | 19 | ;;; Copyright 2002 james anderson 20 | ;;; 20020121 internal to cl-xml 21 | ;;; Copyright 2003 james anderson 22 | ;;; 20030902 factored out as a utility 23 | ;;; Copyright 2009 james anderson 24 | ;;; 20090405 combined the model and operator packages asthe distinction had not made it easier to use/import. 25 | ;;; it's better to just use a short prefix. 26 | 27 | 28 | (modPackage :de.setf.utility.graph 29 | (:nicknames :setf.graph :sg) 30 | (:documentation 31 | "The package :de.setf.utility.graph owns the symbols which name terms (types , predicates, and operations) 32 | in the abstract graph node/path model. It exports the core of a graph modela and path navigation interface. 33 | It uses no packages. It is neither exported through nor used by any 34 | package. The names are often quite brief and best isolated from other packages to avoid conflicts. 35 | They appear in implementation source files _with_ the package prefix.") 36 | (:version "1.000") 37 | (:use-only ) 38 | (:export-only 39 | :*null-generator* 40 | :ancestor 41 | :ancestor-count 42 | :ancestor-p 43 | :annotations 44 | :child 45 | :children 46 | :child-p 47 | :generate-ancestors 48 | :generate-annotations 49 | :generate-children 50 | :generate-children-reversed 51 | :generate-descendants 52 | :generate-descendants-reversed 53 | :generate-parent 54 | :generate-predecessor-siblings 55 | :generate-predecessors 56 | :generate-annotations 57 | :generate-root 58 | :generate-root-and-descendants 59 | :generate-self 60 | :generate-self-and-ancestors 61 | :generate-self-and-children 62 | :generate-self-and-descendants 63 | :generate-self-and-descendants-reversed 64 | :generate-successor-siblings 65 | :generate-successors 66 | :leaf 67 | :leaf-p 68 | :node 69 | :node-p 70 | :parent 71 | :parent-p 72 | :root 73 | :root-p 74 | :walk-ancestors 75 | :walk-annotations 76 | :walk-children 77 | :walk-children-reversed 78 | :walk-descendants 79 | :walk-descendants-reversed 80 | :walk-parent 81 | :walk-predecessor-siblings 82 | :walk-predecessors 83 | :walk-root 84 | :walk-root-and-descendants 85 | :walk-self 86 | :walk-self-and-ancestors 87 | :walk-self-and-children 88 | :walk-self-and-descendants 89 | :walk-self-and-descendants-reversed 90 | :walk-successor-siblings 91 | :walk-successors 92 | )) 93 | 94 | 95 | :de.setf.utility.graph 96 | 97 | -------------------------------------------------------------------------------- /codecs/meta/float.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: de.setf.utility.meta; -*- 2 | 3 | ;;; This file is float parser for the codec module for the 'de.setf.utility' Common Lisp library. 4 | ;;; 5 | ;;; Copyright 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved 6 | ;;; `de.setf.utility` is free software: you can redistribute it and/or modify it under the terms of version 3 7 | ;;; of the the GNU Lesser General Public License as published by the Free Software Foundation. 8 | ;;; 9 | ;;; `de.setf.utility` is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 10 | ;;; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 11 | ;;; See the the GNU Lesser General Public License for more details. 12 | ;;; 13 | ;;; A copy of the GNU Lesser General Public License should be included with `de.setf.utility`, as `lgpl.txt`. 14 | ;;; If not, see the GNU [site](http://www.gnu.org/licenses/). 15 | 16 | 17 | (in-package :de.setf.utility.meta) 18 | 19 | 20 | (defun meta:parse-float (string &aux (s +1) (es +1) (i 0) (f 0) (e 0) 21 | (m nil) (f-count 0) (i-count 0) (e-count 0) (v 0) d) 22 | (with-string-meta (string) 23 | (and 24 | (match 25 | "[{#\\+ [#\\- !(setq s -1)] []} 26 | *[@(\"0123456789\" d) !(setf i (+ (* i 10) (digit-char-p d)) i-count (1+ i-count))] 27 | {#\\. []} 28 | *[@(\"0123456789\" d) !(setf f (+ (* f 10) (digit-char-p d)) f-count (1+ f-count))] 29 | {@(\"eEsSdDfFlL\" m) []} 30 | {#\\+ [#\\- !(setq es -1)] []} 31 | *[@(\"0123456789\" d) !(setf e (+ (* e 10) (digit-char-p d)) e-count (1+ e-count))] 32 | ]") 33 | (when (> (+ f-count i-count) 0) 34 | (when (> f-count 0) (setf f (/ f (expt 10 f-count)))) 35 | (setf v (+ i f)) 36 | 37 | (ecase *read-default-float-format* 38 | ;; constraint exponents 39 | ((short-float single-float) 40 | (if (plusp es) 41 | (when (> e 38) 42 | (return-from meta:parse-float de.setf.utility.codecs:single-float-positive-infinity)) 43 | (when (> e 45) 44 | (return-from meta:parse-float de.setf.utility.codecs:single-float-negative-infinity)))) 45 | ((double-float long-float) 46 | (if (plusp es) 47 | (when (> e 308) 48 | (return-from meta:parse-float de.setf.utility.codecs:double-float-positive-infinity)) 49 | (when (> e 324) 50 | (return-from meta:parse-float de.setf.utility.codecs:double-float-negative-infinity))))) 51 | 52 | (when (plusp e-count) (setf v (* v (expt 10 (* es e))))) 53 | (when (< s 0) (setf v (- v))) 54 | (case m 55 | ((nil #\E #\e) (float v (ecase *read-default-float-format* 56 | (short-float 0.0s0) 57 | (single-float 0.0f0) 58 | (double-float 0.0d0) 59 | (long-float 0.0l0)))) 60 | ((#\S #\s) (float v 0.0s0)) 61 | ((#\D #\d) (float v 0.0d0)) 62 | ((#\F #\f) (float v 0.0f0)) 63 | ((#\L #\l) (float v 0.0l0))))))) 64 | 65 | ;;; (let ((*read-default-float-format* 'short-float)) (meta:parse-float "0.02173913E434782608")) 66 | ;;; (let ((*read-default-float-format* 'double-float)) (meta:parse-float "0.02173913E434782608")) 67 | ;;; (let ((*read-default-float-format* 'double-float)) (meta:parse-float "0.02173913E308")) 68 | -------------------------------------------------------------------------------- /mime/package.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: de.setf.utility.implementation; -*- 2 | 3 | (in-package :de.setf.utility.implementation) 4 | 5 | ;;; This file extends the package definition for 'de.setf.utility' Common Lisp library 6 | ;;; to incorporate names for mime-related operators and classes. It also defined a `MIME` package 7 | ;;; to comprehend names for the mime types themselves. 8 | ;;; 9 | ;;; Copyright 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved 10 | ;;; 'de.setf.utility' is free software: you can redistribute it and/or modify 11 | ;;; it under the terms of version 3 of the GNU Lesser General Public License as published by 12 | ;;; the Free Software Foundation. 13 | ;;; 14 | ;;; 'de.setf.utility' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 15 | ;;; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 16 | ;;; See the GNU Lesser General Public License for more details. 17 | ;;; 18 | ;;; A copy of the GNU Lesser General Public License should be included with 'de.setf.utility, as `lgpl.txt`. 19 | ;;; If not, see the GNU [site](http://www.gnu.org/licenses/). 20 | 21 | ;;; Copyright 2009 [james anderson](mailto:james.anderson@setf.de) 22 | ;;; 20100106 james.anderson : added octet-stream 23 | 24 | 25 | (modpackage :de.setf.utility 26 | (:use-only ) 27 | (:use-by :de.setf.utility.implementation) 28 | (:export 29 | :*class.content-encoding* 30 | :*mime-type-package* 31 | :clone-instance 32 | :compute-charset-codecs 33 | :content-encoding 34 | :content-encoding-byte-decoder 35 | :content-encoding-byte-encoder 36 | :content-encoding-encoded-code-point-size 37 | :content-encoding-name 38 | :def-mime-type 39 | :def-mime-type-key 40 | :defmimetype 41 | :defmimetypekey 42 | :encode-string 43 | :size-string 44 | :intern-mime-type-key 45 | :major-mime-type 46 | :mime-type 47 | :mime-type-charset 48 | :mime-type-expression 49 | :mime-type-major-type 50 | :mime-type-minor-type 51 | :mime-type-file-type 52 | :mime-type-p 53 | :minor-mime-type 54 | )) 55 | 56 | (defpackage :mime 57 | (:nicknames :de.setf.utility.mime.type) 58 | (:use ) 59 | 60 | (:documentation 61 | "The MIME package comprises symbols which name mime types. 62 | A name is present for each concrete, major, and minor type, whereby major 63 | and minor types are present both as stems and as .../*, */... generalizations. 64 | Each concrete type is reified as an instance of the respective concrete class, 65 | which is the global value of the respective class name. The class precedence 66 | is arranged such that the generalizations are present as super-classes. Of 67 | which the major-type generaalization preceeds the minor-type.") 68 | 69 | (:import-from :de.setf.utility :mime-type) 70 | (:export 71 | :* 72 | :*/* 73 | :*/plain 74 | :*/xhtml 75 | :*/xml 76 | :*/text 77 | :application 78 | :application/* 79 | :application/json 80 | :application/octet-stream 81 | :application/xml 82 | :application/rdf+xml 83 | :binary 84 | :graphviz 85 | :html 86 | :image 87 | :json 88 | :markdown 89 | :mime-type 90 | :n3 91 | :octet-stream 92 | :plain 93 | :rdf+xml 94 | :svg 95 | :svg+xml 96 | :text 97 | :text/* 98 | :text/markdown 99 | :text/plain 100 | :text/xhtml 101 | :text/html 102 | :text/vnd.graphviz 103 | :text/x-graphviz 104 | :text/xml 105 | :turtle 106 | :vnd.graphviz 107 | :x-graphviz 108 | :xhtml 109 | :xhtml+xml 110 | :xml 111 | )) 112 | 113 | -------------------------------------------------------------------------------- /walker/.svn/entries: -------------------------------------------------------------------------------- 1 | 2 | 4 | 14 | 23 | 32 | 41 | 50 | 59 | 68 | 77 | 86 | 95 | 104 | 113 | 114 | -------------------------------------------------------------------------------- /codecs/utilities.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: de.setf.utility.implementation; -*- 2 | 3 | (in-package :de.setf.utility.implementation) 4 | 5 | (:documentation 6 | "This file defines utilities for the `de.setf.utility.codecs` library." 7 | 8 | (:copyright 9 | "Copyright 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved 10 | 'de.setf.utility.codecs' is free software: you can redistribute it and/or modify 11 | it under the terms of version 3 of the GNU Lesser General Public License as published by 12 | the Free Software Foundation. 13 | 14 | 'de.setf.utility.codecs' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 15 | without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 16 | See the GNU Lesser General Public License for more details. 17 | 18 | A copy of the GNU Lesser General Public License should be included with 'de.setf.utility.codecs, as `lgpl.txt`. 19 | If not, see the GNU [site](http://www.gnu.org/licenses/).")) 20 | 21 | (macrolet ((def-signed-byte (bit-count) 22 | (let ((name (cons-symbol :de.setf.utility.codecs :sign-byte- (prin1-to-string bit-count))) 23 | (max-positive (1- (expt 2 (1- bit-count)))) 24 | (mask (1- (expt 2 bit-count)))) 25 | `(progn (declaim (inline ,name)) 26 | (defun ,name (byte) 27 | ,(format nil "Convert unsigned to signed ~s-bit byte." bit-count) 28 | (if (> byte ,max-positive) ; convert 29 | (- (logxor ,mask (1- byte))) 30 | byte)))))) 31 | (def-signed-byte 8) 32 | (def-signed-byte 16) 33 | (def-signed-byte 32) 34 | (def-signed-byte 64)) 35 | 36 | (defun unsigned-byte-8 (datum) 37 | (logand datum #xff)) 38 | 39 | (define-compiler-macro unsigned-byte-8 (datum) 40 | `(logand ,datum #xff)) 41 | 42 | 43 | (defun sign-byte (value bit-count) 44 | (let ((max-positive (1- (expt 2 (1- bit-count)))) 45 | (mask (1- (expt 2 bit-count)))) 46 | (if (> value max-positive) ; convert 47 | (- (logxor mask (1- value))) 48 | value))) 49 | 50 | (define-compiler-macro sign-byte (&whole form value bit-count) 51 | (if (integerp bit-count) 52 | (let ((max-positive (1- (expt 2 (1- bit-count)))) 53 | (mask (1- (expt 2 bit-count))) 54 | (value-var (gensym))) 55 | `(let ((,value-var ,value)) ; ensure one reference 56 | (if (> ,value-var ,max-positive) ; convert 57 | (- (logxor ,mask (1- ,value-var))) 58 | ,value-var))) 59 | form)) 60 | 61 | 62 | (defun ensure-buffer-length (buffer new-length) 63 | (let ((size (array-dimension buffer 0))) 64 | (unless (>= size new-length) 65 | (setf size (+ new-length size)) 66 | (setf buffer (adjust-array buffer size))) 67 | buffer)) 68 | 69 | (defun cons-length (x &optional (length 0)) 70 | (declare (fixnum length)) 71 | (if (consp x) 72 | (cons-length (rest x) (1+ length)) 73 | length)) 74 | 75 | 76 | ;;; trivial methods absent runtime-specifica 77 | ;;; no eof suppression as it should not happen in mid-term 78 | #-(or ccl sbcl) 79 | (defmethod stream-reader ((stream t)) 80 | (values #'stream-read-byte stream)) 81 | 82 | #+sbcl 83 | (defmethod stream-reader ((stream t)) 84 | (values #'read-byte stream)) 85 | 86 | #-(or ccl sbcl) 87 | (defmethod stream-writer ((stream t)) 88 | (values #'stream-write-byte stream)) 89 | 90 | #+lispworks 91 | (defmethod stream-writer ((stream stream:fundamental-character-output-stream)) 92 | (values #'stream-write-char stream)) 93 | 94 | #+lispworks 95 | (defmethod stream-writer ((stream stream:fundamental-binary-output-stream)) 96 | (values #'stream-write-byte stream)) 97 | 98 | #+sbcl 99 | (defmethod stream-writer ((stream t)) 100 | (values #'(lambda (stream byte) 101 | ;; loud tracing 102 | ;; (sb-posix:syslog 0 " [~3,'0d]" byte) 103 | (write-byte byte stream)) 104 | stream)) 105 | 106 | -------------------------------------------------------------------------------- /walker/package-graph.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: de.setf.utility.implementation; -*- 2 | 3 | (in-package :de.setf.utility.implementation) 4 | 5 | 6 | (:documentation "This file defines a graphviz-based grapher for package constituency and 7 | used-by/uses relations for the 'de.setf.utility' library." 8 | 9 | (copyright 10 | "Copyright 2003, 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved" 11 | "'de.setf.utility' is free software: you can redistribute it and/or modify 12 | it under the terms of version 3 of the GNU Lesser General Public License as published by 13 | the Free Software Foundation. 14 | 15 | 'de.setf.utility' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 16 | without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 17 | See the GNU Lesser General Public License for more details. 18 | 19 | A copy of the GNU Lesser General Public License should be included with 'de.setf.utility, as `lgpl.txt`. 20 | If not, see the GNU [site](http://www.gnu.org/licenses/).") 21 | 22 | (history 23 | (delta 20021120) 24 | (delta 20031101 "janderson" "cleaned up and adjusted for denominated methods") 25 | (delta 20031210 "janderson" "corrected qualifier slot name for walker class") 26 | (delta 20100310 "janderson" "reorganized to consolidate image/runtime operators, 27 | isolate the runtime-depencies."))) 28 | 29 | 30 | 31 | (defun graph-packages (&key packages (stream *standard-output*) 32 | (root (first packages)) 33 | (name "packages") 34 | (level nil) 35 | (count nil) 36 | (options nil) 37 | (size *graph-size*) 38 | (rankdir *graph-rankdir*) 39 | (ratio *graph-ratio*) 40 | (margin *graph-margin*) 41 | (graph-attributes '()) 42 | (graph-arguments graph-attributes)) 43 | (let ((walk-count 0)) 44 | (flet ((put-statement (package &optional (other-package nil op-p) relation) 45 | (when (and (or (null level) (<= *walk-depth* level)) 46 | (or (null count) (<= walk-count count))) 47 | (cond (op-p 48 | ;; a link 49 | (setf.dot:put-edge (package-name package) (package-name other-package) 50 | :label (string relation))) 51 | (t 52 | (incf walk-count) 53 | (setf.dot:put-node (package-name package))))))) 54 | (destructuring-bind (&key (size size) (rankdir rankdir) (margin margin) (ratio ratio) 55 | &allow-other-keys) 56 | graph-arguments 57 | (apply #'setf.dot:context-put-graph stream name 58 | #'(lambda () (apply #'walk-packages root packages #'put-statement options)) 59 | :size size 60 | :ratio ratio 61 | :rankdir rankdir 62 | :margin margin 63 | graph-arguments))) 64 | walk-count)) 65 | 66 | 67 | (defun print-packages (&key packages (stream *standard-output*) (root (first packages))) 68 | (let ((walk-count 0)) 69 | (flet ((print-package-node (package &optional (other-package nil op-p) relation) 70 | (cond (op-p 71 | (terpri stream) 72 | (dotimes (x (+ 5 (* 5 *walk-depth*))) (write-char #\space stream)) 73 | (format stream "~a: ~a" relation (package-name other-package))) 74 | (t 75 | (terpri stream) 76 | (dotimes (x (* 5 *walk-depth*)) (write-char #\space stream)) 77 | (format stream "~a~@[ ~a~]" (package-name package) (package-nicknames package)))) 78 | (incf walk-count) 79 | package)) 80 | (walk-packages root packages #'print-package-node)) 81 | walk-count)) 82 | 83 | 84 | 85 | :de.setf.utility.walker 86 | 87 | -------------------------------------------------------------------------------- /test/test/monitor.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: de.setf.utility.implementation; -*- 2 | 3 | ;;; This file is part of the 'de.setf.utility' library component. 4 | ;;; (c) 2002, 2009 james anderson 5 | ;;; 6 | ;;; 'de.setf.utility' is free software: you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Lesser General Public License as published by 8 | ;;; the Free Software Foundation, either version 3 of the License, or 9 | ;;; (at your option) any later version. 10 | ;;; 11 | ;;; 'de.setf.utility' is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU Lesser General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Lesser General Public License 17 | ;;; along with 'de.setf.utility'. If not, see the GNU site. 18 | 19 | ;;; tests for test coverage monitoring 20 | 21 | (in-package :de.setf.utility.implementation) 22 | 23 | (defpackage :monitor-test-package 24 | (:nicknames :mtp) 25 | (:export :function-to-monitor 26 | :function-to-call 27 | :generic-function-to-monitor)) 28 | 29 | (defun mtp:function-to-monitor (arg) 30 | (cons arg arg)) 31 | 32 | (defun mtp::function-to-call (arg1 arg2) 33 | (cons arg1 arg2)) 34 | 35 | (defgeneric mtp:generic-function-to-monitor (arg) 36 | (:method ((arg t)) (cons t arg)) 37 | (:method ((arg string)) (cons (mtp::function-to-call 'string arg) (call-next-method))) 38 | (:method ((arg number)) (cons (mtp::function-to-call 'number arg) (call-next-method))) 39 | (:method :around ((arg integer)) 40 | (cons (cons (cons :around 'integer) arg) (call-next-method))) 41 | (:method :before ((arg cons)) 42 | (if (eq (first arg) :before) 43 | (mtp::function-to-call (first arg) (rest arg)) 44 | (setf (first arg) :before)))) 45 | 46 | (dsu:test monitor.1 47 | "test that monitoring succeeds" 48 | (progn (clrhash *monitor-registry*) 49 | (monitor :mtp) 50 | (dsu:test-and 51 | (eql (hash-table-count *monitor-registry*) 8) 52 | (find-monitor 'mtp:function-to-monitor) 53 | (find-monitor 'mtp:generic-function-to-monitor) 54 | (find-monitor '(:method mtp:generic-function-to-monitor (t))) 55 | (find-monitor '(:method mtp:generic-function-to-monitor (string))) 56 | (find-monitor '(:method mtp:generic-function-to-monitor (number))) 57 | (find-monitor '(:method mtp:generic-function-to-monitor :around (integer))) 58 | (find-monitor '(:method mtp:generic-function-to-monitor :before (cons)))))) 59 | 60 | (dsu:test monitor.2 61 | "test that monitoring succeeds" 62 | (progn (initialize-monitor :mtp) 63 | (dsu:test-and 64 | (equal (mtp:function-to-monitor 1) '(1 . 1)) 65 | (equal (mtp:generic-function-to-monitor 1) '(((:AROUND . INTEGER) . 1) (NUMBER . 1) T . 1)) 66 | (equal (mtp:generic-function-to-monitor "one") '((STRING . "one") T . "one")) 67 | (equal (mtp:generic-function-to-monitor t) '(t . t)) 68 | (equal (mtp:generic-function-to-monitor 1.0) '((NUMBER . 1.0) T . 1.0)) 69 | (equal (mtp:generic-function-to-monitor '(nil . 1)) '(T :BEFORE . 1)) 70 | 71 | (monitor-called-p 'mtp:function-to-monitor) 72 | (monitor-called-p 'mtp:generic-function-to-monitor) 73 | ;; test the calls-called-p for the method with a conditional call 74 | (equalp (monitor-calls-called-p (find-monitor '(:method mtp:generic-function-to-monitor :before (cons)))) 75 | #(NIL)) 76 | (equal (mtp:generic-function-to-monitor '(:before . 1)) '(T :BEFORE . 1)) 77 | (equalp (monitor-calls-called-p (find-monitor '(:method mtp:generic-function-to-monitor :before (cons)))) 78 | #(t)))) 79 | 80 | 81 | #| 82 | (with-open-file (stream "LIBRARY:test.html" :direction :output :if-exists :supersede 83 | :if-does-not-exist :create) 84 | (report-monitor *monitor-registry* stream mime:text/html)) 85 | 86 | 87 | #| 88 | -------------------------------------------------------------------------------- /clos/print-object-slots.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: de.setf.utility.implementation; -*- 2 | 3 | (in-package :de.setf.utility.implementation) 4 | 5 | ;;; 6 | ;;; This file is part of the 'de.setf.utility' Common Lisp library. 7 | ;;; It defines generic operators to print object instance slots 8 | ;;; 9 | ;;; Copyright 2003, 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved 10 | ;;; 'de.setf.utility' is free software: you can redistribute it and/or modify 11 | ;;; it under the terms of version 3 of the GNU Lesser General Public License as published by 12 | ;;; the Free Software Foundation. 13 | ;;; 14 | ;;; 'de.setf.utility' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 15 | ;;; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 16 | ;;; See the GNU Lesser General Public License for more details. 17 | ;;; 18 | ;;; A copy of the GNU Lesser General Public License should be included with 'de.setf.utility, as `lgpl.txt`. 19 | ;;; If not, see the GNU [site](http://www.gnu.org/licenses/). 20 | 21 | 22 | (modpackage :de.setf.utility 23 | (:export 24 | :def-print-object-slots 25 | :print-object-slots 26 | :print-object-slot-names 27 | :*print-object-slots*)) 28 | 29 | (defvar *print-object-slots* t 30 | "binds an indicator for use by applications to turn the behaviour on and off.") 31 | 32 | (defgeneric print-object-slots (instance stream) 33 | ;(:argument-precedence-order stream instance) 34 | (:method-combination denominated-progn) 35 | 36 | (:method :around ((instance t) (stream t)) 37 | (if *print-object-slots* 38 | (call-next-method) 39 | (write-string "[...]" stream))) 40 | 41 | (:method :between ((instance t) (stream t)) (write-string " " stream)) 42 | 43 | (:method :qualifying ((instance t) (stream t)) 44 | "the general method just computes the names of the combined class and instance slots." 45 | (print-object-slot-names instance stream))) 46 | 47 | 48 | (defgeneric print-object-slot-names (instance-class stream-class) 49 | (:documentation "this is used by the denominated-progn method combination for print-object-slots to 50 | constrain the method qualifiers introspectively.") 51 | 52 | (:method ((instance standard-object) (stream t)) 53 | (print-object-slot-names (class-of instance) stream)) 54 | 55 | (:method ((instance-class standard-class) (stream t)) 56 | (finalize-if-needed instance-class) 57 | (class-slot-names instance-class))) 58 | 59 | 60 | 61 | (defmacro def-print-object-slots (specialized-parameter-list slot-print-specs) 62 | (let ((stream-var (second specialized-parameter-list)) 63 | (object-var (first (first specialized-parameter-list)))) 64 | (when (consp stream-var) 65 | (setf stream-var (first stream-var))) 66 | `(progn 67 | ,@(mapcar #'(lambda (slot-print-spec) 68 | (etypecase slot-print-spec 69 | (symbol 70 | `(defmethod print-object-slots ,slot-print-spec 71 | ,specialized-parameter-list 72 | (format ,stream-var ,(format nil "[~a: ~~a]" slot-print-spec) 73 | (slot-value ,object-var ',slot-print-spec)))) 74 | (cons 75 | (destructuring-bind (slot-designators &rest print-spec) 76 | slot-print-spec 77 | (etypecase slot-designators 78 | (cons ) 79 | ((and symbol (not null)) 80 | (setf slot-designators (list slot-designators)))) 81 | (etypecase (first print-spec) 82 | (string (setf print-spec `((format ,stream-var ,@print-spec)))) 83 | (list )) ; allow a null print-spec 84 | `(defmethod print-object-slots 85 | ,@slot-designators 86 | ,specialized-parameter-list 87 | ,@print-spec))))) 88 | slot-print-specs)))) 89 | 90 | :de.setf.utility 91 | 92 | -------------------------------------------------------------------------------- /dot/tests/dot.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: de.setf.utility.implementation; -*- 2 | 3 | #| 4 | 5 | 6 | This file is part of the 'de.setf.utility.dot' (or 'dot') library component. 7 | It defines dets for .dot file generation and other model processing. 8 | 9 | 10 | 'dot' is free software: you can redistribute it and/or modify 11 | it under the terms of the GNU Lesser General Public License as published by 12 | the Free Software Foundation, either version 3 of the License, or 13 | (at your option) any later version. 14 | 15 | 'dot' is distributed in the hope that it will be useful, 16 | but WITHOUT ANY WARRANTY; without even the implied warranty of 17 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18 | GNU Lesser General Public License for more details. 19 | 20 | You should have received a copy of the GNU Lesser General Public License 21 | along with 'dot'. If not, see the GNU site. 22 | 23 | 24 | abstracted from xqdm-graph 25 | refactored with simpler interface and tests 26 | 27 | 28 | |# 29 | 30 | 31 | (in-package :de.setf.utility.implementation) 32 | 33 | (defparameter *dot-model-1* 34 | '(setf.dot:graph "test" (:rankdir "lr") 35 | (setf.dot:node "a" :label "node1" :fontsize "9" :fontname "courier") 36 | (setf.dot:node "b" :label "node2" :fontsize "9" :fontname "courier") 37 | (setf.dot:node "c" :label "node3" :fontsize "9" :fontname "courier") 38 | (setf.dot:node "d" :label "node4" :fontsize "9" :fontname "courier") 39 | (setf.dot:edge "a" "b" :fontname "courier" :fontsize "9" :label "edge1") 40 | (setf.dot:edge "a" "c" :fontname "courier" :fontsize "9" :label "edge2") 41 | (setf.dot:edge "b" "c" :fontname "courier" :fontsize "9" :label "edge3") 42 | (setf.dot:edge "b" "d" :fontname "courier" :fontsize "9" :label "edge4") 43 | (setf.dot:edge "c" "b" :fontname "courier" :fontsize "9" :label "edge5")) 44 | "An s-expression dot model equivalent to the S-DOT 45 | example") 46 | 47 | (dsut:test dot/graph/1 48 | "Tests the operator specializations for the s-expression model representation. 49 | The constructor context causes the operators to reconstruct an equal model. 50 | The model is equivalent ." 51 | (equalp *dot-model-1* 52 | (setf.dot:with-context (make-instance 'setf.dot:constructor) 53 | (eval *dot-model-1*)))) 54 | 55 | (dsut:test dot/graph/2 56 | "Tests the operator specializations for the .dot encoding. 57 | The constructor context causes the operators to encode the graph to the stream. 58 | The representation is not the same as S-DOT - i don't think its choices are correct." 59 | (with-output-to-string (stream) 60 | (setf.dot:with-context (make-instance 'setf.dot:stream :stream stream) 61 | (eval *dot-model-1*))) 62 | "graph test { rankdir=lr;a [label=node1, fontsize=\"9\", fontname=courier];b [label=node2, fontsize=\"9\", fontname=courier];c [label=node3, fontsize=\"9\", fontname=courier];d [label=node4, fontsize=\"9\", fontname=courier];a -- b [fontname=courier, fontsize=\"9\", label=edge1];a -- c [fontname=courier, fontsize=\"9\", label=edge2];b -- c [fontname=courier, fontsize=\"9\", label=edge3];b -- d [fontname=courier, fontsize=\"9\", label=edge4];c -- b [fontname=courier, fontsize=\"9\", label=edge5];}") 63 | 64 | 65 | (dsut:test dot/graph/3 66 | "test dot interpretation. write the model as a .dot file, invokes dot, and (if os x), opens the file. 67 | upon success, the error codes should both be 0" 68 | (let ((dot-file #p"LIBRARY:de;setf;utility;dot;tests;dot-model-1.dot")) 69 | (with-open-file (stream dot-file 70 | :direction :output :if-exists :supersede :if-does-not-exist :create) 71 | (setf.dot:with-context (make-instance 'setf.dot:stream :stream stream :eol (string #\newline) 72 | :pretty t) 73 | (eval *dot-model-1*))) 74 | ;; requires full program pathname 75 | (logior (nth-value 1 (bsd:run-command #p"opt:local:bin:dot" "-o" #P"tmp:dot-model-1.jpg" "-Tjpg" dot-file)) 76 | (nth-value 1 (bsd:run-command "open" #p"tmp:dot-model-1.jpg")))) 77 | 0) 78 | 79 | 80 | :EOF 81 | -------------------------------------------------------------------------------- /graph/classes.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: de.setf.utility.implementation; -*- 2 | 3 | (in-package :de.setf.utility.implementation) 4 | 5 | (:documentation "Define class and predicate definitions for an abstract graph model 6 | 7 | The definitions bind very few methods and serve instead as abstract interfaces to 8 | indicate a class's support for the minimal x-path-like navigation interface. 9 | see xml:code;*;*-generate.lisp and xml:code;*;*-walk.lisp." 10 | 11 | (copyright 12 | "Copyright 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved" 13 | "'de.setf.utility' is free software: you can redistribute it and/or modify 14 | it under the terms of version 3 of the GNU Lesser General Public License as published by 15 | the Free Software Foundation. 16 | 17 | 'de.setf.utility' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 18 | without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 19 | See the GNU Lesser General Public License for more details. 20 | 21 | A copy of the GNU Lesser General Public License should be included with 'de.setf.utility, as `lgpl.txt`. 22 | If not, see the GNU [site](http://www.gnu.org/licenses/).") 23 | 24 | (history 25 | (copyright "COPYRIGHT 2002 james anderson") 26 | (delta 20020719 "introduced in order to simplify delegation-based clos instance implementation") 27 | (copyright "COPYRIGHT 2003 james anderson") 28 | (delta 20020919 "added cloning methods") 29 | (delta 20030902 "factored out of xml library established as a utility"))) 30 | 31 | ;; 32 | ;; 33 | ;; data model classes 34 | 35 | (def-abstract-class sg:node () 36 | () 37 | (:documentation 38 | "the `node` abstract class indicates that a a concrete specialization 39 | models a vertex in a data graph. 40 | a concrete specialization must define a `name` method.")) 41 | 42 | (def-abstract-class sg:parent (sg:node) 43 | () 44 | (:documentation 45 | "the `parent` abstract class indicates that a vertex has links to children. 46 | a concrete specialization must define 47 | `generate-children`, 48 | `generate-children-reversed`, `walk-children`, 49 | and `walk-children-reversed` methods.")) 50 | 51 | (def-abstract-class sg:child (sg:node) 52 | () 53 | (:documentation 54 | "the `child` abstract class indicates that a class models a vertex 55 | with links to a parent. a concrete specialization must define a 56 | `parent` method.")) 57 | 58 | (def-abstract-class sg:ancestor () 59 | () 60 | (:documentation 61 | "the `ancestor` abstract class indicates that a vertex is accessible along the ancestor path axis. 62 | this differs from the `parent` closure, in that a `root` vertex is the `parent` 63 | of the top-most model vertex, but is not an `ancestor`.")) 64 | 65 | (def-abstract-class sg:root (sg:parent) 66 | () 67 | (:documentation 68 | "the `root` abstract class indicates that a class models the root of the data model graph. 69 | the `root` acts as the `parent` to the uppermost traversable node(s), but is not 70 | an `ancestor`.")) 71 | 72 | (def-abstract-class sg:leaf (sg:child) 73 | () 74 | (:documentation 75 | "the `leaf` abstract class indicates that a vertex is a at the bottom extreme of a data model graph 76 | and, as such, has no further children.")) 77 | 78 | ;; 79 | ;; 80 | ;; predicates, including provisions for built-in data types. 81 | 82 | (def-class-constructors 83 | 84 | sg:ancestor 85 | 86 | (sg:child 87 | (:method ((datum number) &key &allow-other-keys) t) 88 | (:method ((datum string) &key &allow-other-keys) t)) 89 | 90 | (sg:leaf 91 | (:method ((datum number) &key &allow-other-keys) t) 92 | (:method ((datum string) &key &allow-other-keys) t)) 93 | 94 | sg:node 95 | 96 | (sg:parent 97 | (:documentation 98 | "return the node's parent. concrete classes must provide a method.") 99 | (:method ((node sg:child) &key &allow-other-keys))) 100 | 101 | (sg:root 102 | (:documentation 103 | "return the node's respective parent. the default method invokes parent to traverse links to the root. 104 | concrete implementations may provide more direct methods.") 105 | (:method ((node sg:child) &key &allow-other-keys) 106 | (sg:root (sg:parent node))) 107 | (:method ((node sg:root) &key &allow-other-keys) 108 | "the root of a root is an identity function." 109 | node))) 110 | 111 | ;; 112 | ;; 113 | ;; abstract interface 114 | 115 | (def-abstract-generic sg:children (node) 116 | (:documentation 117 | "return the node's children. concrete parent specialization class must provide a method.") 118 | (:method ((node sg:parent)))) 119 | 120 | (def-abstract-generic sg:annotations (node) 121 | (:documentation 122 | "return the node's annotations. every concrete child specialization class must provide a method.") 123 | (:method ((node sg:child)))) 124 | 125 | 126 | :de.setf.utility.graph 127 | -------------------------------------------------------------------------------- /codecs/types.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: de.setf.utility.implementation; -*- 2 | 3 | (in-package :de.setf.utility.implementation) 4 | 5 | (:documentation 6 | "This file defines types for the `de.setf.utility.codecs` library." 7 | 8 | (:copyright 9 | "Copyright 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved 10 | 'de.setf.utility.codecs' is free software: you can redistribute it and/or modify 11 | it under the terms of version 3 of the GNU Lesser General Public License as published by 12 | the Free Software Foundation. 13 | 14 | 'de.setf.utility.codecs' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 15 | without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 16 | See the GNU Lesser General Public License for more details. 17 | 18 | A copy of the GNU Lesser General Public License should be included with 'de.setf.utility.codecs, as `lgpl.txt`. 19 | If not, see the GNU [site](http://www.gnu.org/licenses/).")) 20 | 21 | (defconstant +string-element-type+ 'character) 22 | 23 | ;; don't tell a compiler more than it needs to know, otherwise shorter vectors can conflict with declarations 24 | (deftype byte-buffer (&optional length) 25 | (declare (ignore length)) 26 | `(array (unsigned-byte 8) (*))) 27 | 28 | (deftype simple-byte-buffer (&optional length) 29 | (declare (ignore length)) 30 | `(simple-array (unsigned-byte 8) (*))) 31 | 32 | (deftype character-buffer (&optional length) 33 | (declare (ignore length)) 34 | `(array character (*))) 35 | 36 | (deftype simple-character-buffer (&optional length) 37 | (declare (ignore length)) 38 | `(simple-array character (*))) 39 | 40 | ;;; floating point boundary constants 41 | ;;; define them where an implementation has not prepared them 42 | ;;; 43 | ;;; extended from corkill's openmcl addition 44 | 45 | 46 | #-sbcl 47 | (declaim (double-float double-float-positive-infinity 48 | double-float-negative-infinity) 49 | (single-float single-float-positive-infinity 50 | single-float-negative-infinity)) 51 | 52 | (declaim (double-float double-float-nan) 53 | (single-float single-float-nan)) 54 | 55 | #+mcl 56 | (unless (boundp 'double-float-positive-infinity) 57 | (eval-when (:compile-toplevel :load-toplevel :execute) 58 | (defconstant double-float-positive-infinity 59 | (unwind-protect 60 | (progn 61 | (ccl::set-fpu-mode :division-by-zero nil) 62 | (funcall '/ 0d0)) 63 | (ccl::set-fpu-mode :division-by-zero t))) 64 | 65 | (defconstant double-float-negative-infinity 66 | (unwind-protect 67 | (progn 68 | (ccl::set-fpu-mode :division-by-zero nil) 69 | (funcall '/ -0d0)) 70 | (ccl::set-fpu-mode :division-by-zero t))))) 71 | 72 | #+(or mcl (and clozure (not ccl-1.4))) 73 | (unless (boundp 'double-float-nan) 74 | (defconstant double-float-nan 75 | (unwind-protect 76 | (locally (declare (special double-float-positive-infinity double-float-negative-infinity)) 77 | (ccl::set-fpu-mode :invalid nil) 78 | (funcall '+ double-float-positive-infinity double-float-negative-infinity)) 79 | (ccl::set-fpu-mode :invalid t)))) 80 | 81 | #+(or mcl clozure) 82 | (unless (boundp 'single-float-positive-infinity) 83 | (eval-when (:compile-toplevel :load-toplevel :execute) 84 | (defconstant single-float-positive-infinity 85 | (unwind-protect 86 | (progn 87 | (ccl::set-fpu-mode :division-by-zero nil) 88 | (funcall '/ 0f0)) 89 | (ccl::set-fpu-mode :division-by-zero t))) 90 | 91 | (defconstant single-float-negative-infinity 92 | (unwind-protect 93 | (progn 94 | (ccl::set-fpu-mode :division-by-zero nil) 95 | (funcall '/ -0f0)) 96 | (ccl::set-fpu-mode :division-by-zero t))))) 97 | 98 | #+(or mcl clozure) 99 | (unless (boundp 'single-float-nan) 100 | (defconstant single-float-nan 101 | (unwind-protect 102 | (locally (declare (special single-float-positive-infinity single-float-negative-infinity)) 103 | (ccl::set-fpu-mode :invalid nil) 104 | (funcall '+ single-float-positive-infinity single-float-negative-infinity)) 105 | (ccl::set-fpu-mode :invalid t)))) 106 | 107 | #+sbcl ;; works on osx and linux 108 | (unless (boundp 'single-float-nan) 109 | ;; do _not_ define as constants as sbcl's compiler chokes on any reference to them 110 | ;; do _not_ let it compile the value expressions as it tries to constant-fold them, with similar results. 111 | (sb-vm::with-float-traps-masked (:invalid) 112 | (defparameter single-float-nan 113 | (eval '(+ single-float-positive-infinity single-float-negative-infinity))) 114 | (defparameter double-float-nan 115 | (eval '(+ double-float-positive-infinity double-float-negative-infinity))))) 116 | 117 | 118 | #+lispworks 119 | (progn 120 | (defconstant double-float-positive-infinity +1D++0) 121 | (defconstant double-float-negative-infinity -1D++0) 122 | (defconstant single-float-positive-infinity +1F++0) 123 | (defconstant single-float-negative-infinity -1F++0) 124 | 125 | (defconstant single-float-nan SYSTEM::*SINGLE-FLOAT-NAN*) 126 | (defconstant double-float-nan SYSTEM::*DOUBLE-FLOAT-NAN*)) 127 | -------------------------------------------------------------------------------- /walker/class-graph.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: de.setf.utility.implementation; -*- 2 | 3 | (in-package :de.setf.utility.implementation) 4 | 5 | 6 | (:documentation "This file defines a graphviz-based grapher for package constituency and 7 | used-by/uses relations for the 'de.setf.utility' library." 8 | 9 | (copyright 10 | "Copyright 2003, 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved" 11 | "'de.setf.utility' is free software: you can redistribute it and/or modify 12 | it under the terms of version 3 of the GNU Lesser General Public License as published by 13 | the Free Software Foundation. 14 | 15 | 'de.setf.utility' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 16 | without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 17 | See the GNU Lesser General Public License for more details. 18 | 19 | A copy of the GNU Lesser General Public License should be included with 'de.setf.utility, as `lgpl.txt`. 20 | If not, see the GNU [site](http://www.gnu.org/licenses/).") 21 | 22 | (history 23 | (delta 20021120) 24 | (delta 20031101 "janderson" "cleaned up and adjusted for denominated methods") 25 | (delta 20031210 "janderson" "corrected qualifier slot name for walker class") 26 | (delta 20100310 "janderson" "reorganized to consolidate image/runtime operators, 27 | isolate the runtime-depencies."))) 28 | 29 | 30 | (defun graph-classes (&key packages (stream *standard-output*) class 31 | (name "classes") 32 | (level nil) 33 | (count nil) 34 | (options nil) 35 | (put-node #'(lambda (class) 36 | (setf.dot:put-eol) 37 | (setf.dot:put-node (class-name class)))) 38 | (put-edge #'(lambda (class other-class relation) 39 | (setf.dot:put-eol) 40 | (case relation 41 | (superclass 42 | (setf.dot:put-edge (class-name other-class) (class-name class) 43 | :label "is-a" :arrowhead "none" :arrowtail "normal")) 44 | (subclass 45 | (setf.dot:put-edge (class-name class) (class-name other-class) 46 | :label "is-a" :arrowhead "none" :arrowtail "normal")) 47 | (t 48 | #+ignore ;; handled as part of the node generation 49 | (setf.dot:put-edge (class-name class) (class-name other-class) 50 | :label (string relation)))))) 51 | (put-appendix nil) 52 | (size *graph-size*) 53 | (rankdir *graph-rankdir*) 54 | (ratio *graph-ratio*) 55 | (margin *graph-margin*) 56 | (graph-attributes '()) 57 | (graph-arguments graph-attributes)) 58 | (let ((walk-count 0)) 59 | (flet ((put-statement (class &optional (other-class nil oc-p) relation) 60 | (when (and (or (null level) (<= *walk-depth* level)) 61 | (or (null count) (<= walk-count count))) 62 | (cond (oc-p 63 | ;; an edge 64 | (funcall put-edge class other-class relation)) 65 | (t 66 | (incf walk-count) 67 | (funcall put-node class)))) 68 | class)) 69 | (destructuring-bind (&key (size size) (rankdir rankdir) (margin margin) (ratio ratio) 70 | &allow-other-keys) 71 | graph-arguments 72 | (apply #'setf.dot:context-put-graph stream name 73 | #'(lambda () 74 | (apply #'walk-classes class packages #'put-statement options) 75 | (when put-appendix (funcall put-appendix))) 76 | :size size 77 | :ratio ratio 78 | :rankdir rankdir 79 | :margin margin 80 | graph-arguments))) 81 | walk-count)) 82 | 83 | 84 | (defun print-classes (&key packages (stream *standard-output*) class) 85 | (let ((walk-count 0)) 86 | (flet ((print-class (class &optional (other nil other-p) relation) 87 | (cond (other-p 88 | (terpri stream) 89 | (dotimes (x (* 5 *walk-depth*)) (write-char #\space stream)) 90 | (format stream "~a -> ~a" relation (class-name other))) 91 | (t 92 | (terpri stream) 93 | (dotimes (x (* 5 *walk-depth*)) (write-char #\space stream)) 94 | (format stream "~a:" (class-name class)))) 95 | (incf walk-count) 96 | class)) 97 | (walk-classes class packages #'print-class)) 98 | walk-count)) 99 | 100 | 101 | 102 | :de.setf.utility.walker 103 | 104 | -------------------------------------------------------------------------------- /walker/function-graph.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: de.setf.utility.implementation; -*- 2 | 3 | (in-package :de.setf.utility.implementation) 4 | 5 | (:documentation "This file defines a graphviz-based grapher for function calls/called relations for the 6 | 'de.setf.utility' library." 7 | 8 | (copyright 9 | "Copyright 2003, 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved" 10 | "'de.setf.utility' is free software: you can redistribute it and/or modify 11 | it under the terms of version 3 of the GNU Lesser General Public License as published by 12 | the Free Software Foundation. 13 | 14 | 'de.setf.utility' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 15 | without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 16 | See the GNU Lesser General Public License for more details. 17 | 18 | A copy of the GNU Lesser General Public License should be included with 'de.setf.utility, as `lgpl.txt`. 19 | If not, see the GNU [site](http://www.gnu.org/licenses/).") 20 | 21 | (history 22 | (delta 20100310 "janderson" "reorganized to consolidate image/runtime operators and 23 | isolate the runtime-depencies."))) 24 | 25 | 26 | (defun graph-functions (extent &key (stream *standard-output*) 27 | function (root function) 28 | (name nil) 29 | (level nil) 30 | (count nil) 31 | (options nil) 32 | (size *graph-size*) 33 | (rankdir *graph-rankdir*) 34 | (ratio *graph-ratio*) 35 | (margin *graph-margin*) 36 | (graph-attributes '()) 37 | (graph-arguments graph-attributes) 38 | (url-encoder nil)) 39 | (let ((walk-count 0)) 40 | (labels ((function-nickname (function) 41 | (let* ((designator (dsw:function-name function)) 42 | (name (if (consp designator) (second designator) designator)) 43 | (package (symbol-package name)) 44 | (p-nick (or (first (package-nicknames package)) 45 | (package-name package)))) 46 | (if (eq package *package*) 47 | (symbol-name name) 48 | (concatenate 'string p-nick ":" (symbol-name name))))) 49 | (put-statement (function &optional (other-function nil other-p) relation) 50 | (when (typep function 'function) 51 | (when (and (or (null level) (<= *walk-depth* level)) 52 | (or (null count) (<= walk-count count))) 53 | (cond (other-p 54 | ;; a link 55 | (when (typep other-function 'function) 56 | (setf.dot:put-edge (function-nickname function) (function-nickname other-function) 57 | :label (string relation)))) 58 | (t 59 | (incf walk-count) 60 | (setf.dot:put-node (function-nickname function) 61 | :url (encode-url function)))))) 62 | function) 63 | (encode-url (component) 64 | (when url-encoder (funcall url-encoder component)))) 65 | (destructuring-bind (&key (size size) (rankdir rankdir) (margin margin) (ratio ratio) 66 | &allow-other-keys) 67 | graph-arguments 68 | (apply #'setf.dot:context-put-graph stream (or name 69 | (if (functionp root) 70 | (function-nickname root) 71 | "?")) 72 | ;; should perhaps choose based on the root - if it's a function the first ways suffices 73 | ;; #'(lambda () (apply #'walk-functions root extent #'put-statement options)) 74 | #'(lambda () (apply #'walk-image root extent #'put-statement 75 | :excluded-qualifiers '(callers) 76 | options)) 77 | :size size 78 | :ratio ratio 79 | :rankdir rankdir 80 | :margin margin 81 | graph-arguments))) 82 | 83 | walk-count)) 84 | 85 | 86 | (defun print-functions (packages &key (stream *standard-output*) function) 87 | (let ((walk-count 0)) 88 | (flet ((print-function (function &optional (other nil other-p) relation) 89 | (cond (other-p 90 | (terpri stream) 91 | (dotimes (x (* 5 *walk-depth*)) (write-char #\space stream)) 92 | (format stream "~a: ~a" relation (function-name other))) 93 | (t 94 | (terpri stream) 95 | (dotimes (x (* 5 *walk-depth*)) (write-char #\space stream)) 96 | (format stream "~a:" (function-name function)))) 97 | (incf walk-count) 98 | function)) 99 | (walk-functions function packages #'print-function)) 100 | walk-count)) 101 | 102 | 103 | :de.setf.utility.walker 104 | 105 | -------------------------------------------------------------------------------- /asdf/contingent-on.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: cl-user; -*- 2 | 3 | ;;; This file is is a constituent of the 'de.setf.utility' library component. 4 | ;;; It adds the 'contingent-on' relation to ASDF 5 | ;;; (c) 2009 james anderson 6 | ;;; 7 | ;;; 'de.setf.utility' is free software: you can redistribute it and/or modify 8 | ;;; it under the terms of the GNU Lesser General Public License as published by 9 | ;;; the Free Software Foundation, either version 3 of the License, or 10 | ;;; (at your option) any later version. 11 | ;;; 12 | ;;; 'de.setf.utility' is distributed in the hope that it will be useful, 13 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;;; GNU Lesser General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU Lesser General Public License 18 | ;;; along with 'de.setf.utility'. If not, see the GNU site. 19 | 20 | ;;; 21 | ;;; 2009-02-20 janderson additions to asdf to support 22 | ;;; + component contingency distinct from dependency 23 | ;;; 2009-06-13 janderson reimplemented to not use specialized classes, but 24 | ;;; instead to use component properties and augment, and/or replace methods 25 | ;;; 2010-01-10 janderson separate extensions topically and add to asdf.asd 26 | 27 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 | 29 | (in-package :cl-user) 30 | 31 | (eval-when (:load-toplevel :compile-toplevel :execute) 32 | (export '(asdf::component-contingent-on) 33 | :asdf)) 34 | 35 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 36 | ;;; 37 | ;;; content : 38 | ;;; 39 | ;;; additional methods to implement contingency 40 | ;;; component-continget-on 41 | ;;; traverse :around 42 | ;;; 43 | ;;; additional properties 44 | ;;; component-description 45 | ;;; component-long-description 46 | ;;; 47 | ;;; additions to instantiation steps to support the above 48 | ;;; shared-initialize :before (system t) 49 | ;;; shared-initialize :after (system t) 50 | 51 | (defparameter asdf::*traverse-verbose* nil) ; help debugging contingency 52 | 53 | 54 | 55 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 56 | ;;; 57 | ;;; additional methods to implement contingency 58 | 59 | (defgeneric asdf::component-contingent-on (component) 60 | (:documentation 61 | "use when collecting the traversal results. iff the component's contingencies 62 | are met - that is, the systems are known and the features are present, then the 63 | component is included in traversal results. otherwise it is invisible.") 64 | (:method ((component asdf::component)) 65 | (asdf::component-property component 'asdf::contingent-on))) 66 | 67 | (defgeneric (setf asdf::component-contingent-on) (description component) 68 | (:method (contingencies (component asdf::component)) 69 | (setf (asdf::component-property component 'asdf::contingent-on) contingencies))) 70 | 71 | 72 | (defmethod asdf::traverse :around ((operation asdf:operation) (module asdf::component)) 73 | "specialize the behavior to suppress traversal unless declared contingencies 74 | are satisfied. if they are not, return (), which effectively prunes the 75 | component with respect to the operation." 76 | 77 | (dolist (contingency (asdf::component-contingent-on module)) 78 | (destructuring-bind (contingent-op . requirements) contingency 79 | (when (typep operation contingent-op) 80 | (dolist (requirement requirements) 81 | (unless (etypecase requirement 82 | ((or string symbol) 83 | (asdf:find-system requirement nil)) 84 | (cons 85 | (destructuring-bind (predicate value) requirement 86 | (cond ((string-equal predicate "feature") 87 | (find value *features* :test #'string-equal)) 88 | (t 89 | (error "invalid contingency predicate: ~s" predicate)))))) 90 | (when asdf::*traverse-verbose* 91 | (format *trace-output* "~&contingency not satisfied: ~s.~s, ~s" 92 | (asdf:component-parent module) module (asdf::component-contingent-on module))) 93 | (return-from asdf::traverse nil)))))) 94 | ;; if all contingencies apply 95 | (when asdf::*traverse-verbose* 96 | (format *trace-output* "~&contingency satisfied: ~s.~s, ~s" 97 | (asdf:component-parent module) module (asdf::component-contingent-on module)) 98 | (when (equalp (asdf:component-name module) "fftw3-digitool") (break))) 99 | (call-next-method)) 100 | 101 | 102 | 103 | 104 | 105 | 106 | #| 107 | (asdf:defsystem :de.setf.test.test 108 | :class asdf:system 109 | :components ((:contingent-module :m1 110 | ; :contingent-on ((explain-op :de.setf.test.none)) 111 | :contingent-on ((explain-op (asdf:feature :test))) 112 | :components ((:file "file1") (:file "file2"))) 113 | (:module :m2 114 | :components ((:file "file3") (:file "file4"))))) 115 | (defclass explain-op (asdf:operation) ()) 116 | (defmethod asdf:perform ((op explain-op) (component asdf:component)) 117 | (asdf:explain op component)) 118 | 119 | (asdf:operate 'explain-op :de.setf.test.test) 120 | (let ((*features* (cons :test *features*))) (asdf:operate 'explain-op :de.setf.test.test)) 121 | 122 | 123 | |# 124 | 125 | -------------------------------------------------------------------------------- /test/rspec/rspec-lisp.rb: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ruby -rubygems 2 | # 3 | # Simple Ruby interface for evaluating Common Lisp code, for use with RSpec. 4 | # Written in August 2010 by Arto Bendiken 5 | # 6 | # This is free and unencumbered software released into the public domain. 7 | 8 | require 'open4' # `sudo gem install open4` 9 | require 'bert' 10 | require 'bert/decode' 11 | require 'bertrpc' 12 | 13 | module RSpec; module Lisp 14 | # SBCL = %q(sbcl --noinform --noprint --no-userinit --disable-debugger --disable-ldb --lose-on-corruption) 15 | SBCL = %q(sbcl --core sbcl-rspec.core --noinform --noprint --no-userinit --eval "(cl-user::rspec-repl)" --disable-debugger --disable-ldb --lose-on-corruption) 16 | LISP = SBCL 17 | 18 | class Proxy 19 | include BERTRPC::Encodes 20 | attr_accessor :module_name # @return [Symbol] 21 | 22 | ## 23 | # @param [Symbol] module_name 24 | def initialize(module_name = nil, &block) 25 | @module_name = module_name 26 | block.call(self) if block_given? 27 | end 28 | 29 | ## 30 | # @private 31 | def method_missing(method_name, *args, &block) 32 | function_name = method_name.to_s.gsub('_', '-').to_sym 33 | result = call_lisp_(function_name, args); 34 | if block_given? 35 | block.call(result) 36 | else 37 | result 38 | end 39 | end 40 | 41 | ## 42 | # Proxy a method through BERT-RPC to a lisp process 43 | # 44 | # Accept a function and an arbitrary list of call arguments, encode them in a call tuple. 45 | # Establish a connection to a LISP process and dispatch the message to its stdin. 46 | # Accept the result and decode it as per BERTRPC spec, which either yields 47 | # the result argument list or raises an error. 48 | # Should the exchangeitself fail, also signal an error. 49 | # 50 | # @param [String] function 51 | # @param [Array] arguments 52 | def call_lisp(function, *arguments) 53 | call_lisp_(function, arguments) 54 | end 55 | 56 | # Accept two fixed arguments, a function name and call arguments, encode them in a call tuple. 57 | # Establish a connection to a LISP process and dispatch the message its stdin. 58 | # if a continuation is supplied, it should accept two arguments, stdin and stdout for the remote 59 | # process. It receives control to exchange additional data, and to decode any response. 60 | # Otherwise, decode the single response. 61 | # 62 | # @param [String] function 63 | # @param [Array] arguments 64 | # @param [Function] block 65 | 66 | def call_lisp_(function, arguments, &block) 67 | # the BERTRPC interface is not symmetric, but that's the way it is. 68 | message = encode_ruby_request(BERT::Tuple[:call, @module_name, function, arguments]) 69 | pid, stdin, stdout, stderr = Open4.popen4(LISP) 70 | stdin.write(message) 71 | 72 | # if a block is given, it has control over the data flow, exchanges further data 73 | # and returns with the 'result' upon completion. 74 | if block_given? 75 | stdin.flush 76 | response = block.call(stdin, stdout) 77 | stdin.close 78 | _, status = Process.waitpid2(pid) 79 | if ( status.exitstatus.zero? ) 80 | response 81 | else 82 | raise(StandardError, stderr.read()) 83 | end 84 | # otherwise, decode a response based on just the encoded call 85 | else 86 | stdin.flush.close 87 | _, status = Process.waitpid2(pid) 88 | if ( status.exitstatus.zero? ) 89 | # decode the response directly from the stream w/o a length header 90 | else 91 | dc = BERT::Decode.new(stdout); 92 | response = dc.read_any 93 | ense 94 | 95 | case response[0] 96 | when :reply 97 | response[1] 98 | when :error 99 | error(response[1]) 100 | else 101 | raise 102 | end 103 | else 104 | raise(StandardError, stderr.read()) 105 | end 106 | end 107 | 108 | end 109 | 110 | ## 111 | # Evaluates the given Lisp `expr` string, returning its result as a Ruby 112 | # value when possible. 113 | # 114 | # Boolean, integer, and float return values are currently marshalled into 115 | # Ruby values. 116 | # 117 | # @param [String] expr 118 | # @return [Object] 119 | def self.evaluate(expr) 120 | case output = execute(%Q((format *standard-output* "~S" #{expr}))) 121 | when 'T' then true 122 | when 'NIL' then nil 123 | when /^[+-]?(?:\d*)?\.\d*$/ then Float(output) 124 | when /^[+-]?\d+$/ then Integer(output) 125 | when /^".*"$/ then output[1...-1] 126 | else output 127 | end 128 | end 129 | 130 | ## 131 | # Executes a given string of Lisp `code`, returning either the standard 132 | # output or standard error of the Lisp process depending on its exit 133 | # status. 134 | # 135 | # @param [String] code 136 | # @return [String] 137 | def self.execute(code) 138 | pid, stdin, stdout, stderr = Open4.popen4(LISP) 139 | stdin.puts(code.to_s) 140 | stdin.flush.close 141 | _, status = Process.waitpid2(pid) 142 | status.exitstatus.zero? ? stdout.read : stderr.read 143 | end 144 | end; end 145 | 146 | if __FILE__ == $0 147 | p RSpec::Lisp.evaluate(%q("Hello, world!")) #=> "Hello, world!" 148 | p RSpec::Lisp.evaluate(%q((* 6 (+ 3 4)))) #=> 42 149 | end 150 | 151 | ## RSpec::Lisp::Proxy.new("CL").call_lisp("lisp-implementation-type") 152 | ## RSpec::Lisp::Proxy.new("CL").call_lisp("round", 7, 3) 153 | ## RSpec::Lisp::Proxy.new("keyword").call_lisp("rspec.succeed") 154 | ## RSpec::Lisp::Proxy.new("keyword").call_lisp("rspec.fail") 155 | ## RSpec::Lisp::Proxy.new("keyword").call_lisp("rspec.error") 156 | 157 | ## RSpec::Lisp::Proxy.new("CL").lisp_implementation_type 158 | 159 | -------------------------------------------------------------------------------- /codecs/bert/bert.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: de.setf.utility.implementation; -*- 2 | 3 | (in-package :de.setf.utility.implementation) 4 | 5 | (:documentation 6 | "This file defines a BERT encoding for the `de.setf.utility.codecs.bert` library." 7 | 8 | (:copyright 9 | "Copyright 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved" 10 | "'de.setf.utility' is free software: you can redistribute it and/or modify 11 | it under the terms of version 3 of the GNU Lesser General Public License as published by 12 | the Free Software Foundation. 13 | 14 | 'de.setf.utility' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 15 | without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 16 | See the GNU Lesser General Public License for more details. 17 | 18 | A copy of the GNU Lesser General Public License should be included with 'de.setf.utility, as `lgpl.txt`. 19 | If not, see the GNU [site](http://www.gnu.org/licenses/).") 20 | 21 | (description "The BERT codec implements the 'Binary ERlang Term' ([BERT-RPC](http://bert-rpc.org/)) data 22 | interchange format with respect to unigned byte arrays and binary streams. It is analogous to the BERT 23 | implementation in (CLERIC)[http://github.com/flambard/CLERIC], but implements symmetric coding/decoding 24 | operators and targets pre-allocated storage for both encoding cases. 25 | 26 | The immediate purpose is to support RDF/BERT, which requires just a subset of the full BERT codec set: 27 | * nil 28 | * atom 29 | * true 30 | * false 31 | * dict 32 | * time 33 | * list 34 | * float 35 | * string")) 36 | 37 | (defpackage :de.setf.utility.codecs.bert (:use )) 38 | 39 | (defparameter +tag.binary-external+ 0) 40 | 41 | 42 | ;; string accessors encode as UTF8 43 | 44 | (macrolet ((def-codec (length-bit-count tag) 45 | (let* ((bit-count-string (princ-to-string length-bit-count)) 46 | (reader-name (cons-symbol :de.setf.utility.codecs.bert :stream-read-string- bit-count-string)) 47 | (writer-name (cons-symbol :de.setf.utility.codecs.bert :stream-write-string- bit-count-string)) 48 | (utf8-reader-name (cons-symbol :de.setf.utility.codecs :stream-read-string-utf8- bit-count-string)) 49 | (utf8-writer-name (cons-symbol :de.setf.utility.codecs :stream-write-string-utf8- bit-count-string)) 50 | (getter-name (cons-symbol :de.setf.utility.codecs.bert :buffer-get-string- bit-count-string)) 51 | (setter-name (cons-symbol :de.setf.utility.codecs.bert :buffer-set-string- bit-count-string)) 52 | (utf8-getter-name (cons-symbol :de.setf.utility.codecs :buffer-get-string-utf8- bit-count-string)) 53 | (utf8-setter-name (cons-symbol :de.setf.utility.codecs :buffer-set-string-utf8- bit-count-string))) 54 | `(progn 55 | (defun ,reader-name (stream) 56 | (,utf8-reader-name stream)) 57 | (defun ,writer-name (stream string) 58 | (de.setf.utility.codecs:stream-write-unsigned-byte-8 stream ,tag) 59 | (,utf8-writer-name stream string)) 60 | 61 | (defun ,getter-name (buffer &optional (position 0)) 62 | (,utf8-getter-name buffer position)) 63 | (defun ,setter-name (buffer string &optional (position 0)) 64 | (de.setf.utility.codecs:buffer-set-unsigned-byte-8 buffer ,tag position) 65 | (,utf8-setter-name buffer string (1+ position))))))) 66 | 67 | (def-codec 8 +tag.binary-external+) 68 | (def-codec 16 +tag.binary-external+)) 69 | 70 | 71 | ;;; atom accessors are string-like, but w/o the utf encoding 72 | 73 | (macrolet ((def-codec (length-bit-count tag) 74 | (let* ((bit-count-string (princ-to-string length-bit-count)) 75 | (reader-name (cons-symbol :de.setf.utility.codecs.bert :stream-read-atom- bit-count-string)) 76 | (writer-name (cons-symbol :de.setf.utility.codecs.bert :stream-write-atom- bit-count-string)) 77 | (iso-reader-name (cons-symbol :de.setf.utility.codecs :stream-read-string-iso- bit-count-string)) 78 | (iso-writer-name (cons-symbol :de.setf.utility.codecs :stream-write-string-iso- bit-count-string)) 79 | (getter-name (cons-symbol :de.setf.utility.codecs.bert :buffer-get-atom- bit-count-string)) 80 | (setter-name (cons-symbol :de.setf.utility.codecs.bert :buffer-set-atom- bit-count-string)) 81 | (iso-getter-name (cons-symbol :de.setf.utility.codecs :buffer-get-string-iso- bit-count-string)) 82 | (iso-setter-name (cons-symbol :de.setf.utility.codecs :buffer-set-string-iso- bit-count-string))) 83 | `(progn 84 | (defun ,reader-name (stream) 85 | (intern (,iso-reader-name stream) *package*)) 86 | (defun ,writer-name (stream value) 87 | (let ((string (symbol-name value))) 88 | (de.setf.utility.codecs:stream-write-unsigned-byte-8 stream ,tag) 89 | (,iso-writer-name stream string))) 90 | 91 | (defun ,getter-name (buffer &optional (position 0)) 92 | (multiple-value-bind (string position) 93 | (,iso-getter-name buffer position) 94 | (values (intern string *package*) position))) 95 | (defun ,setter-name (buffer value &optional (position 0)) 96 | (let ((string (symbol-name value))) 97 | (de.setf.utility.codecs:buffer-set-unsigned-byte-8 buffer ,tag position) 98 | (,iso-setter-name buffer string (1+ position)))))))) 99 | 100 | (def-codec 8 +tag.binary-external+) 101 | (def-codec 16 +tag.binary-external+)) 102 | 103 | 104 | 105 | -------------------------------------------------------------------------------- /codecs/test/float-codecs.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: de.setf.utility.implementation; -*- 2 | 3 | (in-package :de.setf.utility.implementation) 4 | 5 | (:documentation 6 | "This file defines float codecs for the `de.setf.utility.codecs` library." 7 | 8 | (:copyright 9 | "Copyright 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved 10 | 'de.setf.utility.codecs' is free software: you can redistribute it and/or modify 11 | it under the terms of version 3 of the GNU Lesser General Public License as published by 12 | the Free Software Foundation. 13 | 14 | 'de.setf.utility.codecs' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 15 | without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 16 | See the GNU Lesser General Public License for more details. 17 | 18 | A copy of the GNU Lesser General Public License should be included with 'de.setf.utility.codecs, as `lgpl.txt`. 19 | If not, see the GNU [site](http://www.gnu.org/licenses/).") 20 | 21 | (:description "Comprises direct tests for float <-> integer conversion and 32/64 stream/buffer operators.")) 22 | 23 | 24 | (test:test codecs.ieee-754-64 25 | "Test ieee-754-64 packed-integer/float conversion. 26 | See http://babbage.cs.qc.cuny.edu/IEEE-754/References.xhtml for the values." 27 | (null (remove t '(;; all NAN are encoded as positive silent 28 | #xFFF0000000000000 29 | #xFFEFFFFFFFFFFFFF #x8010000000000000 #x800FFFFFFFFFFFFF #x8000000000000001 30 | #x8000000000000000 #x0000000000000000 31 | #x0000000000000001 #x000FFFFFFFFFFFFF #x0010000000000000 #x7FEFFFFFFFFFFFFF 32 | #x7FF8000000000000 33 | #x4039000000000000 #xC039000000000000 #x3FF0000000000000 #xBFF0000000000000 34 | #x4000000000000000 #xC000000000000000 #x3FD5555555555555 #xBFD5555555555555) 35 | :key #'(lambda (x) 36 | (cond ((eql (ieee-754-64-float-to-integer (ieee-754-64-integer-to-float x)) x)) 37 | (t 38 | (warn "ieee-754-64 failed: #x~16,'0x -> ~d -> #x~16,'0x, ~d" 39 | x (ieee-754-64-integer-to-float x) 40 | (ieee-754-64-float-to-integer (ieee-754-64-integer-to-float x)) 41 | (ieee-754-64-integer-to-float (ieee-754-64-float-to-integer (ieee-754-64-integer-to-float x)))) 42 | x)))))) 43 | 44 | (test:test codecs.ieee-754-32 45 | "Test ieee-754-32 packed-integer/float conversion. 46 | See http://babbage.cs.qc.cuny.edu/IEEE-754/References.xhtml for the values." 47 | (null (remove t '(;; all NAN are encoded as positive silent 48 | #xFF800000 49 | #xFF7FFFFF #x80800000 #x807FFFFF #x80000001 50 | #x80000000 #x0000000 51 | #x00000001 #x007FFFFF #x00800000 #x7F7FFFFF 52 | #x7F800000 53 | ;; various numbers 54 | #x41c80000 #xc1c80000 #x3f800000 #xbf800000 55 | #x40000000 #xc0000000 #x3eaaaaab #xbeaaaaab) 56 | :key #'(lambda (x) 57 | (cond ((eql (ieee-754-32-float-to-integer (ieee-754-32-integer-to-float x)) x)) 58 | (t 59 | (warn "ieee-754-32 failed: #x~8,'0x -> ~d -> #x~8,'0x, ~d" 60 | x (ieee-754-32-integer-to-float x) 61 | (ieee-754-32-float-to-integer (ieee-754-32-integer-to-float x)) 62 | (ieee-754-32-integer-to-float (ieee-754-32-float-to-integer (ieee-754-32-integer-to-float x)))) 63 | x)))))) 64 | 65 | 66 | 67 | (test:test codecs.buffer-ieee-codecs 68 | (let ((buffer (make-array 32 :element-type '(unsigned-byte 8) :initial-element 0))) 69 | (labels ((do-codec (encoder decoder value) 70 | (funcall encoder buffer value 0) 71 | (eql (funcall decoder buffer 0) value))) 72 | (dolist (value (list double-float-negative-infinity most-negative-double-float 73 | -1.0d0 least-negative-double-float 74 | 0.0d0 double-float-nan 75 | least-positive-double-float 1.0d0 76 | most-positive-double-float double-float-positive-infinity) 77 | t) 78 | (unless (do-codec #'buffer-set-float-64 #'buffer-get-float-64 value) 79 | (return nil))) 80 | (dolist (value (list single-float-negative-infinity most-negative-single-float 81 | -1.0s0 least-negative-single-float 82 | 0.0s0 single-float-nan 83 | least-positive-single-float 1.0s0 84 | most-positive-single-float single-float-positive-infinity) 85 | t) 86 | (unless (do-codec #'buffer-set-float-32 #'buffer-get-float-32 value) 87 | (return nil)))))) 88 | 89 | 90 | (test:test codecs.stream-ieee-codecs 91 | (let ((stream (make-instance 'vector-io-stream))) 92 | (labels ((do-codec (encoder decoder value) 93 | (stream-position stream 0) 94 | (funcall encoder stream value) 95 | (stream-position stream 0) 96 | (eql (funcall decoder stream) value))) 97 | (dolist (value (list double-float-negative-infinity most-negative-double-float 98 | -1.0d0 least-negative-double-float 99 | 0.0d0 double-float-nan 100 | least-positive-double-float 1.0d0 101 | most-positive-double-float double-float-positive-infinity) 102 | t) 103 | (unless (do-codec #'stream-write-float-64 #'stream-read-float-64 value) 104 | (return nil))) 105 | (dolist (value (list single-float-negative-infinity most-negative-single-float 106 | -1.0s0 least-negative-single-float 107 | 0.0s0 single-float-nan 108 | least-positive-single-float 1.0s0 109 | most-positive-single-float single-float-positive-infinity) 110 | t) 111 | (unless (do-codec #'stream-write-float-32 #'stream-read-float-32 value) 112 | (return nil)))))) 113 | -------------------------------------------------------------------------------- /test/rspec/rspec.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: de.setf.utility.implementation; -*- 2 | 3 | (in-package :de.setf.utility.implementation) 4 | 5 | ;;; This file is part of the 'de.setf.utility' library component. 6 | ;;; It implementes a simple test framework 7 | 8 | ;;; Copyright 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved 9 | ;;; 'de.setf.utility' is free software: you can redistribute it and/or modify 10 | ;;; it under the terms of the GNU Lesser General Public License as published by 11 | ;;; the Free Software Foundation, either version 3 of the License, or 12 | ;;; (at your option) any later version. 13 | ;;; 14 | ;;; 'de.setf.utility' is distributed in the hope that it will be useful, 15 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | ;;; GNU Lesser General Public License for more details. 18 | ;;; 19 | ;;; You should have received a copy of the GNU Lesser General Public License 20 | ;;; along with 'de.setf.utility'. If not, see the GNU site. 21 | 22 | ;;; a stream-based proxied interface to rspec. 23 | ;;; - adds a ruby code-generation operator which emits stubs for each test to 24 | ;;; effect the test from a ruby process 25 | ;;; - defines are bert-encoded call - response/error protocol to invoke the tests 26 | ;;; and return the results through a stream interface 27 | 28 | 29 | (defparameter +rspec-undesignated+ 0) 30 | (defparameter +rspec-no-such-module+ 1) 31 | (defparameter +rspec-no-such-function+ 2) 32 | (defparameter +rspec-unable-to-read-header+ 1) 33 | (defparameter +rspec-unable-to-read-data+ 2) 34 | 35 | (defvar test:*rspec-input* nil 36 | "Bound during execution of rspec-run to the binary input stream from which the test spec was read.") 37 | 38 | (defvar test:*rspec-output* nil 39 | "Bound during execution of rspec-run to the binary output stream to which the test results are written.") 40 | 41 | #+sbcl 42 | (defun rspec-log (format-control &rest args) 43 | (apply #'sb-posix:syslog sb-posix:log-info format-control args)) 44 | 45 | #+digitool 46 | (defun rspec-log (format-control &rest args) 47 | (apply #'warn format-control args)) 48 | 49 | (defun rspec-run-test (path &key debug) 50 | (let ((test-unit (find-test path))) 51 | (cond (test-unit 52 | (handler-case 53 | (let ((values (multiple-value-list (funcall (test-unit-function test-unit))))) 54 | (vector :|reply| (vector (if (apply (test-unit-predicate-function test-unit) values) 55 | etf:true etf:false) 56 | values))) 57 | (error (condition) 58 | (let ((message (format nil "test ~s signaled:~%~a" 59 | (test-unit-name test-unit) condition))) 60 | (when debug 61 | (rspec-log "rspec : ~s" message)) 62 | (vector :|error| (vector :|user| 100 63 | (symbol-name (type-of condition)) 64 | message 65 | nil)))))) 66 | (t 67 | (vector :|error| (vector :|server| +rspec-no-such-function+ 68 | "UNDEFINED-FUNCTION" 69 | (format nil "Test not found: ~a" path) 70 | nil)))))) 71 | 72 | (defun rspec-apply-function (package-name symbol-name arguments &key debug) 73 | (let ((package nil) 74 | (symbol nil) 75 | (function nil)) 76 | (cond ((and (setf package (find-package (cons-symbol :keyword package-name))) 77 | (setf symbol (cons-symbol package symbol-name)) 78 | (setf function (when (fboundp symbol) (fdefinition symbol)))) 79 | (handler-case 80 | (vector :|reply| (multiple-value-list (apply function arguments))) 81 | (error (condition) 82 | (let ((message (format nil "function ~s signaled:~%~a" 83 | symbol condition))) 84 | (when debug 85 | (rspec-log "rspec : ~s" message)) 86 | (vector :|error| (vector :|user| 100 87 | (symbol-name (type-of condition)) 88 | message 89 | nil)))))) 90 | (t 91 | (vector :|error| (vector :|server| +rspec-no-such-function+ 92 | "UNDEFINED-FUNCTION" 93 | (format nil "Function not found: ~a:~a" package-name symbol-name) 94 | nil)))))) 95 | 96 | 97 | ;;; (test:test rspec.1 (+ 1 2) 3) 98 | ;;; (rspec-run-test "rspec.1") 99 | 100 | (defun rspec-run (test:*rspec-input* test:*rspec-output* &key debug) 101 | (handler-case 102 | (let ((request (etf:decode-term test:*rspec-input*)) (response nil)) 103 | (when debug (rspec-log "rspec -> ~s" request)) 104 | (cond ((and (vectorp request) 105 | (symbolp (aref request 0)) 106 | (string-equal (aref request 0) "call") 107 | (stringp (aref request 1))) 108 | (setf response (if (string-equal (aref request 1) "keyword") 109 | (rspec-run-test (elt request 2) :debug debug) 110 | (rspec-apply-function (aref request 1) (aref request 2) (aref request 3) 111 | :debug debug)))) 112 | (t (setf response (vector :|error| (vector :|protocol| +rspec-unable-to-read-header+ 113 | "PROTOCOL-ERROR" 114 | (format nil "Invalid request: ~s." request) 115 | nil))))) 116 | (when debug (rspec-log "rspec <- ~s" response)) 117 | (etf:encode-term response test:*rspec-output*) 118 | (finish-output test:*rspec-output*)) 119 | (error (c) 120 | (rspec-log "rspec : ~a" c)))) 121 | 122 | #+sbcl 123 | (defun cl-user::rspec-repl (&key debug) 124 | (let ((input (sb-sys::make-fd-stream 0 :element-type '(unsigned-byte 8) :input t)) 125 | (output (sb-sys::make-fd-stream 1 :element-type '(unsigned-byte 8) :output t))) 126 | (loop (unless (listen input) (return)) 127 | (de.setf.utility.implementation::rspec-run input output :debug debug)))) 128 | 129 | 130 | #+(or) 131 | (test:test rspec.succeed 132 | (+ 1 2) 133 | 3) 134 | 135 | #+(or) 136 | (test:test rspec.fail 137 | (+ 1 2) 138 | 0) 139 | 140 | #+(or) 141 | (test:test rspec.error 142 | (/ 1 a) 143 | t) -------------------------------------------------------------------------------- /walker/.svn/text-base/ncsl.html.svn-base: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | setf.de LISP Library Noncommercial Source License 8 | 9 | 10 | 11 | 12 |

13 | 14 | 15 | 19 | 22 | 23 |
NONCOMMERCIAL SOURCE LICENSE
16 |
17 | setf.de LISP Library Noncommercial Source License
18 | 20031102T0000		 20 |

setf.de 21 |

24 |

25 |

26 |

27 |

28 | 29 | 33 | 34 |

35 |

36 |

37 | 

 38 | 
PREAMBLE

 39 | 
This license is intended for parties who wish to use components from the setf.de
 40 | library for noncommercial applications. It permits one to copy and use the library
 41 | to develop noncommercial applications only. If one intends to use these components
 42 | in a commercial application, a commectial source license or a commercial binary license
 43 | is required instead.

 44 | 
Subclasses and additional methods are freely distributable. Distribution of Library
 45 | classes and functions themselves and changes to those functions and classes is subject
 46 | to restrictions.

 47 | 
The precise terms and conditions for copying follow.

 48 | 

 49 | 

 50 | 

 51 | 
TERMS AND CONDITIONS FOR COPYING AND MODIFICATION

 52 | 
TERMS OF USE

 53 | 
0. This License applies to the setf.de
 54 | library software (the "Library"). The Library is made available as a source
 55 | archive (.tar file), and as individual source (.lisp) files. the Library comprises
 56 | Common Lisp functions and classes in various packages with the prefix de.setf.
 57 | The "Library", below, refers to this software, and a "work based on
 58 | the Library" means any Program or any derivative work which contains the Library
 59 | or a portion of it, either verbatim or as a linked component. Each licensee is addressed
 60 | as "you".

 61 | 
1. You have a non-exclusive right to copy the Library source
 62 | code as you receive it, in any medium, for your own noncommercial use, provided that
 63 | you conspicuously and appropriately either retain on each copy an appropriate copyright
 64 | notice and disclaimer of warranty, and keep intact all the notices that refer to
 65 | this License and to the absence of any warranty.

 66 | 
2. You may modify your copy or copies of the Library or any portion
 67 | of it, thus forming a work based on the Library, and copy such modifications or work
 68 | under the terms of Section 1 above, provided that you also meet all of these conditions:

 69 | 
 70 | 
 85 | 
 86 | 
3. You have a non-exclusive right to copy the Library in binary
 87 | form, as you receive it or as modified by you, in any medium, provided that it is
 88 | an integral part of a noncommercial, end-user application, and provided that you
 89 | conspicuously and appropriately publish on each copy an appropriate copyright notice,
 90 | assume full responsibility for any warranty; keep intact all the notices that refer
 91 | to this License, and give any other recipients of the Library a copy of this License
 92 | along with the Library.

 93 | 
4. You may not aggregate the Library with of another work for
 94 | distribution - whether the other work is based on the Library or not, except under
 95 | the terms of Section 3, above.

 96 | 
5.You may not charge a fee for a copy of the Library and you
 97 | may not offer services and/or programs and/or offer warranty protection whether directly
 98 | or indirectly related to the Library in exchange for a fee.

 99 | 
6. You may not copy, modify, sublicense, or distribute the Library
100 | except as expressly provided under this License. Any attempt otherwise to copy, modify,
101 | sublicense or distribute the Library is void, and will automatically terminate your
102 | rights under this License.

103 | 
7. If any portion of this license is held invalid or unenforceable
104 | under any particular circumstance, the balance of the license is intended to apply.

105 | 
NO WARRANTY

106 | 
A.THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED
107 | BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS
108 | AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY
109 | KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
110 | OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. YOU ACKNOWLEDGE THAT THE
111 | PROGRAM IS NOT DESIGNED OR INTENDED FOR USE IN THE DESIGN CONSTRUCTION OF ANY NUCLEAR
112 | FACILITY AND THE AUTHOR DISCLAIMS ANY EXPRESS OR IMPLIED WARRANTY OF FITNESS FOR
113 | SUCH USES.THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH
114 | YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
115 | REPAIR OR CORRECTION.

116 | 
B. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO
117 | IN WRITING WILL THE COPYRIGHT HOLDER BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
118 | GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY
119 | TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED
120 | INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM
121 | TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN
122 | ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.

123 | 

124 | 

125 | 

126 | 
END OF LICENSE
127 | 
128 | 
129 | 
130 | 
131 | 


--------------------------------------------------------------------------------
/codecs/test/character-codecs.lisp:
--------------------------------------------------------------------------------
  1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: de.setf.utility.implementation; -*-
  2 | 
  3 | (in-package :de.setf.utility.implementation)
  4 | 
  5 | (:documentation
  6 |   "This file tests string codecs for the `de.setf.utility.codecs` library."
  7 |   
  8 |   (:copyright
  9 |    "Copyright 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved
 10 |  'de.setf.utility.codecs' is free software: you can redistribute it and/or modify
 11 |  it under the terms of version 3 of the GNU Lesser General Public License as published by
 12 |  the Free Software Foundation.
 13 | 
 14 |  'de.setf.utility.codecs' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
 15 |  without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 16 |  See the GNU Lesser General Public License for more details.
 17 | 
 18 |  A copy of the GNU Lesser General Public License should be included with 'de.setf.utility.codecs, as `lgpl.txt`.
 19 |  If not, see the GNU [site](http://www.gnu.org/licenses/).")
 20 |   
 21 |   (:description "Defines functions and compiler macros for character sequence operations on streams and buffers.
 22 |  The operators implement the combinations for destination (stream / buffer), direction (read / write), string
 23 |  length bit count (8, 16, 32), and encoding (is05589 and utf8).
 24 | 
 25 |  The interface operators include both general operators, which accept a run-time size and size-specific operators.
 26 |  The latter generate type constraints and supply a constant byte size in order to enable size-specific compilation."))
 27 | 
 28 | (test:test codecs.buffer-character-codecs
 29 |   (let* ((buffer (make-array 32 :element-type '(unsigned-byte 8) :initial-element 0))
 30 |          (good-strings (list "" "01234567"
 31 |                              (let ((i (char-code #\a)))
 32 |                                (map-into (make-string (- (length buffer) 4)) #'(lambda () (values (code-char i) (incf i)))))
 33 |                              (map 'string #'code-char `(#x0000  #x00FF #x0100 #x01FF #x0200
 34 |                                                         ,(if (> char-code-limit 65536) #x10FFFF #xffff))))))
 35 |     (dolist (length-bit-count '(8 16 32) t)
 36 |       (let* ((bit-count-string (princ-to-string length-bit-count))
 37 |              (getter-iso-name (cons-symbol :de.setf.utility.codecs :buffer-get-string-iso- bit-count-string))
 38 |              (getter-utf8-name (cons-symbol :de.setf.utility.codecs :buffer-get-string-utf8- bit-count-string))
 39 |              (setter-iso-name (cons-symbol :de.setf.utility.codecs :buffer-set-string-iso- bit-count-string))
 40 |              (setter-utf8-name (cons-symbol :de.setf.utility.codecs :buffer-set-string-utf8- bit-count-string)))
 41 |         (unless (dolist (string good-strings t)
 42 |                   (funcall setter-iso-name buffer string 0)
 43 |                   (when (every #'(lambda (c) (<= (char-code c) 255)) string)
 44 |                     (unless (equal (funcall getter-iso-name buffer 0) buffer)
 45 |                       (return nil)))
 46 |                   (funcall setter-utf8-name buffer string 0)
 47 |                   (unless (equal (funcall getter-utf8-name buffer 0) string)
 48 |                     (return nil))))))))
 49 | 
 50 | (test:test codecs.buffer-character-codecs.errors
 51 |   "Test the effect of access at the end: over-run should signal a type error."
 52 |   (let* ((buffer (make-array 32 :element-type '(unsigned-byte 8) :initial-element 0))
 53 |          (string "01234567"))
 54 |     (dolist (length-bit-count '(8 16 32) t)
 55 |       (let* ((bit-count-string (princ-to-string length-bit-count))
 56 |              (length-byte-count (/ length-bit-count 8))
 57 |              (getter-iso-name (cons-symbol :de.setf.utility.codecs :buffer-get-string-iso- bit-count-string))
 58 |              (getter-utf8-name (cons-symbol :de.setf.utility.codecs :buffer-get-string-utf8- bit-count-string))
 59 |              (setter-iso-name (cons-symbol :de.setf.utility.codecs :buffer-set-string-iso- bit-count-string))
 60 |              (setter-utf8-name (cons-symbol :de.setf.utility.codecs :buffer-set-string-utf8- bit-count-string)))
 61 |         (unless (and (typep (nth-value 1 (ignore-errors (funcall setter-iso-name string buffer
 62 |                                                                  (1+ (- (length buffer) (+ (length string) length-byte-count))))))
 63 |                              'type-error)
 64 |                      (funcall setter-iso-name buffer string (- (length buffer) (+ (length string) length-byte-count)))
 65 |                      (equal (funcall getter-iso-name buffer (- (length buffer) (+ (length string) length-byte-count)))
 66 |                              string)
 67 |                      (typep (nth-value 1 (ignore-errors (funcall setter-utf8-name string buffer
 68 |                                                                  (1+ (- (length buffer) (+ (length string) length-byte-count))))))
 69 |                              'type-error)
 70 |                      (funcall setter-utf8-name buffer string (- (length buffer) (+ (length string) length-byte-count)))
 71 |                      (equal (funcall getter-utf8-name buffer (- (length buffer) (+ (length string) length-byte-count)))
 72 |                              string))
 73 |           (return nil))))))
 74 | 
 75 | 
 76 | (test:test codecs.stream-character-codecs
 77 |   (let ((stream (make-instance 'vector-io-stream))
 78 |         (strings (list "" "01234567"
 79 |                             (let ((i (char-code #\a)))
 80 |                               (map-into (make-string 32) #'(lambda () (values (code-char i) (incf i)))))
 81 |                             (map 'string #'code-char `(#x0000  #x00FF #x0100 #x01FF #x0200
 82 |                                                        ,(if (> char-code-limit 65536) #x10FFFF #xffff))))))
 83 |     (labels ((do-codec (encoder decoder value)
 84 |                (stream-position stream 0)
 85 |                (funcall encoder stream value)
 86 |                (stream-position stream 0)
 87 |                (eql (funcall decoder stream) value)))
 88 |       (dolist (length-bit-count '(8 16 32) t)
 89 |         (let* ((bit-count-string (princ-to-string length-bit-count))
 90 |                (reader-iso-name (cons-symbol :de.setf.utility.codecs :stream-read-string-iso- bit-count-string))
 91 |                (reader-utf8-name (cons-symbol :de.setf.utility.codecs :stream-read-string-utf8- bit-count-string))
 92 |                (writer-iso-name (cons-symbol :de.setf.utility.codecs :stream-write-string-iso- bit-count-string))
 93 |                (writer-utf8-name (cons-symbol :de.setf.utility.codecs :stream-write-string-utf8- bit-count-string)))
 94 |           (unless (dolist (string strings t)
 95 |                     (unless (and (do-codec writer-iso-name reader-iso-name string)
 96 |                                  (do-codec writer-utf8-name reader-utf8-name string))
 97 |                       (return nil)))))))))
 98 |   
 99 | 
100 | (test:test codecs.stream-string-sized
101 |    (let ((stream (make-instance 'vector-io-stream)))
102 |     (labels ((do-codec (encoder decoder value &optional (size (length value)))
103 |                (stream-position stream 0)
104 |                (funcall encoder stream value size)
105 |                (stream-position stream 0)
106 |                (equal (funcall decoder stream size)
107 |                       (concatenate 'string (make-string (- size (length value)) :initial-element #\space) value))))
108 |       (dolist (spec '("" ("" 10) "asdf" ("asdf" 10))
109 |                      t)
110 |         (unless (apply #'do-codec #'stream-write-string-iso-sized #'stream-read-string-iso-sized
111 |                        (if (listp spec) spec (list spec)))
112 |           (return nil))))))
113 | 
114 | 
115 | 


--------------------------------------------------------------------------------
/string.lisp:
--------------------------------------------------------------------------------
  1 | ;;; -*- Package: de.setf.utility.implementation; -*-
  2 | 
  3 | ;;;  This file is part of the 'de.setf.utility' Common Lisp library.
  4 | ;;;  It defines several string utility functions.
  5 | 
  6 | ;;;  Copyright 2003, 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved
  7 | ;;;  'de.setf.utility' is free software: you can redistribute it and/or modify
  8 | ;;;  it under the terms of version 3 of the GNU Lesser General Public License as published by
  9 | ;;;  the Free Software Foundation.
 10 | ;;;
 11 | ;;;  'de.setf.utility' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
 12 | ;;;  without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 13 | ;;;  See the GNU Lesser General Public License for more details.
 14 | ;;;
 15 | ;;;  A copy of the GNU Lesser General Public License should be included with 'de.setf.utility, as `lgpl.txt`.
 16 | ;;;  If not, see the GNU [site](http://www.gnu.org/licenses/).
 17 | ;;;
 18 | ;;;  nb. clocc/cllib includes operators with a similar interface, but they 
 19 | ;;;  ignored some of the constraints.
 20 | 
 21 | 
 22 | ;;; Content :
 23 | ;;;
 24 | ;;;  split-string
 25 | ;;;  split-sequence
 26 | ;;;  cons-symbol (package &rest elements)
 27 | 
 28 | ;;; 20030101 established independant utility
 29 | ;;; 20030214 string+
 30 | 
 31 | (in-package :de.setf.utility.implementation)
 32 | 
 33 | (modPackage :de.setf.utility
 34 |   (:export
 35 |    :concatenate-string
 36 |    :cons-symbol
 37 |    :string+
 38 |    :split-string
 39 |    :split-sequence
 40 |    :trim-string-whitespace
 41 |    :when-symbol
 42 |    ))
 43 | 
 44 | (defun trim-string-whitespace (string)
 45 |   (string-trim #(#\space #\tab #\return #\linefeed) string))
 46 | 
 47 | 
 48 | ;;; these don't do the right thing, as they modify their argument lists
 49 | 
 50 | (defun concatenate-string* (list &aux (length 0))
 51 |   (declare (type cons list) (type fixnum length))
 52 |   (cond ((consp list)
 53 |          (mapl #'(lambda (list &aux (elt (first list)))
 54 |                    (etypecase elt
 55 |                      (cons (setf elt (concatenate-string* elt))
 56 |                            (setf (first list) elt))
 57 |                      (null )
 58 |                      (string ))
 59 |                    (when elt (incf length (length elt))))
 60 |                list)
 61 |          (let ((string (make-string length))
 62 |                (index 0))
 63 |            (declare (type string string)
 64 |                     (type fixnum index))
 65 |            (dolist (elt list)
 66 |              (when (stringp elt)
 67 |                (locally  (declare (type string elt))
 68 |                  (dotimes (i (length elt)) (declare (type fixnum i))
 69 |                           (setf (schar string index) (char elt i))
 70 |                           (incf index)))))
 71 |            string))
 72 |         (t
 73 |          "")))
 74 | 
 75 | (defun concatenate-string (&rest list)
 76 |   (declare (dynamic-extent list))
 77 |   (concatenate-string* list))
 78 | 
 79 | ;; (concatenate-string "asd" '("qwe" "try") "zxc")
 80 | 
 81 | (defun string+ (&rest string-designators)
 82 |    (concatenate-string* (mapl #'(lambda (designators &aux (designator (first designators)))
 83 |                                   (etypecase designator
 84 |                                     (character (setf (first designators)
 85 |                                                      (make-string 1 :initial-element designator)))
 86 |                                     (null )
 87 |                                     (string )
 88 |                                     (sequence (setf (first designators) (reduce #'string+ designator)))
 89 |                                     (symbol (setf (first designators) (string designator)))))
 90 |                               string-designators)))
 91 | 
 92 | (defun split-sequence (seq pred &key (start 0) end key strict punctuation-p)
 93 |   (let* ((p0 (if strict start (position-if-not pred seq :start start :end end :key key)))
 94 |          (p1 0)
 95 |          (result (list nil))
 96 |          (next result))
 97 |     (labels ((collect (x) (setf next (setf (rest next) (list x))))
 98 |              (collect-characters (sequence start end)
 99 |                (loop (unless (< start end) (return))
100 |                      (collect (elt sequence start))
101 |                      (incf start))))
102 |       (when (and punctuation-p (or (null p0) (plusp p0)))
103 |         (collect-characters seq 0 (or p0 (length seq))))
104 |       (loop (unless (and p0 p1) (return))
105 |             (setf p1 (position-if pred seq :start p0 :end end :key key))
106 |             (collect (subseq seq p0 (or p1 end)))
107 |             (when p1
108 |               (setq p0 (if strict (1+ p1) (position-if-not pred seq :start p1 :end end :key key)))
109 |               (when punctuation-p
110 |                 (collect-characters seq p1 (or p0 (length seq)))))))
111 |     (rest result)))
112 | 
113 | (defun split-string (str chars &rest opts)
114 |   "Split the string on chars."
115 |   (apply #'split-sequence str
116 |          (etypecase chars
117 |            (character
118 |             #'(lambda (ch) (declare (character ch) (character chars)) (eql ch chars)))
119 |            (sequence
120 |             (etypecase (elt chars 0)
121 |               (character #'(lambda (ch) (declare (character ch)) (find ch chars)))
122 |               (fixnum #'(lambda (ch) (declare (character ch)) (find (char-code ch) chars)))))
123 |            (function chars))
124 |          opts))
125 | 
126 | ;(split-string "<<>" ",.<>" :punctuation-p t)
127 | ;(split-string "<<>" ",.<>" :punctuation-p nil)
128 | ;(split-string "asdf,qwer" ",")
129 | ;(split-string "the macro with-namespace-declaration-handler.
" #(#x09 #x0A #x0D #x20 #x85 #\( #\) #\, #\< #\> #\.) :punctuation-p t)
130 | ;(split-string ",,qwer" "," :strict t)
131 | ;(split-string ",,qwer" "," :punctuation-p t :strict t)
132 | ;(split-string ",,qwer" ",")
133 | 
134 | 
135 | 
136 | (defun cons-symbol (package &rest args)
137 |   "Construct a symbol given string designators. If package is null, the symbol is
138 |  a new, uninterned symbol."
139 |   (declare (dynamic-extent args))
140 | 
141 |   (multiple-value-bind (symbol name)
142 |                        (apply #'when-symbol package args)
143 |     (or symbol (intern name package))))
144 | 
145 | 
146 | (defun when-symbol (package &rest args)
147 |   (declare (dynamic-extent args))
148 | 
149 |   (flet ((element-length (element)
150 |            (if element (length (string element)) 0)))
151 |     (declare (dynamic-extent #'element-length))
152 |     (let* ((length (reduce #'+ args :key #'element-length :initial-value 0))
153 |            (name (make-string length))
154 |            (position 0))
155 |       (declare (dynamic-extent name))
156 |       (dolist (el args)
157 |         (when el
158 |           (setf el (string el))
159 |           (replace name  el :start1 position)
160 |           (incf position (length el))))
161 |       (ecase (readtable-case *readtable*)
162 |         (:upcase (map-into name #'char-upcase name))
163 |         (:downcase (map-into name #'char-downcase name))
164 |         (:preserve )
165 |         (:invert (flet ((char-invert (c)
166 |                           (cond ((upper-case-p c) (char-downcase c))
167 |                                 ((lower-case-p c) (char-upcase c))
168 |                                 (t c))))
169 |                    (declare (dynamic-extent #'char-invert))
170 |                    (map-into name #'char-invert name))))
171 |       (if package
172 |         (or (find-symbol name package)
173 |             (values nil (copy-seq name)))
174 |         (make-symbol (copy-seq name))))))
175 | 
176 | (unless (find-package "_")
177 |   (defpackage "_" (:use)
178 |     (:documentation "An isolated package for macro definition symbols.")))
179 | 
180 | 
181 | :de.setf.utility
182 | 


--------------------------------------------------------------------------------
/lock.lisp:
--------------------------------------------------------------------------------
  1 | ;;; -*- Package: de.setf.utility.implementation; -*-
  2 | 
  3 | (in-package :de.setf.utility.implementation)
  4 | 
  5 | (eval-when (:compile-toplevel :load-toplevel :execute)
  6 |   (unless (intersection '(:clozure :digitool :sbcl) *features*)
  7 |     (cerror "Continue anyway." "This file must be conditionalized for ~a." (lisp-implementation-type))))
  8 | 
  9 | 
 10 | (:documentation "This file defines mp/lock utilities for the 'de.setf.utility' library."
 11 |  
 12 |  (copyright
 13 |   "Copyright 2010 [james anderson](mailto:james.anderson@setf.de)  All Rights Reserved"
 14 |   "'de.setf.utility' is free software: you can redistribute it and/or modify
 15 |  it under the terms of version 3 of the GNU Lesser General Public License as published by
 16 |  the Free Software Foundation.
 17 | 
 18 |  'de.setf.utility' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
 19 |  without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 20 |  See the GNU Lesser General Public License for more details.
 21 | 
 22 |  A copy of the GNU Lesser General Public License should be included with 'de.setf.utility, as `lgpl.txt`.
 23 |  If not, see the GNU [site](http://www.gnu.org/licenses/)."))
 24 | 
 25 | 
 26 | (modpackage :de.setf.utility.lock
 27 |   (:use )
 28 |   (:nicknames :setf.lock)
 29 |   (:export
 30 |    :call-with-object-locked
 31 |    :instance-lock
 32 |    :with-object-locked
 33 |    :synchronized-object
 34 |    :run-in-thread
 35 |    ))
 36 | 
 37 | (defmacro setf.lock:with-object-locked ((object) &rest body)
 38 |   (let* ((function (gensym)))
 39 |     `(flet ((,function () ,@body))
 40 |        (declare (dynamic-extent #',function))
 41 |        (setf.lock:call-with-object-locked #',function ,object))))
 42 | 
 43 | #+digitool
 44 | (setf (ccl:assq 'synchronized ccl::*fred-special-indent-alist*) 1)
 45 | 
 46 | #+ccl
 47 | (defun setf.lock:call-with-object-locked (function instance)
 48 |   "invoke the argument function while holding the lock on the argument instance."
 49 |   (with-lock-grabbed ((setf.lock:instance-lock instance))
 50 |     (funcall function)))
 51 | 
 52 | #+sbcl
 53 | (defun setf.lock:call-with-object-locked (function instance)
 54 |   "invoke the argument function while holding the lock on the argument instance."
 55 |   (sb-thread:with-mutex ((setf.lock:instance-lock instance))
 56 |     (funcall function)))
 57 | 
 58 | (declaim (ftype (function (&key (name t)) t) make-lock))
 59 | 
 60 | #-ccl
 61 | (setf (fdefinition 'make-lock)
 62 |       #+allegro #'mp:make-process-lock
 63 |       #+lispworks #'mp:make-lock
 64 |       #+sbcl #'sb-thread:make-mutex)
 65 |   
 66 | (defvar *instance-locks* (make-weak-hash-table))
 67 | 
 68 | ;; make a lock for the registry itself
 69 | (setf (gethash *instance-locks* *instance-locks*) (make-lock))
 70 | 
 71 | (defclass setf.lock:synchronized-object ()
 72 |   ((lock
 73 |     ;; :initform nil
 74 |     :initarg :lock
 75 |     :reader get-instance-lock))
 76 |   (:documentation
 77 |    "a synchronized-object binds a lock for use with the synchronized and call-with-instance-lock-held.
 78 |     if no lock is provided as an initialization argument, one with be created upon first reference."))
 79 | 
 80 | (defGeneric setf.lock:instance-lock (instance)
 81 |   (:method ((datum t))
 82 |            (flet ((new-instance-lock ()
 83 |                     (or (gethash datum *instance-locks*)
 84 |                         (setf (gethash datum *instance-locks*) (make-lock)))))
 85 |              (declare (dynamic-extent #'new-instance-lock))
 86 |              (or (gethash datum *instance-locks*)
 87 |                  (setf.lock:call-with-object-locked #'new-instance-lock *instance-locks*))))
 88 |   (:documentation
 89 |    "retrieve an instance's lock. if the instance is not a synchronized object manage a lock for it in a central,
 90 |     weak hashtable."))
 91 | 
 92 | (defmethod setf.lock:instance-lock ((instance setf.lock:synchronized-object))
 93 |   "generate and bind an instance lock upon demand only."
 94 |   (if (slot-boundp instance 'lock)
 95 |     (get-instance-lock instance)
 96 |     (setf (slot-value instance 'lock) (make-lock))))
 97 | 
 98 | #+digitool
 99 | (defun setf.lock:run-in-thread (function
100 |                    &key (name "anonymous") (priority 0)
101 |                    parameters)
102 |   "Runs function in it's own thread."
103 |   (let ((keys `(:name , name :priority ,priority)))
104 |     (declare (dynamic-extent keys))
105 |     (apply #'ccl:process-run-function keys function parameters)))
106 | 
107 | #+clozure
108 | (defun setf.lock:run-in-thread (function
109 |                    &key (name "anonymous") (priority 0)
110 |                    parameters)
111 |   "Runs function in it's own thread."
112 |   (let ((keys `(:name , name :priority ,priority)))
113 |     (declare (dynamic-extent keys))
114 |     (apply #'ccl:process-run-function keys function parameters)))
115 | 
116 | #+(or lispworks allegro)
117 | (defun setf.lock:run-in-thread (function
118 |                       &key (name (function-namestring function))
119 |                       priority
120 |                            parameters)
121 |   "Runs function in it's own thread."
122 |   (declare (ignore priority))
123 |   (apply #'mp:process-run-function
124 |          name
125 |          function
126 |          parameters))
127 | 
128 | #+sbcl
129 | (defun setf.lock:run-in-thread (function
130 |                       &key (name (function-namestring function))
131 |                       priority
132 |                            parameters)
133 |   "Runs function in it's own thread."
134 |   (declare (ignore priority))
135 |   (flet ((run-op () (apply function parameters)))
136 |     (sb-thread:make-thread #'run-op :name name)))
137 | 
138 | 
139 | 
140 | 
141 | 
142 | #|
143 | (defparameter *w* (make-instance 'fred-window))
144 | (defun wtw (w string)
145 |   (synchronized w
146 |                 (terpri w)
147 |                 (dotimes (x (length string)) (write-char (char string x) w))))
148 | 
149 | (synchronized (datum (front-window)) (print datum))
150 | (synchronized datum (print datum))
151 | 
152 | 
153 | ;; test timing for slot-boundp vs slot-unbound vs null
154 | 
155 | (defclass slot-test ()
156 |   ((slot :initarg :slot :reader slot-test-slot)))
157 | 
158 | (defmethod slot-unbound ((class standard-class) (instance slot-test) (slot (eql 'slot)))
159 |   (setf (slot-value instance 'slot) :x))
160 | 
161 | (defmethod test-by-slot-null ((instance slot-test))
162 |   (with-slots (slot) instance (or slot (setf slot :y))))
163 | 
164 | (defmethod test-by-slot-unbound ((instance slot-test))
165 |   (with-slots (slot) instance slot))
166 | 
167 | (defmethod test-by-slot-boundp ((instance slot-test))
168 |   (with-slots (slot) instance
169 |     (if (slot-boundp instance 'slot)
170 |       slot
171 |       (setf slot :z))))
172 | 
173 | 
174 | (let ((instance (make-instance 'slot-test)))
175 |   ;; initialize 57  / reference 16 ms
176 |   (time (dotimes (x 100000) (setf (slot-value instance 'slot) nil) (test-by-slot-null instance)))
177 |   (time (dotimes (x 100000)                                        (test-by-slot-null instance)))
178 |   ;; initialize 147 / reference 17 ms
179 |   (time (dotimes (x 100000) (slot-makunbound instance 'slot)       (test-by-slot-unbound instance)))
180 |   (time (dotimes (x 100000)                                        (test-by-slot-unbound instance)))
181 |   ;; initialize 147 / reference 17 ms
182 |   (time (dotimes (x 100000) (slot-makunbound instance 'slot)       (slot-test-slot instance)))
183 |   (time (dotimes (x 100000)                                        (slot-test-slot instance)))
184 |   ;; initialize 75 / reference 26 ms
185 |   (time (dotimes (x 100000) (slot-makunbound instance 'slot)       (test-by-slot-boundp instance)))
186 |   (time (dotimes (x 100000)                                        (test-by-slot-boundp instance)))
187 |   )
188 | 
189 | ;; according to which the specialized slot-unbound method has a high initial cose, but
190 | ;; negligible long-term cost at the benefit simpler use. if a standard reader suffices, then
191 | ;; the method is faster.
192 | 
193 | |#
194 | 


--------------------------------------------------------------------------------
/walker/.svn/text-base/package-graph.lisp.svn-base:
--------------------------------------------------------------------------------
  1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: de.setf.utility.implementation; -*-
  2 | ;;;
  3 | 
  4 | #|
  5 | 
  6 |  
  7 |   
a simple package grapher
  8 |    

  9 |   
 10 |  
 11 |   
 12 |    cleaned up and adjusted for denominated methods
 13 |    corrected qualifier slot name for walker class
 14 |   
 15 |  
 16 | |#
 17 | 
 18 | (in-package :de.setf.utility.implementation)
 19 | 
 20 | (modPackage :de.setf.utility.package.graph
 21 |   (:use-only )
 22 |   (:use-by :de.setf.utility.implementation)
 23 |   (:export
 24 |    :package-walker
 25 |    :walk-packages
 26 |    :graph-packages
 27 |    :print-packages
 28 |    ))
 29 | 
 30 | 
 31 | 
 32 | ;; dot-graphing for packages
 33 | 
 34 | (defparameter *package-print-level* 0)
 35 | 
 36 | 
 37 | (defun read-file-package-names (pathname &aux names form (eof (gensym)) (error (gensym)))
 38 |   (labels ((extract-name (form)
 39 |              (let ((operator (first form)))
 40 |                (cond ((eq operator 'eval-when)
 41 |                       (mapcar #'extract-name (cddr form)))
 42 |                      ((and (search "package" (string operator) :test #'char-equal)
 43 |                            (symbolp (second form)))
 44 |                       (pushnew (string (second form)) names :test #'string=))))))
 45 |     (with-open-file (stream pathname :direction :input)
 46 |       (loop (setf form (handler-case (read stream nil eof)
 47 |                          (error () error)))
 48 |             (when (or (eq eof form) (eq form error)) (return))
 49 |             (when (consp form) (extract-name form)))
 50 |       names)))
 51 | 
 52 | ;(mapcar #'read-file-package-names (directory "packages:de;**;*.lisp"))
 53 | 
 54 | (defClass package-walker (preorder-node-walker
 55 |                           preorder-link-walker
 56 |                           cyclic-walker
 57 |                           walk-qualifier)
 58 |   ((walk-qualifiers :initform '(used-by imports uses relations other) :allocation :class)))
 59 | 
 60 | (defmethod walk-node-predecessors uses
 61 |            ((walker package-walker) (package package) (op t))
 62 |   (dolist (uses (package-use-list package))
 63 |     (unless (find package (getf (walker-node-properties walker uses) 'used-by))
 64 |       (push uses (getf (walker-node-properties walker package) 'uses))
 65 |       (walk-link walker 'uses package uses op)))
 66 |   package)
 67 | 
 68 | (defmethod walk-node-predecessors imports
 69 |            ((walker package-walker) (package package) (op t))
 70 |   (let ((imports nil))
 71 |     (with-package-iterator (next-symbol package :internal :external)
 72 |       (loop (multiple-value-bind (more symbol) (next-symbol)
 73 |               (unless more (return))
 74 |               (unless (eq (symbol-package symbol) package)
 75 |                 (pushnew (symbol-package symbol) imports)))))
 76 |     (when imports (map-walk-link imports walker 'imports package op)))
 77 |   package)
 78 | 
 79 | (defmethod walk-node-successors used-by
 80 |            ((walker package-walker) (package package) (op t))
 81 |   (dolist (used-by (package-used-by-list package))
 82 |     (unless (find package (getf (walker-node-properties walker used-by) 'uses))
 83 |       (push used-by (getf (walker-node-properties walker package) 'used-by))
 84 |       (walk-link walker 'used-by package used-by op)))
 85 |   package)
 86 | 
 87 | (defMethod walk-link :around
 88 |            ((walker package-walker) (relation t) (from package) (to package) (op t))
 89 |   (when (find to *packages-to-walk*)
 90 |     (let ((*package-print-level* (1+ *package-print-level*)))
 91 |       (call-next-method)
 92 |       to)))
 93 | 
 94 | (defmethod walk-node :denominative ((navigator package-walker) (node t) (operator t)))
 95 | (defmethod walk-node-predecessors :denominative ((navigator package-walker) (node t) (operator t)))
 96 | (defmethod walk-node-successors :denominative ((navigator package-walker) (node t) (operator t)))
 97 | (defmethod walk-link :denominative ((walker package-walker) (relation t) (from t) (to t) (op t)))
 98 | 
 99 | 
100 | (defGeneric walk-packages (root packages op &key &allow-other-keys)
101 |   (:argument-precedence-order packages root op)
102 |   (:method ((root t) (packages pathname) op &rest options)
103 |            (apply #'walk-packages root
104 |                   (remove-duplicates (apply #'append
105 |                                             (mapcar #'read-file-package-names
106 |                                                     (if (directory-pathname-p packages)
107 |                                                       (directory (make-pathname :name :wild :type :wild :defaults packages)
108 |                                                                  :files t :directories nil)
109 |                                                       (list packages)))))
110 |                   op
111 |                   options))
112 |   (:method ((root t) (packages t) op &rest options)
113 |            (apply #'walk-packages (coerce-to-package root) packages op options))
114 |   (:method ((root null) (packages t) (op t) &rest options)
115 |            (apply #'walk-packages (find-package "COMMON-LISP") packages op options))
116 |   (:method ((root t) (packages null) op &rest options)
117 |            (apply #'walk-packages root (list-all-packages) op options))
118 |   (:method ((root t) (package-predicate function) op &rest options)
119 |            (apply #'walk-packages root (remove-if-not package-predicate (list-all-packages)) op options))
120 |   (:method ((root package) (*packages-to-walk* cons) op &rest options)
121 |            (setf *packages-to-walk* (mapcar #'coerce-to-package *packages-to-walk*))
122 |            (walk-model root (apply #'make-instance 'package-walker options) op)))
123 |             
124 | 
125 | (defun write-package-graph-node (package &optional (other-package nil op-p) relation)
126 |   (cond (op-p
127 |          ;; a link
128 |          (dot:dot-write-edge-statement dot:*dot-output*
129 |                                       (package-name package) (package-name other-package)
130 |                                       `(( "label" . ,(string relation)))))
131 |         (t
132 |          (dot:dot-write-node-statement dot:*dot-output* (package-name package) nil))))
133 | 
134 | (defun graph-packages (&key packages-to-walk (stream *standard-output*) root)
135 |   (dot:dot-write-graph stream
136 |                           #'(lambda (grapher)
137 |                               (declare (ignore grapher))
138 |                               (dot-write-attribute *dot-output* "size" "8.5,11")
139 |                               (write-string "; " *dot-output*)
140 |                               (dot-write-attribute *dot-output* "ratio" "compress")
141 |                               (write-string "; " *dot-output*)
142 |                               (dot-write-attribute *dot-output* "rankdir" "LR")
143 |                               (write-string "; " *dot-output*)
144 |                               (dot-write-attribute *dot-output* "margin" ".5")
145 |                               (write-string "; " *dot-output*)
146 |                               (walk-packages root packages-to-walk #'write-package-graph-node))))
147 | 
148 | (defun print-packages (&key packages (stream *standard-output*) root)
149 |   (flet ((print-package-node (package &optional (other-package nil op-p) relation)
150 |            (cond (op-p
151 |                   (terpri stream)
152 |                   (dotimes (x (+ 5 (* 5 *package-print-level*))) (write-char #\space stream))
153 |                   (format stream "~a: ~a" relation (package-name other-package)))
154 |                  (t
155 |                   (terpri stream)
156 |                   (dotimes (x (* 5 *package-print-level*)) (write-char #\space stream))
157 |                   (format stream "~a~@[ ~a~]" (package-name package) (package-nicknames package))))
158 |            package))
159 |     (walk-packages root packages #'print-package-node)))
160 | 
161 | 
162 | 
163 | 
164 | :EOF
165 | 


--------------------------------------------------------------------------------
/lgpl.txt:
--------------------------------------------------------------------------------
  1 | 		   GNU LESSER GENERAL PUBLIC LICENSE
  2 |                        Version 3, 29 June 2007
  3 | 
  4 |  Copyright (C) 2007 Free Software Foundation, Inc. 
  5 |  Everyone is permitted to copy and distribute verbatim copies
  6 |  of this license document, but changing it is not allowed.
  7 | 
  8 | 
  9 |   This version of the GNU Lesser General Public License incorporates
 10 | the terms and conditions of version 3 of the GNU General Public
 11 | License, supplemented by the additional permissions listed below.
 12 | 
 13 |   0. Additional Definitions.
 14 | 
 15 |   As used herein, "this License" refers to version 3 of the GNU Lesser
 16 | General Public License, and the "GNU GPL" refers to version 3 of the GNU
 17 | General Public License.
 18 | 
 19 |   "The Library" refers to a covered work governed by this License,
 20 | other than an Application or a Combined Work as defined below.
 21 | 
 22 |   An "Application" is any work that makes use of an interface provided
 23 | by the Library, but which is not otherwise based on the Library.
 24 | Defining a subclass of a class defined by the Library is deemed a mode
 25 | of using an interface provided by the Library.
 26 | 
 27 |   A "Combined Work" is a work produced by combining or linking an
 28 | Application with the Library.  The particular version of the Library
 29 | with which the Combined Work was made is also called the "Linked
 30 | Version".
 31 | 
 32 |   The "Minimal Corresponding Source" for a Combined Work means the
 33 | Corresponding Source for the Combined Work, excluding any source code
 34 | for portions of the Combined Work that, considered in isolation, are
 35 | based on the Application, and not on the Linked Version.
 36 | 
 37 |   The "Corresponding Application Code" for a Combined Work means the
 38 | object code and/or source code for the Application, including any data
 39 | and utility programs needed for reproducing the Combined Work from the
 40 | Application, but excluding the System Libraries of the Combined Work.
 41 | 
 42 |   1. Exception to Section 3 of the GNU GPL.
 43 | 
 44 |   You may convey a covered work under sections 3 and 4 of this License
 45 | without being bound by section 3 of the GNU GPL.
 46 | 
 47 |   2. Conveying Modified Versions.
 48 | 
 49 |   If you modify a copy of the Library, and, in your modifications, a
 50 | facility refers to a function or data to be supplied by an Application
 51 | that uses the facility (other than as an argument passed when the
 52 | facility is invoked), then you may convey a copy of the modified
 53 | version:
 54 | 
 55 |    a) under this License, provided that you make a good faith effort to
 56 |    ensure that, in the event an Application does not supply the
 57 |    function or data, the facility still operates, and performs
 58 |    whatever part of its purpose remains meaningful, or
 59 | 
 60 |    b) under the GNU GPL, with none of the additional permissions of
 61 |    this License applicable to that copy.
 62 | 
 63 |   3. Object Code Incorporating Material from Library Header Files.
 64 | 
 65 |   The object code form of an Application may incorporate material from
 66 | a header file that is part of the Library.  You may convey such object
 67 | code under terms of your choice, provided that, if the incorporated
 68 | material is not limited to numerical parameters, data structure
 69 | layouts and accessors, or small macros, inline functions and templates
 70 | (ten or fewer lines in length), you do both of the following:
 71 | 
 72 |    a) Give prominent notice with each copy of the object code that the
 73 |    Library is used in it and that the Library and its use are
 74 |    covered by this License.
 75 | 
 76 |    b) Accompany the object code with a copy of the GNU GPL and this license
 77 |    document.
 78 | 
 79 |   4. Combined Works.
 80 | 
 81 |   You may convey a Combined Work under terms of your choice that,
 82 | taken together, effectively do not restrict modification of the
 83 | portions of the Library contained in the Combined Work and reverse
 84 | engineering for debugging such modifications, if you also do each of
 85 | the following:
 86 | 
 87 |    a) Give prominent notice with each copy of the Combined Work that
 88 |    the Library is used in it and that the Library and its use are
 89 |    covered by this License.
 90 | 
 91 |    b) Accompany the Combined Work with a copy of the GNU GPL and this license
 92 |    document.
 93 | 
 94 |    c) For a Combined Work that displays copyright notices during
 95 |    execution, include the copyright notice for the Library among
 96 |    these notices, as well as a reference directing the user to the
 97 |    copies of the GNU GPL and this license document.
 98 | 
 99 |    d) Do one of the following:
100 | 
101 |        0) Convey the Minimal Corresponding Source under the terms of this
102 |        License, and the Corresponding Application Code in a form
103 |        suitable for, and under terms that permit, the user to
104 |        recombine or relink the Application with a modified version of
105 |        the Linked Version to produce a modified Combined Work, in the
106 |        manner specified by section 6 of the GNU GPL for conveying
107 |        Corresponding Source.
108 | 
109 |        1) Use a suitable shared library mechanism for linking with the
110 |        Library.  A suitable mechanism is one that (a) uses at run time
111 |        a copy of the Library already present on the user's computer
112 |        system, and (b) will operate properly with a modified version
113 |        of the Library that is interface-compatible with the Linked
114 |        Version.
115 | 
116 |    e) Provide Installation Information, but only if you would otherwise
117 |    be required to provide such information under section 6 of the
118 |    GNU GPL, and only to the extent that such information is
119 |    necessary to install and execute a modified version of the
120 |    Combined Work produced by recombining or relinking the
121 |    Application with a modified version of the Linked Version. (If
122 |    you use option 4d0, the Installation Information must accompany
123 |    the Minimal Corresponding Source and Corresponding Application
124 |    Code. If you use option 4d1, you must provide the Installation
125 |    Information in the manner specified by section 6 of the GNU GPL
126 |    for conveying Corresponding Source.)
127 | 
128 |   5. Combined Libraries.
129 | 
130 |   You may place library facilities that are a work based on the
131 | Library side by side in a single library together with other library
132 | facilities that are not Applications and are not covered by this
133 | License, and convey such a combined library under terms of your
134 | choice, if you do both of the following:
135 | 
136 |    a) Accompany the combined library with a copy of the same work based
137 |    on the Library, uncombined with any other library facilities,
138 |    conveyed under the terms of this License.
139 | 
140 |    b) Give prominent notice with the combined library that part of it
141 |    is a work based on the Library, and explaining where to find the
142 |    accompanying uncombined form of the same work.
143 | 
144 |   6. Revised Versions of the GNU Lesser General Public License.
145 | 
146 |   The Free Software Foundation may publish revised and/or new versions
147 | of the GNU Lesser General Public License from time to time. Such new
148 | versions will be similar in spirit to the present version, but may
149 | differ in detail to address new problems or concerns.
150 | 
151 |   Each version is given a distinguishing version number. If the
152 | Library as you received it specifies that a certain numbered version
153 | of the GNU Lesser General Public License "or any later version"
154 | applies to it, you have the option of following the terms and
155 | conditions either of that published version or of any later version
156 | published by the Free Software Foundation. If the Library as you
157 | received it does not specify a version number of the GNU Lesser
158 | General Public License, you may choose any version of the GNU Lesser
159 | General Public License ever published by the Free Software Foundation.
160 | 
161 |   If the Library as you received it specifies that a proxy can decide
162 | whether future versions of the GNU Lesser General Public License shall
163 | apply, that proxy's public statement of acceptance of any version is
164 | permanent authorization for you to choose that version for the
165 | Library.
166 | 


--------------------------------------------------------------------------------
/walker/.svn/text-base/mcl.lisp.svn-base:
--------------------------------------------------------------------------------
  1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: de.setf.utility.implementation; -*-
  2 | ;;;
  3 | 
  4 | (in-package :de.setf.utility.implementation)
  5 | 
  6 | 
  7 |  
  8 |   

  9 |   mcl ide tools to use the class/function/package grapher

 10 |   
 11 |  
 12 |   all rights reserved. no warranty.
 13 |   [0]
 14 |   [1]
 15 |  
 16 |   combined ide interface to various graphers
 17 |   
 18 |  
 19 | 
 20 | (defparameter *graph-menu-packages* nil
 21 |   "binds a list of known packages. this set of packages is compared with
 22 | the result of list-all-packages when updating the graph menu. when
 23 | they differ the set of menu entires is rebuilt.")
 24 | 
 25 | (defparameter *graph-packages* (list (find-package :common-lisp))
 26 |   "binds the list of packages for the symbols which name objects to be
 27 | included in in graph output. the initial value is a list which contains the 
 28 | common-lisp package. the constituency is modified according to selections
 29 | from the entries in the packages submenu of the graphs menu." )
 30 | 
 31 | (defClass graph-package-menu (menu) ()
 32 |   (:documentation
 33 |    "a specialized menu class to support an update method which rebuilds
 34 | the menu to reflect the set of all known packages."))
 35 | 
 36 | 
 37 | 

 38 |  add a subment to the Tools menu with entries for graphing classes,
 39 | packages and functions, and a final entry for a further submenu which
 40 | displays all known packages and lets one specify whether they should be
 41 | included in graphs.
 42 |  

 43 | 
 44 | (defparameter *graph-package-menu*
 45 |   (make-instance 'graph-package-menu
 46 |     :menu-title "Packages"))
 47 | 
 48 | (defParameter *graph-menu*
 49 |   (make-instance 'menu
 50 |     :menu-title "Graph"
 51 |     :menu-items (list (make-instance 'window-menu-item
 52 |                         :menu-item-title "Classes"
 53 |                         :menu-item-action 'ide-graph-classes)
 54 |                       (make-instance 'window-menu-item
 55 |                         :menu-item-title "Packages"
 56 |                         :menu-item-action 'ide-graph-packages)
 57 |                       (make-instance 'window-menu-item
 58 |                         :menu-item-title "Functions"
 59 |                         :menu-item-action 'ide-graph-functions)
 60 |                       (make-instance 'menu-item
 61 |                         :menu-item-title "-")
 62 |                       *graph-package-menu*)))
 63 | 
 64 | 
 65 | (defMethod menu-update ((menu graph-package-menu))
 66 |   "check of the set of known packages has changed. if so, then rebuild the
 67 | packages submenu. continue with the general method in order to update the
 68 | individual menu entries."
 69 |   (let ((packages (list-all-packages)))
 70 |     (when (or (/= (length packages) (length *graph-menu-packages*))
 71 |               (/= (length packages) (length (intersection packages *graph-menu-packages*))))
 72 |       (setf *graph-menu-packages* (sort (copy-list packages)
 73 |                                         #'string-lessp :key #'package-name))
 74 |       (apply #'remove-menu-items menu
 75 |              (menu-items menu))
 76 |       (apply #'add-menu-items menu
 77 |              (mapcar #'(lambda (package)
 78 |                          (make-instance 'menu-item
 79 |                            :menu-item-title (package-name package)
 80 |                            :menu-item-action #'(lambda ()
 81 |                                                  (if (find package *graph-packages*)
 82 |                                                    (setf *graph-packages* (remove package *graph-packages*))
 83 |                                                    (push package *graph-packages*)))
 84 |                            :update-function #'(lambda (item)
 85 |                                                 (set-menu-item-check-mark item (if (find package *graph-packages*) t nil)))))
 86 |                      *graph-menu-packages*))))
 87 |   (call-next-method))
 88 | 
 89 | (let* ((menu (find-menu "Tools")))
 90 |   (unless (find-menu-item menu "Graph")
 91 |     (add-menu-items menu *graph-menu*)))
 92 | 
 93 | ;(remove-menu-items (find-menu "Tools") (find-menu-item (find-menu "Tools") "Graph"))
 94 | 
 95 | 

 96 |  allow two alternative means to specify the initial designator.
 97 |  if the active window exhibits a selected symbol, use that.
 98 |  otherwise prompt the user for a symbol.
 99 |  

100 | 
101 | (defMethod window-selected-symbol ((window window))
102 |   "read the current selection and require that it be a symbol."
103 |   (multiple-value-bind (start end) (selection-range window)
104 |     (unless (= start end)
105 |       (let ((datum (ignore-errors (ccl::stream-position window start) (read window))))
106 |         (when (and datum (symbolp datum))
107 |           datum)))))
108 | 
109 | (defun get-symbol-from-user (&optional (prompt "enter a symbol"))
110 |   "prompt the user for a symbol and read the returned string"
111 |   (read-from-string (get-string-from-user prompt)))
112 | 
113 | 

114 |  provide an abstract mechanism to save a result in a temporary file
115 | and start a program to present the graph. if no application is provided
116 | the os makes the choice. omnigraffle works well with .dot files.
117 | 

118 | each of the ide-graph-* functions extracts a symbol and invokes the
119 | respective graphing function to generate a graph file which is then
120 | opened.
121 |  

122 | 
123 | (defun call-with-application-file (function &key application type)
124 |   (let* ((pathname (make-pathname :host "home"
125 |                                   :name (multiple-value-bind (sec min hour day month year) (decode-universal-time (get-universal-time))
126 |                                           (format nil "~@[~a-~]~4,'0d~2,'0d~2,'0dT~2,'0d~2,'0d~2,'0d"
127 |                                                   type year month day hour min sec))
128 |                                   :type "dot")))
129 |     (prog1 (funcall function pathname)
130 |       (set-mac-file-creator pathname (intern (make-string 4 :initial-element #\null) :keyword))
131 |       (setf pathname (namestring (truename pathname)))
132 |       (setf pathname (subseq pathname (1+ (position #\: pathname))))
133 |       (bsd:system-command (format nil  "open ~@[-a ~a~] '/~a'" application (substitute #\/ #\: pathname))))))
134 | 
135 | (defMethod ide-graph-classes ((window fred-window))
136 |   (let* ((*package* (window-package window))
137 |          (class-symbol (or (window-selected-symbol window) (get-symbol-from-user "enter class name"))))
138 |     (call-with-application-file
139 |      #'(lambda (pathname)
140 |          (let ((*class-walk-depth-limit* 10))
141 |            (graph-classes :stream pathname :class class-symbol
142 |                           :packages (cons (symbol-package class-symbol) *graph-packages*)
143 |                           ; :packages (list-all-packages)
144 |                           )))
145 |      :type 'class)))
146 | 
147 | (defMethod ide-graph-functions ((window fred-window))
148 |   (let* ((*package* (window-package window))
149 |          (function-symbol (or (window-selected-symbol window) (get-symbol-from-user "enter function name"))))
150 |     (call-with-application-file
151 |      #'(lambda (pathname)
152 |          (let ((*function-walk-depth-limit* 5))
153 |            (graph-functions :stream pathname :function function-symbol
154 |                             :packages (cons (symbol-package function-symbol) *graph-packages*)
155 |                             ; :packages (list-all-packages)
156 |                             :depth-limit 3)))
157 |      :type 'function)))
158 | 
159 | (defMethod ide-graph-packages ((window fred-window))
160 |   (let* ((package-designator (or (window-selected-symbol window)
161 |                                  (get-string-from-user "package-name"
162 |                                                        :initial-string (package-name (window-package window))))))
163 |     (typecase package-designator
164 |       (string (setf package-designator (find-package package-designator)))
165 |       (symbol (setf package-designator (symbol-package package-designator))))
166 |     (call-with-application-file
167 |      #'(lambda (pathname)
168 |          (graph-packages :stream pathname
169 |                          :root package-designator
170 |                          :packages-to-walk (cons package-designator *graph-packages*)))
171 |      :type 'package)))
172 | 
173 | 
174 |     
175 | 
176 | :EOF
177 | 


--------------------------------------------------------------------------------
/walker/.svn/text-base/class-graph.lisp.svn-base:
--------------------------------------------------------------------------------
  1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: de.setf.utility.implementation; -*-
  2 | ;;;
  3 | 
  4 | (in-package :de.setf.utility.implementation)
  5 | 
  6 | 
  7 |  
  8 |   

  9 |   a simple class grapher 

 10 |   

 11 |   this file specializes graph walking classes to implement a class hierarchy walker and
 12 |   provides two interface functions. one, graph-classes, generates a graphviz dot file
 13 |   which depicts the hierarchy. the second, print classes, prints a formatted list of
 14 |   which depicts the class tree.
 
 15 |   
 16 |  all rights reserved. no warranty.
 17 |   [0]
 18 |   [1]
 19 |  
 20 |   
 21 |    cleaned up and adjusted for denominated methods
 22 |    corrected qualifier slot name for walker class
 23 |   
 24 |  
 25 | 
 26 | (modPackage :de.setf.utility.clos.graph
 27 |   (:use-only )
 28 |   (:use-by :de.setf.utility.implementation)
 29 |   (:export
 30 |    :class-walker
 31 |    :walk-classes
 32 |    :graph-classes
 33 |    :print-classes
 34 |    ))
 35 | 
 36 | 
 37 | 
 38 | ;; dot-graphing for classes
 39 | 
 40 | (defparameter *class-walk-depth* 0)
 41 | (defparameter *class-walk-depth-limit* nil)
 42 | (defparameter *class-walk-count* 0)
 43 | (defparameter *class-walk-count-limit* nil)
 44 | 
 45 | (defvar *superclass-link* 'superclass
 46 |   "binds the link identifier for class-to-superclass links. the default value is superclass")
 47 | (defvar *subclass-link* 'subclass
 48 |   "binds the link identifier for class-to-superclass links. the default value is subclass")
 49 | 
 50 | (defun coerce-to-class (datum)
 51 |   (etypecase datum
 52 |     (symbol (find-class datum))
 53 |     (class datum)))
 54 | 
 55 | 
 56 | (defClass class-walker (preorder-node-walker
 57 |                         preorder-link-walker
 58 |                         cyclic-walker
 59 |                         walk-qualifier)
 60 |   ((walk-qualifiers
 61 |     :initform '(subclass superclass binds relations other)
 62 |     :allocation :class)
 63 |    (effective-qualifiers
 64 |     :initform nil
 65 |     :accessor walker-effective-qualifiers
 66 |     :documentation
 67 |     "binds a list of the effective qualifiers for the particuler walker.
 68 |      these limit the relations followed.")))
 69 | 
 70 | (defmethod initialize-instance :after ((instance class-walker)
 71 |                                        &key (qualifiers nil qualifiers-p))
 72 |     (setf (walker-effective-qualifiers instance)
 73 |           (if qualifiers-p
 74 |             (remove-if-not #'(lambda (q) (find q qualifiers :test #'string-equal))
 75 |                            (walk-qualifiers instance))
 76 |             (walk-qualifiers instance))))
 77 | 
 78 | (defmethod walk-node-successors subclass
 79 |            ((walker class-walker) (class class) (op t))
 80 |   (when (find 'subclass (walker-effective-qualifiers walker))
 81 |     (dolist (subclass  (class-direct-subclasses class))
 82 |       (unless (find class (getf (walker-node-properties walker subclass) 'superclass))
 83 |         (push subclass (getf (walker-node-properties walker class) 'subclass))
 84 |         (walk-link walker *subclass-link* class subclass op))))
 85 |   class)
 86 | 
 87 | (defmethod walk-node-predecessors superclass
 88 |            ((walker class-walker) (class class) (op t))
 89 |   (when (find 'superclass (walker-effective-qualifiers walker))
 90 |     (dolist (superclass  (class-direct-superclasses class))
 91 |       (setf superclass (coerce-to-class superclass))
 92 |       (unless (find class (getf (walker-node-properties walker superclass) 'subclass))
 93 |         (push superclass (getf (walker-node-properties walker class) 'superclass))
 94 |         (walk-link walker *superclass-link* class superclass op))))
 95 |   class)
 96 | 
 97 | (defmethod walk-node-predecessors binds
 98 |            ((walker class-walker) (class standard-class) (op t))
 99 |   (when (find 'binds (walker-effective-qualifiers walker))
100 |     (flet ((walk-slot (slot &aux (type (slot-definition-type slot)) (name (slot-definition-name slot)) slot-class)
101 |              (when (and type (not (eq type t)) (symbolp type)
102 |                         (setf slot-class (find-class type nil)))
103 |                (walk-link walker name class slot-class op))))
104 |       (declare (dynamic-extent #'walk-slot))
105 |       #+digitool
106 |       (map nil #'walk-slot (ccl::class-direct-class-slots class))
107 |       #+digitool
108 |       (map nil #'walk-slot (class-direct-instance-slots class))
109 |       #-ccl
110 |       (map nil #'walk-slot (class-direct--slots class))))
111 |   class)
112 | 
113 | (defMethod walk-link :around
114 |            ((walker class-walker) (relation t) (from class) (to class) (op t))
115 |   (when (find (symbol-package (class-name to)) *packages-to-walk*)
116 |     (let ((*class-walk-depth* (1+ *class-walk-depth*)))
117 |       (call-next-method)
118 |       to)))
119 | 
120 | (defmethod walk-node :denominative ((navigator class-walker) (node t) (operator t)))
121 | (defmethod walk-node-predecessors :denominative ((navigator class-walker) (node t) (operator t)))
122 | (defmethod walk-node-successors :denominative ((navigator class-walker) (node t) (operator t)))
123 | (defmethod walk-link :denominative ((walker class-walker) (relation t) (from t) (to t) (op t)))
124 | 
125 | 
126 | ;;;
127 | ;;; interface
128 | 
129 | (defGeneric walk-classes (root classes op &key &allow-other-keys)
130 |   (:argument-precedence-order classes root op)
131 |    (:method ((root class) (classes null) op &rest options)
132 |            (apply #'walk-classes root (list (symbol-package (class-name root))) op options))
133 |   (:method ((root t) (package-predicate function) op &rest options)
134 |            (apply #'walk-packages root (remove-if-not package-predicate (list-all-packages)) op options))
135 |   (:method ((root symbol) (packages t) (op t) &rest options)
136 |            (apply #'walk-classes (find-class root) packages op options))
137 |   (:method ((root class) (*packages-to-walk* cons) op &rest options)
138 |            (setf *packages-to-walk* (mapcar #'coerce-to-package *packages-to-walk*))
139 |            (walk-model root (apply #'make-instance 'class-walker options) op)))
140 |             
141 | 
142 | (defun write-graph-statement (class &optional (other-class nil op-p) relation)
143 |   (when (and (or (null *class-walk-depth-limit*) (<= *class-walk-depth* *class-walk-depth-limit*))
144 |              (or (null *class-walk-count-limit*) (<= *class-walk-count* *class-walk-count-limit*)))
145 |     (cond (op-p
146 |            ;; a link
147 |            (dot:dot-write-edge-statement dot:*dot-output*
148 |                                          (class-name class) (class-name other-class)
149 |                                          `(("label" . ,(string relation)))))
150 |           (t
151 |            (incf *class-walk-count*)
152 |            (dot:dot-write-node-statement dot:*dot-output* (class-name class) nil))))
153 |   class)
154 | 
155 | 
156 | 
157 | 
158 | (defun graph-classes (&key packages (stream *standard-output*) class
159 |                       ((:depth-limit *class-walk-depth-limit*) *class-walk-depth-limit*)
160 |                       ((:count-limit *class-walk-count-limit*) *class-walk-count-limit*)
161 |                       (options nil)
162 |                       &aux (*class-walk-count* 0))
163 |   (dot:dot-write-graph stream
164 |                        #'(lambda (grapher)
165 |                            (declare (ignore grapher))
166 |                            (dot-write-attribute *dot-output* "size" "8.5,11")
167 |                            (write-string "; " *dot-output*)
168 |                            (dot-write-attribute *dot-output* "ratio" "compress")
169 |                            (write-string "; " *dot-output*)
170 |                            (dot-write-attribute *dot-output* "rankdir" "LR")
171 |                            (write-string "; " *dot-output*)
172 |                            (dot-write-attribute *dot-output* "margin" ".5")
173 |                            (write-string "; " *dot-output*)
174 |                            (apply #'walk-classes class packages #'write-graph-statement
175 |                                   options)))
176 |   *class-walk-count*)
177 | 
178 | (defun print-classes (&key packages (stream *standard-output*) class)
179 |   (flet ((print-class (class &optional (other nil other-p) relation)
180 |            (cond (other-p
181 |                   (terpri stream)
182 |                   (dotimes (x (* 5 *class-walk-depth*)) (write-char #\space stream))
183 |                   (format stream "~a -> ~a" relation (class-name other)))
184 |                  (t
185 |                   (terpri stream)
186 |                   (dotimes (x (* 5 *class-walk-depth*)) (write-char #\space stream))
187 |                   (format stream "~a:" (class-name class))))
188 |            class))
189 |     (walk-classes class packages #'print-class)))
190 | 
191 | 
192 | 
193 | :EOF
194 | 


--------------------------------------------------------------------------------