From 321f3f3002023af0bcb11925b56b44b95666ac5d Mon Sep 17 00:00:00 2001 From: tony Date: Fri, 16 May 2008 07:54:03 +0200 Subject: [PATCH] Redid ch-asdf and ch-util as submodules from Cyrus's repo. --- .gitignore | 1 - .gitmodules | 6 + external/ch-asdf.git | 1 + external/ch-asdf/ch-asdf.asd | 44 --- external/ch-asdf/src/asdf-util.cl | 54 ---- external/ch-asdf/src/ch-asdf.cl | 555 ---------------------------------- external/ch-asdf/src/defpackage.cl | 53 ---- external/ch-asdf/version.lisp-expr | 1 - external/ch-util.git | 1 + external/ch-util/COPYRIGHT | 28 -- external/ch-util/README | 1 - external/ch-util/bootstrap.cl | 7 - external/ch-util/ch-util-test.asd | 39 --- external/ch-util/ch-util.asd | 54 ---- external/ch-util/make-dist.sh | 10 - external/ch-util/src/array.cl | 16 - external/ch-util/src/bytebuffer.cl | 60 ---- external/ch-util/src/ch-asdf.cl | 87 ------ external/ch-util/src/ch-util.cl | 248 --------------- external/ch-util/src/debug.cl | 63 ---- external/ch-util/src/defpackage.cl | 84 ----- external/ch-util/src/filesystem.cl | 199 ------------ external/ch-util/src/hash-table.cl | 60 ---- external/ch-util/src/lists.cl | 47 --- external/ch-util/src/macros.cl | 37 --- external/ch-util/src/sequence.cl | 18 -- external/ch-util/src/testharness.cl | 26 -- external/ch-util/src/vector.cl | 20 -- external/ch-util/test/defpackage.cl | 10 - external/ch-util/test/test-ch-util.cl | 37 --- external/ch-util/version.lisp-expr | 1 - 31 files changed, 8 insertions(+), 1860 deletions(-) create mode 100644 .gitmodules create mode 160000 external/ch-asdf.git delete mode 100644 external/ch-asdf/ch-asdf.asd delete mode 100644 external/ch-asdf/src/asdf-util.cl delete mode 100644 external/ch-asdf/src/ch-asdf.cl delete mode 100644 external/ch-asdf/src/defpackage.cl delete mode 100644 external/ch-asdf/version.lisp-expr create mode 160000 external/ch-util.git delete mode 100644 external/ch-util/COPYRIGHT delete mode 100644 external/ch-util/README delete mode 100644 external/ch-util/bootstrap.cl delete mode 100644 external/ch-util/ch-util-test.asd delete mode 100644 external/ch-util/ch-util.asd delete mode 100644 external/ch-util/make-dist.sh delete mode 100644 external/ch-util/src/array.cl delete mode 100644 external/ch-util/src/bytebuffer.cl delete mode 100644 external/ch-util/src/ch-asdf.cl delete mode 100644 external/ch-util/src/ch-util.cl delete mode 100644 external/ch-util/src/debug.cl delete mode 100644 external/ch-util/src/defpackage.cl delete mode 100644 external/ch-util/src/filesystem.cl delete mode 100644 external/ch-util/src/hash-table.cl delete mode 100644 external/ch-util/src/lists.cl delete mode 100644 external/ch-util/src/macros.cl delete mode 100644 external/ch-util/src/sequence.cl delete mode 100644 external/ch-util/src/testharness.cl delete mode 100644 external/ch-util/src/vector.cl delete mode 100644 external/ch-util/test/defpackage.cl delete mode 100644 external/ch-util/test/test-ch-util.cl delete mode 100644 external/ch-util/version.lisp-expr diff --git a/.gitignore b/.gitignore index 67208a8..2aee5ad 100644 --- a/.gitignore +++ b/.gitignore @@ -8,5 +8,4 @@ fasl *.o *.flc *.x86f -external/* test-results/ diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..6adead0 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,6 @@ +[submodule "external/ch-asdf.git"] + path = external/ch-asdf.git + url = git://cyrusharmon.org/pub/git/ch-asdf.git +[submodule "external/ch-util.git"] + path = external/ch-util.git + url = git://cyrusharmon.org/pub/git/ch-util.git diff --git a/external/ch-asdf.git b/external/ch-asdf.git new file mode 160000 index 0000000..75ba984 --- /dev/null +++ b/external/ch-asdf.git @@ -0,0 +1 @@ +Subproject commit 75ba9843c293cad2f8c7e15200f6c7e27e14032f diff --git a/external/ch-asdf/ch-asdf.asd b/external/ch-asdf/ch-asdf.asd deleted file mode 100644 index 0d2a56a..0000000 --- a/external/ch-asdf/ch-asdf.asd +++ /dev/null @@ -1,44 +0,0 @@ - -(defpackage #:ch-asdf-system (:use #:asdf #:cl)) -(in-package #:ch-asdf-system) - -;;;; -;;;; The following section customizes asdf to work with filenames -;;;; with a .cl extension and to put fasl files in a separate -;;;; directory. -;;;; -;;;; To enable this behvior, use asdf component type -;;;; :ch-asdf-cl-source-file -;;;; -(defclass ch-asdf-cl-source-file (cl-source-file) ()) - -(defparameter *fasl-directory* - (make-pathname :directory '(:relative #+sbcl "sbcl-fasl" - #+openmcl "openmcl-fasl" - #-(or sbcl openmcl) "fasl"))) - -(defmethod source-file-type ((c ch-asdf-cl-source-file) (s module)) "cl") - -(defmethod asdf::output-files :around ((operation compile-op) (c ch-asdf-cl-source-file)) - (list (merge-pathnames *fasl-directory* (compile-file-pathname (component-pathname c))))) - -(defsystem #:ch-asdf - :name "ch-asdf" - :author "Cyrus Harmon " - :version #.(with-open-file - (vers (merge-pathnames "version.lisp-expr" *load-truename*)) - (read vers)) - :depends-on (:ch-util :puri) - :licence "BSD" - :description "ASDF Extensions from Cyrus Harmon" - :components - ((:static-file "version" :pathname #p"version.lisp-expr") - (:module - :src - :components - ((:ch-asdf-cl-source-file "defpackage") - (:ch-asdf-cl-source-file "asdf-util" - :depends-on ("defpackage")) - (:ch-asdf-cl-source-file "ch-asdf" - :depends-on ("defpackage" "asdf-util")))))) - diff --git a/external/ch-asdf/src/asdf-util.cl b/external/ch-asdf/src/asdf-util.cl deleted file mode 100644 index 704a17a..0000000 --- a/external/ch-asdf/src/asdf-util.cl +++ /dev/null @@ -1,54 +0,0 @@ -;; -;; file: asdf-util.cl -;; author: cyrus harmon -;; - -(in-package :ch-asdf) - -(defun unix-name (pathname) - (namestring - (typecase pathname - (logical-pathname (translate-logical-pathname pathname)) - (t pathname)))) - -(defun absolute-path-p (path) - (when (listp (pathname-directory path)) - (eql (car (car (pathname-directory path))) - :absolute))) - -(defun asdf-lookup (path) - (cond ((and path (listp path)) - (reduce #'asdf:find-component (cdr path) - :initial-value (asdf:find-system (car path)))) - ((stringp path) - (let ((uri (puri:parse-uri path))) - (when uri - (let ((scheme (puri:uri-scheme uri))) - (when (and (or (null scheme) - (eql scheme :asdf)) - (puri:uri-parsed-path uri)) - (asdf-lookup (cdr (puri:uri-parsed-path uri)))))))))) - -(defun asdf-lookup-path (path) - (component-pathname (asdf-lookup path))) - -(defun merge-asdf-path (name path) - (merge-pathnames name (asdf-lookup-path path))) - -(defmacro with-component-directory ((component) &body body) - `(ch-util::with-current-directory - (make-pathname - :directory (pathname-directory - (component-pathname ,component))) - ,@body)) - -(flet ((asdf-op (op component) - (typecase component - (string - (asdf:operate 'asdf:load-op (asdf-lookup component))) - (t (asdf:operate 'asdf:load-op component))))) - (defun asdf-load (component) - (asdf-op 'asdf:load-op component)) - (defun asdf-compile (component) - (asdf-op 'asdf:compile-op component))) - diff --git a/external/ch-asdf/src/ch-asdf.cl b/external/ch-asdf/src/ch-asdf.cl deleted file mode 100644 index 95a43ed..0000000 --- a/external/ch-asdf/src/ch-asdf.cl +++ /dev/null @@ -1,555 +0,0 @@ -;; -;; file: ch-asdf.cl -;; author: cyrus harmon -;; - -(in-package :ch-asdf) - -(defparameter *c-compiler* "gcc") - -(defclass clean-op (operation) ()) - -(defmethod perform ((operation clean-op) (c component)) - nil) - -(defclass ch-cl-source-file (cl-source-file) ()) - -(defparameter *fasl-directory* - (make-pathname :directory '(:relative #+sbcl "sbcl-fasl" - #+openmcl "openmcl-fasl" - #-(or sbcl openmcl) "fasl"))) - -(defmethod source-file-type ((c ch-cl-source-file) (s module)) "cl") - -(defmethod output-files :around ((operation compile-op) (c ch-cl-source-file)) - (list (merge-pathnames *fasl-directory* (compile-file-pathname (component-pathname c))))) - -(defclass ch-lisp-source-file (cl-source-file) ()) - -(defparameter *fasl-directory* - (make-pathname :directory '(:relative #+sbcl "sbcl-fasl" - #+openmcl "openmcl-fasl" - #-(or sbcl openmcl) "fasl"))) - -(defmethod output-files :around ((operation compile-op) (c ch-lisp-source-file)) - (list (merge-pathnames *fasl-directory* (compile-file-pathname (component-pathname c))))) - -;;;; C source file compilation section -;;;; ripped from sb-posix.asd in the sbcl source code - -(defclass unix-dso (module) - ((dso-name :accessor dso-name :initarg :dso-name) - (dso-directory :accessor dso-directory :initarg :dso-directory) - (include-directories :accessor include-directories :initarg :include-directories :initform nil) - (link-library-directories :accessor link-library-directories :initarg :link-library-directories :initform nil) - (link-libraries :accessor link-libraries :initarg :link-libraries :initform nil) - (dso-type :accessor dso-type :initarg :dso-type :initform - ;; fill appropriate OS specific types in here - #+darwin "so" - #-darwin "so"))) - -(defmethod input-files ((operation compile-op) (dso unix-dso)) - (mapcar #'component-pathname (module-components dso))) - -(defmethod output-files ((operation compile-op) (dso unix-dso)) - (let ((dir (component-pathname dso))) - (list - (make-pathname :type (dso-type dso) - :name (if (slot-boundp dso 'dso-name) - (dso-name dso) - (car (last (pathname-directory dir)))) - :directory (cond - ((slot-boundp dso 'dso-directory) - (let ((dso-pathname - (merge-pathnames (dso-directory dso) - (component-pathname dso)))) - (ensure-directories-exist dso-pathname) - (pathname-directory dso-pathname))) - ((and (slot-boundp dso 'dso-name) - (absolute-path-p (dso-name dso))) - nil) - (t (butlast (pathname-directory dir)))) - :defaults dir)))) - -(defmethod perform :after ((operation compile-op) (dso unix-dso)) - (let ((dso-name (unix-name (car (output-files operation dso))))) - (unless (zerop - (run-shell-command - "~A ~A -o ~S ~{~S ~}" - *c-compiler* - (concatenate 'string - ;; This really should be specified as an initarg of the unix-dso - ;; rather than hard coded here! - ;; e.g. :components (... (:unix-library "R" :library-directory *r-dir*)) - (sb-ext:posix-getenv "EXTRA_LDFLAGS") - " " - (format nil " ~{-L~A~^ ~} " (link-library-directories dso)) - #-darwin - (format nil " ~{-Xlinker -rpath -Xlinker ~A~^ ~} " (link-library-directories dso)) - (format nil " ~{-l~A~^ ~} " (link-libraries dso)) - #+sunos " -shared -lresolv -lsocket -lnsl " - #+darwin " -bundle " - #-(or darwin sunos) " -shared ") - dso-name - (mapcar #'unix-name - (mapcan (lambda (c) - (output-files operation c)) - (module-components dso))))) - (error 'operation-error :operation operation :component dso)))) - -;;;; Unix executables -;;;; -(defclass unix-executable (module) - ((include-directories :accessor include-directories :initarg :include-directories :initform nil) - (link-library-directories :accessor link-library-directories :initarg :link-library-directories :initform nil) - (link-libraries :accessor link-libraries :initarg :link-libraries :initform nil) - (source-files :accessor source-files :initarg :source-files :initform nil))) - -(defmethod input-files ((operation compile-op) (executable unix-executable)) - (declare (optimize (debug 3))) - (let ((files - (mapcan #'(lambda (obj) - (output-files operation (get-sibling-component executable obj))) - (source-files executable)))) - (append (mapcar #'unix-name files) - (mapcar #'component-pathname (module-components executable))))) - -(defmethod output-files ((operation compile-op) (executable unix-executable)) - (list (component-pathname executable))) - -#+nil -(defmethod operation-done-p ((o compile-op) (c unix-executable)) - nil) - -(defmethod perform :after ((operation compile-op) (executable unix-executable)) - (let ((executable-name (unix-name (car (output-files operation executable))))) - (unless (zerop - (run-shell-command - "~A ~A ~A -o ~S ~{~S ~}" - *c-compiler* - *c-compiler-options* - (concatenate 'string - ;; This really should be specified as an initarg of the unix-executable - ;; rather than hard coded here! - ;; e.g. :components (... (:unix-library "R" :library-directory *r-dir*)) - (sb-ext:posix-getenv "EXTRA_LDFLAGS") - " " - (format nil " ~{-L~A~^ ~} " (link-library-directories executable)) - #-darwin - (format nil " ~{-Xlinker -rpath -Xlinker ~A~^ ~} " (link-library-directories executable)) - (format nil " ~{-l~A~^ ~} " (link-libraries executable)) - (format nil " ~{~A~^ ~} " (input-files operation executable))) - executable-name - nil - #+nil - (mapcar #'unix-name - (mapcan (lambda (c) - (output-files operation c)) - (module-components executable))))) - (error 'operation-error :operation operation :component executable)))) - -(defmethod component-depends-on ((op compile-op) (c unix-executable)) - (append (call-next-method) - (mapcar #'(lambda (x) - `(compile-op ,x)) - (source-files c)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; C Header Files -(defclass c-header-file (source-file) ()) - -(defmethod perform ((op compile-op) (c c-header-file))) - -(defmethod perform ((op load-op) (c c-header-file))) - -(defmethod source-file-type ((c c-header-file) (s module)) "h") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; C Source Files - -;;; if this goes into the standard asdf, it could reasonably be extended -;;; to allow cflags to be set somehow -(defmethod output-files ((op compile-op) (c c-source-file)) - (list - (make-pathname :type "o" :defaults - (component-pathname c)))) - -(defgeneric get-include-directories (c)) - -(defmethod get-include-directories ((c c-source-file)) - (when (and - (slot-exists-p (component-parent c) 'include-directories) - (slot-boundp (component-parent c) 'include-directories)) - (mapcar - #'unix-name - (include-directories - (component-parent c))))) - -;;; -;;; removed this bit here: -;;; #+nil "~{-isystem ~A~^ ~}" -;;; #+nil (mapcar #'unix-name (system-include-directories c)) - -(defparameter *c-compiler-options* "-Wall") - -(defmethod perform ((op compile-op) (c c-source-file)) - (unless - (= 0 (run-shell-command - (concatenate 'string - (format nil "~A ~A ~A -o ~S -c ~S" - *c-compiler* - *c-compiler-options* - (concatenate - 'string - (format nil "~{-I~A~^ ~}" (get-include-directories c)) - " " (sb-ext:posix-getenv "EXTRA_CFLAGS") - " -fPIC") - (unix-name (car (output-files op c))) - (unix-name (component-pathname c)))))) - (error 'operation-error :operation op :component c))) - -(defmethod perform ((op load-op) (c c-source-file))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ASM Source Files -;;; -;;; NASTY cut-and-paste job here! - -(defclass asm-source-file (source-file) ()) - -(defmethod source-file-type ((c asm-source-file) (s module)) "s") - -(defmethod output-files ((op compile-op) (c asm-source-file)) - (list - (make-pathname :type "o" :defaults - (component-pathname c)))) - -(defgeneric get-include-directories (c)) - -(defmethod get-include-directories ((c asm-source-file)) - (when (and - (slot-exists-p (component-parent c) 'include-directories) - (slot-boundp (component-parent c) 'include-directories)) - (mapcar - #'unix-name - (include-directories - (component-parent c))))) - -(defmethod perform ((op compile-op) (c asm-source-file)) - (unless - (= 0 (run-shell-command - (concatenate 'string - (format nil "~A ~A -o ~S -c ~S" - *c-compiler* - (concatenate - 'string - (format nil "~{-I~A~^ ~}" (get-include-directories c)) - " " (sb-ext:posix-getenv "EXTRA_ASMFLAGS") - " -fPIC") - (unix-name (car (output-files op c))) - (unix-name (component-pathname c)))))) - (error 'operation-error :operation op :component c))) - -(defmethod perform ((op load-op) (c asm-source-file))) - -(defmethod perform ((o load-op) (c unix-dso)) - (let ((co (make-instance 'compile-op))) - (let ((filename (car (output-files co c)))) - #+cmu (ext:load-foreign filename) - #+sbcl (sb-alien:load-shared-object filename)))) - -;;;; ASDF hackery for generating components, generated source files -;;;; and other neat stuff. - -;;; -;;; generate-op -(defclass generate-op (asdf:operation) ()) - -;;; -;;; generated-component for components that generate files -(defclass generated-component (asdf:component) ()) - - -(defmethod perform ((op generate-op) (c component))) - -(defmethod perform ((op generate-op) (c generated-component))) - -(defmethod component-depends-on ((op compile-op) (c generated-component)) - (append (call-next-method) - `((generate-op ,(component-name c))))) - -(defmethod component-depends-on ((op load-op) (c generated-component)) - (append (call-next-method) - `((generate-op ,(component-name c))))) - - -(defmethod perform :before ((operation generate-op) (c generated-component)) - (map nil #'ensure-directories-exist (output-files operation c))) - -;;; -;;; generated-file - not all components will have files associated -;;; with them. for those that do, use this subclass of -;;; generated-component. -(defclass generated-file (generated-component source-file) ()) - -(defmethod asdf::component-relative-pathname ((component generated-file)) - (let ((relative-pathname (slot-value component 'asdf::relative-pathname))) - (if relative-pathname - relative-pathname - (let ((*default-pathname-defaults* - (asdf::component-parent-pathname component))) - (make-pathname - :name (component-name component)))))) - -(defclass generated-source-file (generated-file) ()) - -(defmethod operation-done-p ((o operation) (c generated-source-file)) - (let ((in-files (input-files o c))) - (if in-files - (and (every #'probe-file in-files) - (call-next-method)) - (call-next-method)))) - -(defmethod source-file-type ((c generated-file) (s module)) "") - -(defmethod perform ((op compile-op) (c generated-file))) - -(defmethod perform ((op load-op) (c generated-file))) - -;;; pdf files - -(defclass pdf-file (source-file) ()) -(defmethod source-file-type ((c pdf-file) (s module)) "pdf") - -(defmethod perform ((operation compile-op) (c pdf-file))) - -(defmethod perform ((operation load-op) (c pdf-file)) - (ch-util::app-open (unix-name (component-pathname c)))) - -(defmethod operation-done-p ((o load-op) (c pdf-file)) - nil) - - -;;; css files - -(defclass css-file (static-file) ()) -(defmethod source-file-type ((c css-file) (s module)) "css") - -;;; xhtml files - -(defclass xhtml-file (html-file) ()) -(defmethod source-file-type ((c xhtml-file) (s module)) "xhtml") - -;;; tiff files - -(defclass tiff-file (static-file) ()) -(defmethod source-file-type ((c tiff-file) (s module)) "tiff") - -;;; jpeg files - -(defclass jpeg-file (static-file) ()) -(defmethod source-file-type ((c jpeg-file) (s module)) "jpg") - -;;; png files - -(defclass png-file (static-file) ()) -(defmethod source-file-type ((c png-file) (s module)) "png") - -;;; markup files - -(defclass markup-file (source-file) ()) -(defmethod source-file-type ((c markup-file) (s module)) "gmarkup") - -(defclass markup-latex-file (generated-source-file) ()) -(defmethod source-file-type ((c markup-latex-file) (s module)) "tex") - -(defclass markup-pdf-file (pdf-file generated-source-file) ()) -(defclass markup-xhtml-file (xhtml-file) ()) - -;;; tinaa documentation - -(defclass tinaa-directory (module) ()) - -;;; Need a generic ASDF object that reads a file and associates an -;;; in-memory object with the file. It should cache the creation date -;;; of the object and reload the object if the modification date of -;;; the file is newer than the creation date of the in-memory object. - -(defun get-sibling-component (comp sib) - (asdf:find-component (asdf:component-parent comp) - (asdf::coerce-name sib))) - -(defclass object-component (generated-component) - ((symbol :accessor object-symbol :initarg :symbol))) - -(defmethod operation-done-p ((o generate-op) (c object-component)) - t) - -(defmethod source-file-type ((c object-component) (s module)) nil) - -(defun make-symbol-from-name (name) - (intern (string (read-from-string name)))) - -(defmethod shared-initialize :after ((c object-component) slot-names - &key force - &allow-other-keys) - (declare (ignore force)) - (when (slot-boundp c 'asdf::name) - (unless (slot-boundp c 'symbol) - (setf (object-symbol c) - (make-symbol-from-name (asdf::component-name c)))))) - -(defmethod perform ((op compile-op) (c object-component))) -(defmethod perform ((op load-op) (c object-component)) - (setf (component-property c 'last-loaded) - (get-universal-time))) - -(defmethod operation-done-p ((o compile-op) (c object-component)) - t) - -(defmethod operation-done-p ((o load-op) (comp object-component)) - (every #'identity - (loop for (dep-op dep-comp) in - (asdf::component-depends-on o comp) - collect (asdf::operation-done-p - (make-instance dep-op) - (get-sibling-component comp dep-comp))))) - -;;; An object-from-file is the file-based representation of an object. The -;;; load-op -(defclass object-from-file (object-component source-file) - ((load-date :accessor object-load-date :initarg :load-date))) - -(defmethod perform ((op compile-op) (c object-from-file)) - (setf (asdf:component-property c 'last-compiled) - (get-universal-time)) - (with-open-file (input-stream (component-pathname c)) - (setf (symbol-value (object-symbol c)) - (read input-stream))) - (call-next-method)) - -(defmethod perform ((op generate-op) (c object-from-file)) - (setf (asdf::component-property c 'last-generated) - (get-universal-time))) - -;;; this needs to check the file date!!!! -(defmethod operation-done-p ((o generate-op) (c object-from-file)) - (let ((on-disk-time - (file-write-date (component-pathname c))) - (my-last-load-time (asdf::component-property c 'last-loaded))) - (and on-disk-time - my-last-load-time - (>= my-last-load-time on-disk-time)))) - - -(defclass object-to-file (object-component) - ((write-date :accessor object-write-date :initarg :write-date))) - - -(defclass object-from-variable (object-component) - ((input-object :accessor object-input-object :initarg :input-object))) - -(defmethod component-depends-on ((op generate-op) (c object-from-variable)) - (append (call-next-method) - `((load-op , (asdf::coerce-name (object-input-object c)))))) - -(defmethod component-depends-on ((op compile-op) (c object-from-variable)) - (append (call-next-method) - `((load-op ,(asdf::coerce-name (object-input-object c)))))) - -(defmethod operation-done-p ((o generate-op) (c object-from-variable)) - (let ((input-object-last-load-time - (asdf::component-property - (find-component (component-parent c) - (asdf::coerce-name (object-input-object c))) - 'last-loaded)) - (my-last-generate-time (asdf::component-property c 'last-generated))) - (and input-object-last-load-time - my-last-generate-time - (>= my-last-generate-time input-object-last-load-time)))) - -(defmethod operation-done-p ((o compile-op) (c object-from-variable)) - (let ((my-last-generate-time (asdf::component-property c 'last-generated)) - (my-last-compile-time (asdf::component-property c 'last-compiled))) - (and my-last-generate-time - my-last-compile-time - (>= my-last-compile-time my-last-generate-time)))) - -(defmethod operation-done-p ((o load-op) (c object-from-variable)) - (let ((my-last-compile-time (asdf::component-property c 'last-compiled)) - (my-last-load-time (asdf::component-property c 'last-loaded))) - (and my-last-compile-time - my-last-load-time - (>= my-last-load-time my-last-compile-time)))) - -(defmethod perform ((op generate-op) (c object-from-variable)) - (setf (asdf:component-property c 'last-generated) - (get-universal-time)) - (let ((sexp - (symbol-value - (object-symbol - (find-component (component-parent c) - (asdf::coerce-name (object-input-object c))))))) - (setf (symbol-value (object-symbol c)) sexp))) - - -(defmethod perform ((op compile-op) (c object-from-variable)) - (setf (asdf:component-property c 'last-compiled) - (get-universal-time))) - -(defmethod perform ((op load-op) (c object-from-variable)) - (setf (asdf:component-property c 'last-loaded) - (get-universal-time))) - -(defclass load-only-file-mixin () - ()) - -(defclass load-only-cl-source-file (load-only-file-mixin cl-source-file) - ()) - -(defmethod perform ((op compile-op) (component load-only-file-mixin)) - nil) - -(defmethod perform ((op load-op) (component load-only-cl-source-file)) - (load (component-pathname component))) - -;;; graphviz dot-files - -(defparameter *dot-program* "dot") -(defparameter *dot-program-path* - (let ((found (sb-ext:find-executable-in-search-path - *dot-program*))) - (unless found - (setf found - #+darwin "/opt/local/bin/dot" - #-darwin "/usr/local/bin/dot")) - found)) - -(defclass graphviz-dot-file (generated-source-file) ()) - -(defmethod source-file-type ((c graphviz-dot-file) (s module)) "dot") - -(defmethod output-files ((operation compile-op) (c graphviz-dot-file)) - (list - (merge-pathnames (make-pathname :type "png") - (compile-file-pathname (component-pathname c))))) - -(defmethod perform ((op compile-op) (c graphviz-dot-file)) - (run-shell-command - "~A ~A -o~A ~A" - *dot-program-path* - "-Tpng" - (ch-asdf:unix-name (car (output-files op c))) - (ch-asdf:unix-name (component-pathname c)))) - - -;;; benchmarking stuff - -(defclass benchmark-op (operation) ()) - -(defmethod perform ((operation benchmark-op) (c component)) - (oos 'load-op c)) - - - diff --git a/external/ch-asdf/src/defpackage.cl b/external/ch-asdf/src/defpackage.cl deleted file mode 100644 index 98248e5..0000000 --- a/external/ch-asdf/src/defpackage.cl +++ /dev/null @@ -1,53 +0,0 @@ - -(in-package #:cl-user) - -(defpackage #:ch-asdf - (:use #:cl #:asdf) - (:export #:ch-cl-source-file - #:ch-lisp-source-file - #:c-header-file - #:asm-source-file - - #:unix-name - #:absolute-path-p - #:asdf-lookup - #:asdf-lookup-path - #:merge-asdf-path - #:with-component-directory - #:asdf-load - #:asdf-compile - - #:unix-dso - #:dso-type - #:dso-name - #:dso-directory - #:include-directories - #:system-include-directories - - #:unix-executable - - #:jpeg-file - #:png-file - #:tiff-file - - #:generated-file - #:generated-source-file - - #:pdf-file - #:css-file - #:xhtml-file - - #:markup-file - #:markup-latex-file - #:markup-pdf-file - #:markup-xhtml-file - - #:tinaa-directory - - #:object-component - #:object-from-variable - #:object-from-file - #:object-to-file - - #:graphviz-dot-file)) - diff --git a/external/ch-asdf/version.lisp-expr b/external/ch-asdf/version.lisp-expr deleted file mode 100644 index 4bd395d..0000000 --- a/external/ch-asdf/version.lisp-expr +++ /dev/null @@ -1 +0,0 @@ -"0.2.8" diff --git a/external/ch-util.git b/external/ch-util.git new file mode 160000 index 0000000..91f3a89 --- /dev/null +++ b/external/ch-util.git @@ -0,0 +1 @@ +Subproject commit 91f3a89216314f235d0c0cbe7507244f80917755 diff --git a/external/ch-util/COPYRIGHT b/external/ch-util/COPYRIGHT deleted file mode 100644 index 5ef0c8a..0000000 --- a/external/ch-util/COPYRIGHT +++ /dev/null @@ -1,28 +0,0 @@ -chutil, a library of common lisp utilities by Cyrus Harmon - -Copyright (c) 2005 Cyrus Harmon -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials - provided with the distribution. - -THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED -OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY -DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE -GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/external/ch-util/README b/external/ch-util/README deleted file mode 100644 index b009562..0000000 --- a/external/ch-util/README +++ /dev/null @@ -1 +0,0 @@ -README goes here diff --git a/external/ch-util/bootstrap.cl b/external/ch-util/bootstrap.cl deleted file mode 100644 index aa2b574..0000000 --- a/external/ch-util/bootstrap.cl +++ /dev/null @@ -1,7 +0,0 @@ - -(require 'asdf) - -(asdf:operate 'asdf:load-op 'ch-util) -(asdf:operate 'asdf:load-op 'ch-util-test) - -(ch-util-test:run-tests) \ No newline at end of file diff --git a/external/ch-util/ch-util-test.asd b/external/ch-util/ch-util-test.asd deleted file mode 100644 index 621c030..0000000 --- a/external/ch-util/ch-util-test.asd +++ /dev/null @@ -1,39 +0,0 @@ - -(defpackage #:ch-util-test-system (:use #:asdf #:cl)) -(in-package #:ch-util-test-system) - -;;;; -;;;; The following section customizes asdf to work with filenames -;;;; with a .cl extension and to put fasl files in a separate -;;;; directory. -;;;; -;;;; To enable this behvior, use asdf component type -;;;; :ch-util-test-cl-source-file -;;;; -(defclass ch-util-test-cl-source-file (cl-source-file) ()) - -(defparameter *fasl-directory* - (make-pathname :directory '(:relative #+sbcl "sbcl-fasl" - #+openmcl "openmcl-fasl" - #-(or sbcl openmcl) "fasl"))) - -(defmethod source-file-type ((c ch-util-test-cl-source-file) (s module)) "cl") - -(defmethod asdf::output-files :around ((operation compile-op) (c ch-util-test-cl-source-file)) - (list (merge-pathnames *fasl-directory* (compile-file-pathname (component-pathname c))))) - -(defsystem #:ch-util-test - :name "ch-util-test" - :author "Cyrus Harmon " - :version #.(with-open-file - (vers (merge-pathnames "version.lisp-expr" *load-truename*)) - (read vers)) - :licence "BSD" - :description "Tests for ch-util" - :depends-on (:ch-util) - :components - ((:module :test - :components - ((:ch-util-test-cl-source-file "defpackage") - (:ch-util-test-cl-source-file "test-ch-util" :depends-on ("defpackage")))))) - diff --git a/external/ch-util/ch-util.asd b/external/ch-util/ch-util.asd deleted file mode 100644 index 1eaab64..0000000 --- a/external/ch-util/ch-util.asd +++ /dev/null @@ -1,54 +0,0 @@ - -(defpackage #:ch-util-system (:use #:asdf #:cl)) -(in-package #:ch-util-system) - -;;;; -;;;; The following section customizes asdf to work with filenames -;;;; with a .cl extension and to put fasl files in a separate -;;;; directory. -;;;; -;;;; To enable this behvior, use asdf component type -;;;; :ch-util-cl-source-file -;;;; -(defclass ch-util-cl-source-file (cl-source-file) ()) - -(defparameter *fasl-directory* - (make-pathname :directory '(:relative #+sbcl "sbcl-fasl" - #+openmcl "openmcl-fasl" - #-(or sbcl openmcl) "fasl"))) - -(defmethod source-file-type ((c ch-util-cl-source-file) (s module)) "cl") - -(defmethod asdf::output-files :around ((operation compile-op) (c ch-util-cl-source-file)) - (list (merge-pathnames *fasl-directory* (compile-file-pathname (component-pathname c))))) - -(defsystem #:ch-util - :name "ch-util" - :author "Cyrus Harmon " - :version #.(with-open-file - (vers (merge-pathnames "version.lisp-expr" *load-truename*)) - (read vers)) - :licence "BSD" - :description "Miscellaneous Utility Functions from Cyrus Harmon" - :components - ((:static-file "version" :pathname #p"version.lisp-expr") - (:module :src - :components - ((:ch-util-cl-source-file "defpackage") - (:ch-util-cl-source-file "ch-util" :depends-on ("defpackage")) - (:ch-util-cl-source-file "lists" :depends-on ("defpackage")) - (:ch-util-cl-source-file "macros" :depends-on ("defpackage")) - (:ch-util-cl-source-file "testharness" :depends-on ("defpackage")) - (:ch-util-cl-source-file "hash-table" :depends-on ("defpackage")) - (:ch-util-cl-source-file "array" :depends-on ("defpackage")) - (:ch-util-cl-source-file "sequence" :depends-on ("defpackage")) - (:ch-util-cl-source-file "vector" :depends-on ("defpackage")) - (:ch-util-cl-source-file "bytebuffer" :depends-on ("defpackage")) - (:ch-util-cl-source-file "filesystem" :depends-on ("defpackage")) - (:ch-util-cl-source-file "debug" :depends-on ("defpackage")) - (:ch-util-cl-source-file "ch-asdf" :depends-on ("defpackage" "filesystem")))) - (:static-file "bootstrap" :pathname #p"bootstrap.cl") - (:static-file "COPYRIGHT") - (:static-file "README") - (:static-file "make-dist" :pathname #.(make-pathname :name "make-dist" :type "sh")))) - diff --git a/external/ch-util/make-dist.sh b/external/ch-util/make-dist.sh deleted file mode 100644 index c3c7b23..0000000 --- a/external/ch-util/make-dist.sh +++ /dev/null @@ -1,10 +0,0 @@ -PACKAGE=ch-util -SYSTEMS=":${PACKAGE} :${PACKAGE}-test" - -sbcl --noinform --noprint \ - --eval '(require :asdf)' \ - --eval "(pushnew (make-pathname :directory \""`pwd`"\") asdf:*central-registry*)" \ - --eval "(asdf:operate 'asdf:load-op 'ch-util)" \ - --eval "(asdf:operate 'asdf:load-op 'asdf-package)" \ - --eval "(asdf-package:package-system ${SYSTEMS})" \ - --eval '(quit)' diff --git a/external/ch-util/src/array.cl b/external/ch-util/src/array.cl deleted file mode 100644 index 5d170f7..0000000 --- a/external/ch-util/src/array.cl +++ /dev/null @@ -1,16 +0,0 @@ -;;; -;;; array.cl -- various lisp utilities for vectors -;;; -;;; Author: Cyrus Harmon -;;; - -(in-package :ch-util) - -(defun copy-array (original-array) - "returns a copy of original-array where each element contains -the value in original-arary" - (let ((dim (array-dimensions original-array))) - (let ((flat-array (make-array (reduce #'* dim) :displaced-to original-array))) - (let ((flat-copy (copy-seq flat-array))) - (make-array dim :displaced-to flat-copy))))) - diff --git a/external/ch-util/src/bytebuffer.cl b/external/ch-util/src/bytebuffer.cl deleted file mode 100644 index 4e6b468..0000000 --- a/external/ch-util/src/bytebuffer.cl +++ /dev/null @@ -1,60 +0,0 @@ - -(in-package :ch-util) - -(defclass byte-buffer () - ((storage :accessor storage - :initform (make-array '(256) - :element-type '(unsigned-byte 8) - :fill-pointer 0 - :adjustable t)) - (chunk-size :accessor chunk-size :initform 256))) - -(defun byte-buffer () - (make-instance 'byte-buffer)) - -(defgeneric append-byte (buf byte)) -(defmethod append-byte ((buf byte-buffer) byte) - (let* ((a (storage buf)) - (l (first (array-dimensions a))) - (fp (fill-pointer a))) - (when (= l fp) - (let ((newlen (+ l (chunk-size buf)))) - (adjust-array a (list newlen)))) - (setf (aref a (1- (incf (fill-pointer a)))) byte))) - -(defgeneric print-buffer (buf)) -(defmethod print-buffer ((buf byte-buffer)) - (let* ((a (storage buf)) - (fp (fill-pointer a))) - (dotimes (i fp) - (princ (code-char (aref a i)))))) - -(defun read-file-to-buffer (filename) - (let ((buf (byte-buffer))) - (with-open-file (f filename :element-type '(unsigned-byte 8)) - (do ((b (read-byte f) (read-byte f nil 'eof))) - ((eq b 'eof)) - (append-byte buf b))) - buf)) - -(defun contents-of-stream (in) - "Returns a string with the entire contents of the specified file." - (with-output-to-string (contents) - (let* ((buffer-size 4096) - (buffer (make-string buffer-size))) - (labels ((read-chunks () - (let ((size (read-sequence buffer in))) - (if (< size buffer-size) - (princ (subseq buffer 0 size) contents) - (progn - (princ buffer contents) - (read-chunks)))))) - (read-chunks))))) - -;;; -;;; From lemonodor.com -;;; John Wiseman's blog -;;; -(defun contents-of-file (pathname) - (with-open-file (in pathname :direction :input) - (contents-of-stream in))) diff --git a/external/ch-util/src/ch-asdf.cl b/external/ch-util/src/ch-asdf.cl deleted file mode 100644 index 066ea5a..0000000 --- a/external/ch-util/src/ch-asdf.cl +++ /dev/null @@ -1,87 +0,0 @@ -;;; -;;; ch-asdf.cl -- various lisp utilities that make my life easier -;;; -;;; Author: Cyrus Harmon -;;; Time-stamp: <2006-07-31 14:46:56 sly> -;;; - -(in-package :ch-util) - -(defun pathname-in-parent (path system) - (enough-namestring - path - (truename - (merge-pathnames - (make-pathname :directory `(:relative :up)) - (make-pathname - :directory - (pathname-directory - (asdf:system-definition-pathname system))))))) - -(defun list-module-files (module system) - (cond ((string-equal (symbol-name (class-name (class-of module))) - "tinaa-directory") - (list (pathname-in-parent (asdf:component-pathname module) system))) - (t - (append - (typecase module - (asdf:system (list - (pathname-in-parent - (truename (asdf:system-definition-pathname module)) - system)))) - (mapcan #'(lambda (x) - (typecase x - (asdf:module (list-module-files x system)) - (t (let ((path (asdf:component-pathname x))) - (when path - (list - (pathname-in-parent - path - system))))))) - (asdf:module-components module)))))) - -(defun make-dist (&rest module-keywords) - (let ((modules (mapcar - #'(lambda (k) (asdf:find-system k)) - module-keywords))) - (let ((module (car modules)) - (files-for-dist - (mapcan - #'(lambda (module) - (list-module-files module module)) - modules))) - (with-open-file (gzip-file - (concatenate 'string - (asdf:component-name module) - "-" - (asdf:component-version module) - ".tar.gz") - :if-does-not-exist :create - :if-exists :supersede - :direction :output) - (let ((*default-pathname-defaults* - (truename - (merge-pathnames - (make-pathname :directory '(:relative :up)) - (make-pathname - :directory - (pathname-directory - (asdf:system-definition-pathname module))))))) - (with-current-directory *default-pathname-defaults* - (ch-util:run-program - "/usr/bin/gzip" - '("-c") - :input (ch-util:process-output-stream - (ch-util:run-program - "/usr/bin/tar" - (append - '("-cf" "-") - (print files-for-dist)) - :wait nil - :output :stream - :error #p"/dev/null" - :if-error-exists :append)) - :output gzip-file))))))) - -(defun unregister-system (name) - (remhash name asdf::*defined-systems*)) diff --git a/external/ch-util/src/ch-util.cl b/external/ch-util/src/ch-util.cl deleted file mode 100644 index adc92e3..0000000 --- a/external/ch-util/src/ch-util.cl +++ /dev/null @@ -1,248 +0,0 @@ -;;; -;;; ch-util.cl -- various lisp utilities that make my life easier -;;; -;;; Author: Cyrus Harmon -;;; - -(in-package :ch-util) - -;;; Miscellaneous list utilities - -(flet ((cca (l1 l2) - (dolist (x l1) - (let ((y (member x l2))) - (if y (return y)))))) - (defun closest-common-ancestor (itm &rest lis) - (if (null lis) - itm - (cca itm (apply #'closest-common-ancestor lis))))) - -;;; Miscellaneous class utilities - -(defun subclassp (c1 c2) - (subtypep (class-name c1) (class-name c2))) - -;;; Miscellaneous string utilities - -(defun strcat (&rest strs) - (apply #'concatenate 'string strs)) - -(defun trim (seq suffix) - (subseq seq 0 (search suffix seq))) - -;;; This is a hack so that one day we might run under a case-sensitive lisp -;;; like Allegro mlisp (modern lisp). For now we encapsulate the uppercasing -;;; here so we can do the right thing later. -(defun interncase (x) - (string-upcase x)) - -;;; simple wrapper for intern to allow us -(defun make-intern (x &optional (package *package*)) - (intern (interncase x) package)) - -(defun make-keyword (x) - (make-intern x 'keyword)) - -(defun keywordicate (x) - (cond ((keywordp x) x) - (t (make-keyword x)))) - -(defun keyword-list-names (k) - (mapcar #'(lambda (x) - (symbol-name x)) - k)) - -(defun double-float-divide (&rest args) - (apply #'/ (mapcar #'(lambda (x) (coerce x 'double-float)) args))) - -(defun single-float-divide (&rest args) - (apply #'/ (mapcar #'(lambda (x) (coerce x 'single-float)) args))) - -(defmacro mapv (function &rest vals) - `(values-list (mapcar ,function (multiple-value-list ,@vals)))) - -;; -;; Silly little macro to do a postincrement, that is -;; return the value of the place prior to incrementing -;; it. Like incf, this only works on valid places. -;; -(defmacro postincf (x &optional (step 1)) - (let ((pre (gensym))) - `(let ((,pre ,x)) - (incf ,x ,step) - ,pre))) - -;; another silly little function. -;; this one to sum a 2d array. -;; undoubtedly a better way to do this. -(defun array-sum (a) - (destructuring-bind (height width) (array-dimensions a) - (let ((acc 0)) - (dotimes (h height) - (dotimes (w width) - (incf acc (aref a h w)))) - acc))) - -(defun array-from-string (str) - (let ((a (make-array (length str) :element-type '(unsigned-byte 8)))) - (dotimes (i (length str)) - (setf (aref a i) (char-code (elt str i)))) - a)) - -(defun str-to-int (str) - (let ((intval 0)) - (map nil #'(lambda (c) (setf intval (+ (ash intval 8) (char-code c)))) str) - intval)) - -(defun int-to-str (i &optional s) - (if (> i 0) - (let ((r (mod i 256))) - (int-to-str (ash i -8) (cons (code-char r) s))) - (coerce s 'string))) - - -(defparameter *months* - '((1 . "January") - (2 . "February") - (3 . "March") - (4 . "April") - (5 . "May") - (6 . "June") - (7 . "July") - (8 . "August") - (9 . "September") - (10 . "October") - (11 . "November") - (12 . "December"))) - -(defun get-current-date () - (multiple-value-bind (sec min hour date mon year dow dst tz) - (get-decoded-time) - (declare (ignore sec min hour dow dst tz)) - (format nil - "~A ~A, ~A" - (cdr (assoc mon *months*)) - date - year))) - -(defun find-nth-zero (vector n) - "finds the nth zero in a vector." - (loop for i below (length vector) - with count = 0 - with rem = n - while (<= count n) - do (when (zerop (aref vector i)) - (incf count) - (decf rem)) - finally (return (when (minusp rem) - (1- i))))) - -(defun generate-random-permutation (n &key (length n)) - "returns a random permutation of length length of the -integers from 0 to n-1." - (let ((a (make-array n))) - (let ((randlist - (loop for i from n downto (1+ (- n length)) - collect - (let ((k (random i))) - (let ((n (find-nth-zero a k))) - (setf (aref a n) 1) - n))))) - randlist))) - -;;; this doesn't work yet! -#+nil -(defun robust-mean (vector-or-list) - (flet ((square (a) (* a a))) - (let ((v (cond ((vectorp vector-or-list) vector-or-list) - ((listp vector-or-list (coerce vector-or-list 'vector)))))) - (when v - (let ((n (length v)) - (b 1) - (s1 (elt v 0)) - (s2 (square (elt v 0)))) - (loop for a below n - do )))))) - -(defun median (seq) - (let ((v (cond ((vectorp seq) (copy-seq seq)) - ((listp seq) (coerce seq 'vector))))) - (when (and v (plusp (length v))) - (sort v #'<) - (let ((f (floor (length v) 2))) - (cond ((oddp (length v)) - (elt v f)) - (t - (/ (+ (elt v (1- f)) - (elt v f)) - 2))))))) - -(defun mean (seq) - (let ((v (cond ((vectorp seq) (copy-seq seq)) - ((listp seq) (coerce seq 'vector))))) - (when (and v (plusp (length v))) - (/ (reduce #'+ v) - (length v))))) - -(defun variance (seq) - (flet ((square (x) - (* x x))) - (let* ((v (cond ((vectorp seq) (copy-seq seq)) - ((listp seq) (coerce seq 'vector)))) - (n (length v))) - (when (and v (plusp n)) - (let ((msq (square (mean seq)))) - (/ (reduce #'+ (mapcar #'(lambda (x) - (- (square x) msq)) - seq)) - (1- n))))))) - -(defun square-seq (seq) - (flet ((square (x) - (* x x))) - (let ((v (cond ((vectorp seq) (copy-seq seq)) - ((listp seq) (coerce seq 'vector))))) - (when (and v (plusp (length v))) - (mapcar #'square seq))))) - -(defun remove-keywordish-args (keywords &rest args) - (let ((keys)) - (let ((non-keys - (loop for (x y) on args - with skip = nil - append (if skip - (setf skip nil) - (if (member x keywords) - (progn - (setf skip t) - (pushnew (cons x y) keys) - nil) - (list x)))))) - (list (mapcan #'(lambda (x) - (list (car x) (cdr x))) - (nreverse keys)) - non-keys)))) - -(defun keyword-arg-name (key) - (cond ((atom key) key) - ((listp key) (car key)))) - -(defmacro with-keyword-args (((&rest args) rest) list &body body) - `(destructuring-bind ((&key ,@args) (&rest ,rest)) - (apply #'remove-keywordish-args - (mapcar #'keywordicate - (mapcar #'keyword-arg-name - ',args)) - ,list) - ,@body)) - -(defun sort-copy (seq pred &key key) - (apply #'sort (copy-seq seq) pred - (when key `(:key ,key)))) - -(defun iota (n) - (labels ((%iota (n) - (when (plusp n) - (cons n (%iota (1- n)))))) - (nreverse (%iota n)))) - diff --git a/external/ch-util/src/debug.cl b/external/ch-util/src/debug.cl deleted file mode 100644 index 88b4f1c..0000000 --- a/external/ch-util/src/debug.cl +++ /dev/null @@ -1,63 +0,0 @@ - - -(in-package :ch-util) - -(defun hex-dump-word (address) - #+sbcl - (format nil "~8,'0X" - (sb-alien:deref - (sb-alien:sap-alien - (sb-alien::int-sap address) - (* (sb-alien:unsigned 32))))) - #-sbcl - (format "not yet implemented!")) - -(defun hex-dump-byte (address) - #+sbcl - (format nil "~2,'0X" - (sb-alien:deref - (sb-alien:sap-alien - (sb-alien::int-sap address) - (* (sb-alien:unsigned 8))))) - #-sbcl - (format "not yet implemented!")) - -(defun hex-dump-memory (start-address length) - (loop for i from start-address below (+ start-address length) - collect (format nil (hex-dump-byte i)))) - -(defun hex-dump-words (start-address length) - (loop for i from start-address below (+ start-address length) by 4 - collect (format nil (hex-dump-word i)))) - -(defun hex-dump-long (address) - (hex-dump-memory address 4)) - -(defun char-dump-byte (address) - #+sbcl - (format nil "~A" - (code-char - (sb-alien:deref - (sb-alien:sap-alien - (sb-alien::int-sap address) - (* (sb-alien:unsigned 8)))))) - #-sbcl - (format nil "not yet implemented")) - -(defun char-dump-memory (start-address length) - (loop for i from start-address below (+ start-address length) - collect (format nil (char-dump-byte i)))) - -(defun double-at-address (address) - (sb-alien:deref - (sb-alien:sap-alien - (sb-alien::int-sap address) - (* (sb-alien:double-float))))) - -(defun double-dump-memory (start-address length) - (let ((size (sb-alien:alien-size sb-alien:double-float :bytes))) - (loop for i from start-address - below (+ start-address (* length size)) - by size - collect (cons (format nil "~X" i) - (double-at-address i))))) diff --git a/external/ch-util/src/defpackage.cl b/external/ch-util/src/defpackage.cl deleted file mode 100644 index f07a1f7..0000000 --- a/external/ch-util/src/defpackage.cl +++ /dev/null @@ -1,84 +0,0 @@ - -(in-package #:cl-user) - -(defpackage #:ch-util - (:use #:cl #:asdf) - (:export #:get-fasl-directory - - #:insert-before - #:insert-before-all - #:closest-common-ancestor - - #:subclassp - - #:strcat - #:trim - - #:str-to-int - #:int-to-str - - #:find-nth-zero - #:generate-random-permutation - - #:get-current-date - - #:time-to-string - - #:double-float-divide - #:single-float-divide - - #:defun-export - #:defparameter-export - #:defclass-export - #:defmethod-export - - #:postincf - #:array-sum - - #:interncase - #:make-intern - #:make-keyword - #:keyword-list-names - #:byte-buffer - #:read-file-to-buffer - #:print-buffer - #:make-test-run - #:test-run-tests - #:test-run-passed - #:run-test - - #:pathname-as-directory - #:pwd - #:ls - #:with-open-file-preserving-case - #:contents-of-file - - #:prefix - #:subdirectories - #:list-directory - - #:unix-name - - #:make-dist - #:unregister-system - - #:run-program - #:process-output-stream - - #:make-hash-table-from-plist - #:make-hash-table-from-alist - - ;; array.cl functions - #:copy-array - - ;; sequence.cl - #:max-length - #:seqmin - #:seqmax - - ;; vector.cl - #:map-vector - - #:pdf-open - #:html-open)) - diff --git a/external/ch-util/src/filesystem.cl b/external/ch-util/src/filesystem.cl deleted file mode 100644 index 5e270c2..0000000 --- a/external/ch-util/src/filesystem.cl +++ /dev/null @@ -1,199 +0,0 @@ -;;; -;;; filesystem.cl -- various lisp utilities that make my life easier -;;; -;;; Author: Cyrus Harmon -;;; - -(in-package :ch-util) - -#+sbcl -(eval-when (:compile-toplevel :load-toplevel :execute) - (require :sb-posix)) - -#+openmcl -(defun pwd () - (ccl::current-directory-name)) - -(defun component-present-p (value) - (and value (not (eql value :unspecific)))) - -;;; I don't remember where I got this from. Probably from KMR somewhere -;;; along the line... -(defun pathname-as-directory (pathname) - "Return a pathname reperesenting the given pathname in `directory - form', i.e. with all the name elements in the directory component and - NIL in the name and type components. Can not be used on wild - pathnames. Returns its argument if name and type are both nil or - :unspecific." - (setf pathname (pathname pathname)) - (when (wild-pathname-p pathname) - (error "Can't reliably convert wild pathnames to directory names.")) - (cond - ((or (component-present-p (pathname-name pathname)) - (component-present-p (pathname-type pathname))) - (make-pathname - :directory (append (pathname-directory pathname) (list - (file-namestring pathname))) - :name nil - :type nil - :defaults pathname)) - (t pathname))) - -;;; I don't remember where I got this from. Probably from KMR somewhere -;;; along the line... -(defun list-directory (dirname) - "Return a list of the contents of the directory named by dirname. - Names of subdirectories will be returned in `directory normal form'. - Unlike CL:DIRECTORY, LIST-DIRECTORY does not accept wildcard - pathnames; `dirname' should simply be a pathname that names a - directory. It can be in either file or directory form." - (let ((wildcard (make-pathname :name :wild - :type :wild - :defaults (pathname-as-directory - dirname)))) - - (declare (ignorable wildcard)) - #+openmcl - ;; OpenMCl by default doesn't return subdirectories at all. But - ;; when prodded to do so with the special argument :directories, - ;; it returns them in directory form. - (directory wildcard :directories t) - #-openmcl (directory wildcard))) - -(defun ls (&optional (dirname "")) - (list-directory dirname)) - -(defmacro with-open-file-preserving-case (&rest args) - `(let ((*readtable* (copy-readtable))) - (setf (readtable-case *readtable*) :preserve) - (with-open-file ,@args))) - -(defparameter *tmp-file-directory* (make-pathname :directory '(:absolute "tmp"))) - -(defun tmp-file-name (&key (prefix "tmp.")) - (concatenate 'string prefix (format nil "~8,'0',X" (random #xffffffff)))) - -(defun tmp-file (&key (name (tmp-file-name))) - (merge-pathnames name *tmp-file-directory*)) - -(defun remove-keyword-args (list &rest remove) - (loop for x on list by #'cddr when (not (member (car x) remove)) append (list (car x) (cadr x)))) - -(defmacro with-temporary-file ((path stream &rest options &key (delete t) &allow-other-keys) &body body) - `(let ((,path (tmp-file))) - (prog1 - (with-open-file (,stream ,path ,@(remove-keyword-args options :delete)) - ,@body) - ,(when delete `(delete-file ,path))))) - -;;; from antifuchs on #lisp via paste.lisp.org -;;; http://paste.lisp.org/display/9527 -(defmacro with-current-directory (dir &body body) - `(unwind-protect (progn - #+sbcl - (sb-posix:chdir ,dir) - (let ((*default-pathname-defaults* ,dir)) - ,@body)) - #+sbcl (sb-posix:chdir *default-pathname-defaults*))) - -(defmacro run-program (&rest args) - #+sbcl `(sb-ext::run-program ,@args)) - -(defmacro run-program-asynchronously (&rest args) - #+sbcl `(sb-ext::run-program ,@args :wait nil)) - - -(defun app-open (&rest args) - #+darwin (run-program "/usr/bin/open" (mapcar #'(lambda (x) (if (pathnamep x) (unix-name x) x)) args))) - -(defun safari-open (&rest args) - #+darwin - (apply #'app-open (list* "-a" "/Applications/Safari.app" - (mapcar #'(lambda (x) (if (pathnamep x) (unix-name x) x)) args)))) - -(defun firefox-open (&rest args) - #+darwin - (apply #'app-open (list* "-a" "/Users/sly/Applications/Camino.app" - (mapcar #'(lambda (x) (if (pathnamep x) (unix-name x) x)) args)))) - - -(defparameter *pdf-viewer* - #+linux "kpdf" - #+darwin "Preview.app") - -(defparameter *pdf-viewer-path* - (let ((found (sb-ext:find-executable-in-search-path - *pdf-viewer*))) - (unless found - (setf found - #+darwin "/Applications/Preview.app" - #-darwin "/usr/bin/kpdf")) - found)) - -(defun pdf-open (&rest args) - #+darwin - (apply #'app-open "-a" *pdf-viewer-path* (mapcar #'unix-name args)) - #-darwin - (run-program-asynchronously *pdf-viewer-path* - (mapcar #'(lambda (x) - (if (pathnamep x) (unix-name x) x)) args)) - ) - -(defparameter *html-viewer* - #+linux "konqueror" - #+darwin "Safari.app") - -(defparameter *html-viewer-path* - (let ((found (sb-ext:find-executable-in-search-path - *html-viewer*))) - (unless found - (setf found - #+darwin "/Applications/Safari.app" - #-darwin "/usr/bin/konqueror")) - found)) - -(defun html-open (&rest args) - (run-program-asynchronously *html-viewer-path* - (mapcar #'(lambda (x) - (if (pathnamep x) (unix-name x) x)) args))) - -(defmacro process-output-stream (&rest args) - #+sbcl `(sb-ext::process-output ,@args)) - -(defun prefix (seq suffix) - "Removes the prefix of seq that occurs before suffix. Return - values are the prefix and the position at which the suffix - begins in the original sequence, or the original sequence and - NIL if the suffix is not in seq" - (let ((pos (search suffix seq))) - (if pos - (values (subseq seq 0 pos) pos) - (values seq nil)))) - -(defun subdirectories (path) - (loop for d in - (directory - (make-pathname :name :wild :type nil :defaults path)) - when (string-equal (file-namestring d) "") collect d)) - -(defun unix-name (pathname) - (namestring - (typecase pathname - (logical-pathname (translate-logical-pathname pathname)) - (t pathname)))) - -(defun map-files-in-directory (function - destination-directory - &key file-type) - (mapcar function - (directory - (merge-pathnames - (make-pathname - :name :wild - :type (if file-type file-type :wild)) - destination-directory)))) - -(defun pathname-lessp (p1 p2) - (string-lessp (pathname-name p1) - (pathname-name p2))) - diff --git a/external/ch-util/src/hash-table.cl b/external/ch-util/src/hash-table.cl deleted file mode 100644 index 8e884b3..0000000 --- a/external/ch-util/src/hash-table.cl +++ /dev/null @@ -1,60 +0,0 @@ -;;; -;;; hash-table.cl -- various lisp utilities for hash-tables -;;; -;;; Author: Cyrus Harmon -;;; - -(in-package :ch-util) - -;;; Miscellaneous hash-table utilities - -(defun make-hash-table-from-plist (plist &key (test #'eql)) - (let ((h (make-hash-table :test test))) - (loop for (x y) on plist by #'cddr - do (setf (gethash x h) y)) - h)) - -(defun make-hash-table-from-alist (alist &key (test #'eql)) - (let ((h (make-hash-table :test test))) - (loop for (x . y) in alist - do (setf (gethash x h) y)) - h)) - -(defun hash-table-to-plist (h &aux l) - (if (hash-table-p h) - (progn (maphash - #'(lambda (key val) - (setf l (cons (hash-table-to-plist val) - (cons key l)))) h) - (nreverse l)) - h)) - -(defun hash-ref (h &rest keys) - (reduce #'(lambda (h k) (gethash k h)) keys :initial-value h)) - -(defun %put-hash-ref (new-value h key &rest more-keys) - ;; not quite Perl-style autovivification, but we do create - ;; appropriate list structure for intermediate keys that can't be found - (unless (hash-table-p h) (setf h (make-hash-table :test 'equal))) - (let* ((sub (gethash key h)) - (val (if more-keys - (apply #'%put-hash-ref new-value sub more-keys) - new-value))) - (progn (setf (gethash key h) val) h))) - -(define-setf-expander hash-ref (place &rest props - &environment env) - ;; %put-ref may cons new structure or mutate its argument. - ;; all this magic is just so that we can - ;; (let ((l nil)) (setf (ref l :foo :bar) t)) - (multiple-value-bind (temps values stores set get) - (get-setf-expansion place env) - (let ((newval (gensym)) - (ptemps (loop for i in props collect (gensym)))) - (values `(,@temps ,@ptemps ) - `(,@values ,@props ) - `(,newval) - `(let ((,(car stores) (%put-hash-ref ,newval ,get ,@ptemps))) - ,set - ,newval) - `(hash-ref ,get ,@ptemps))))) diff --git a/external/ch-util/src/lists.cl b/external/ch-util/src/lists.cl deleted file mode 100644 index dab0f82..0000000 --- a/external/ch-util/src/lists.cl +++ /dev/null @@ -1,47 +0,0 @@ -;;; -;;; lists.cl -- various lisp list utilities that make my life easier -;;; -;;; Author: Cyrus Harmon -;;; - -(in-package :ch-util) - -;;; Miscellaneous list utilities - -(defun insert-before (new old list) - (labels ((build-list (old c &optional newlist) - (if c - (if (eq old (car c)) - (append (reverse (cdr c)) (cons (car c) (cons new newlist))) - (build-list old (cdr c) (cons (car c) newlist))) - (cons new newlist)))) - (reverse (build-list old list)))) - -(defun insert-before-all (new old list) - (labels ((build-list (old c &optional newlist) - (if c - (if (eq old (car c)) - (build-list old (cdr c) (cons (car c) (cons new newlist))) - (build-list old (cdr c) (cons (car c) newlist))) - newlist))) - (reverse (build-list old list)))) - -(defun flatten (l) - (mapcan #'(lambda (x) - (cond ((null x) nil) - ((atom x) (list x)) - (t (flatten x)))) - l)) - -(defun properties (plist) - "Returns a list of the names properties present in plist, but -not the value of the properties." - (loop for prop in plist by #'cddr collect prop)) - -(defun remove-nulls (list) - (loop for l in list append (when l (list l)))) - -(defun ensure-list (l) - (cond ((listp l) l) - ((atom l) (list l)))) - diff --git a/external/ch-util/src/macros.cl b/external/ch-util/src/macros.cl deleted file mode 100644 index af211a3..0000000 --- a/external/ch-util/src/macros.cl +++ /dev/null @@ -1,37 +0,0 @@ -;;; -;;; macros.cl -- macro writing macros -;;; -;;; Author: Cyrus Harmon -;;; - -(in-package :ch-util) - -;;; this is taken from Peter Seibel's Practical Common Lisp -;;; book, p. 102 -(defmacro once-only ((&rest names) &body body) - (let ((gensyms (loop for n in names collect (gensym)))) - `(let (,@(loop for g in gensyms collect `(,g (gensym)))) - `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n))) - ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g))) - ,@body))))) - -;; -;; Reference implementation of with-unique-names from cliki -;; -(defmacro with-unique-names ((&rest bindings) &body body) - `(let ,(mapcar #'(lambda (binding) - (destructuring-bind (var prefix) - (if (consp binding) binding (list binding binding)) - `(,var (gensym ,(string prefix))))) - bindings) - ,@body)) - -(defmacro time-to-string (&body body) - (let ((strstr (gensym)) - (time-string (make-array '(0) :element-type 'character - :fill-pointer 0 :adjustable t))) - `(with-output-to-string (,strstr ,time-string) - (let ((*trace-output* ,strstr)) - (time ,@body)) - ,time-string))) - diff --git a/external/ch-util/src/sequence.cl b/external/ch-util/src/sequence.cl deleted file mode 100644 index 7e6c2c1..0000000 --- a/external/ch-util/src/sequence.cl +++ /dev/null @@ -1,18 +0,0 @@ -;;; -;;; vector.cl -- various lisp utilities for sequences -;;; -;;; Author: Cyrus Harmon -;;; - -(in-package :ch-util) - -(defun max-length (&rest seqs) - (apply #'max (mapcar #'length seqs))) - -(defun seqmin (seq &key key) - (car (apply #'sort (copy-seq seq) #'< - (when key `(:key ,key))))) - -(defun seqmax (seq &key key) - (car (apply #'sort (copy-seq seq) #'> - (when key `(:key ,key))))) diff --git a/external/ch-util/src/testharness.cl b/external/ch-util/src/testharness.cl deleted file mode 100644 index 623aeed..0000000 --- a/external/ch-util/src/testharness.cl +++ /dev/null @@ -1,26 +0,0 @@ -;;; -;;; testharness.cl -- various lisp utilities for hash-tables -;;; -;;; Author: Cyrus Harmon -;;; Time-stamp: <2005-07-01 08:11:52 sly> -;;; - -(in-package :ch-util) - -(defparameter *verbose-test-results* nil) - -(defstruct test-run - (tests 0) - (passed 0)) - -(defun run-test (f test-name run) - (if (funcall f) - (progn - (when *verbose-test-results* - (format t "~&Test ~A Succeeded" test-name)) - (incf (test-run-passed run)) - (incf (test-run-tests run))) - (progn - (format t "~&Test ~A Failed!" test-name) - (incf (test-run-tests run))))) - diff --git a/external/ch-util/src/vector.cl b/external/ch-util/src/vector.cl deleted file mode 100644 index 2de0766..0000000 --- a/external/ch-util/src/vector.cl +++ /dev/null @@ -1,20 +0,0 @@ -;;; -;;; vector.cl -- various lisp utilities for vectors -;;; -;;; Author: Cyrus Harmon -;;; - -(in-package :ch-util) - -;;; Miscellaneous vector utilities - -(defun map-vector (fn v - &key - (adjustable t) - (fill-pointer 0)) - (let* ((n (length v)) - (a (make-array n - :adjustable adjustable - :fill-pointer fill-pointer))) - (map-into a fn v))) - diff --git a/external/ch-util/test/defpackage.cl b/external/ch-util/test/defpackage.cl deleted file mode 100644 index dcfbb46..0000000 --- a/external/ch-util/test/defpackage.cl +++ /dev/null @@ -1,10 +0,0 @@ - -(in-package #:cl-user) - -(defpackage #:ch-util-test - (:use #:cl #:asdf #:ch-util) - (:shadowing-import-from #:ch-util) - (:export #:run-tests - )) - -(in-package #:ch-util-test) diff --git a/external/ch-util/test/test-ch-util.cl b/external/ch-util/test/test-ch-util.cl deleted file mode 100644 index 9de5b22..0000000 --- a/external/ch-util/test/test-ch-util.cl +++ /dev/null @@ -1,37 +0,0 @@ - -(in-package #:ch-util-test) - -(defun test-strcat () - (let ((s1 (strcat "this is " "a test"))) - (equal s1 "this is a test"))) - -(defun test-interncase () - (let ((s1 (interncase "testINGinternCase"))) - (format t "~&~A" s1) - t)) - -(defun test-print-buffer () - (print-buffer (read-file-to-buffer "/etc/motd")) - t) - -(defun test-postincf () - (let ((moose 3)) - (print moose) - (print (postincf moose)) - (print moose) - (print (postincf moose 2)) - (print moose) - )) - -(defun run-tests () - (let ((run (make-test-run))) - (run-test #'test-strcat "test-strcat" run) - (run-test #'test-print-buffer "test-print-buffer" run) - (run-test #'test-interncase "test-interncase" run) - (run-test #'test-postincf "test-postincf" run) - (format t "~&~A of ~A tests passed" (test-run-passed run) (test-run-tests run)) - )) - -;;; Lisp one liners: - -; (let ((gstring (with-output-to-string (gstream) (run-program "ls" nil :output gstream)))) (print gstring)) diff --git a/external/ch-util/version.lisp-expr b/external/ch-util/version.lisp-expr deleted file mode 100644 index 92195dc..0000000 --- a/external/ch-util/version.lisp-expr +++ /dev/null @@ -1 +0,0 @@ -"0.2.2" -- 2.11.4.GIT