Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Initial commit

  • Loading branch information...
commit ca9ad1fa81b037e18f979b282267de8dd2911322 0 parents
m2ym authored
5 .gitignore
@@ -0,0 +1,5 @@
+*.fasl
+*.dx64fsl
+*.dx32fsl
+*.lx64fsl
+*.x86f
18 cl-more-types.asd
@@ -0,0 +1,18 @@
+(in-package :cl-user)
+
+(defpackage :cl-more-types-asd
+ (:use :cl :asdf))
+(in-package :cl-more-types-asd)
+
+(defsystem :cl-more-types
+ :version "0.1"
+ :author "Tomohiro Matsuyama"
+ :license "LLGPL"
+ :components ((:module "src"
+ :serial t
+ :components ((:file "packages")
+ (:file "specials")
+ (:file "combinators")
+ (:file "streams")
+ (:file "lists")
+ (:file "designators")))))
6 src/combinators.lisp
@@ -0,0 +1,6 @@
+(in-package :cl-more-types)
+
+(deftype non-nil (&optional type)
+ (if type
+ `(and (not null) ,type)
+ '(not null)))
35 src/designators.lisp
@@ -0,0 +1,35 @@
+(in-package :cl-more-types)
+
+(deftype character-designator ()
+ '(or (string 1)
+ character))
+
+(deftype function-designator ()
+ '(or symbol
+ function))
+
+(deftype file-position-designator ()
+ '(or (member :start :end)
+ (integer 0)))
+
+(deftype list-designator ()
+ '(or (non-nil atom)
+ proper-list))
+
+(deftype package-designator ()
+ '(or string-designator
+ package))
+
+(deftype pathname-designator ()
+ '(or string
+ file-associated-stream
+ pathname))
+
+(deftype stream-designator ()
+ '(or (member t nil)
+ stream))
+
+(deftype string-designator ()
+ '(or character
+ symbol
+ string))
61 src/lists.lisp
@@ -0,0 +1,61 @@
+(in-package :cl-more-types)
+
+(declaim (inline proper-list-p
+ property-list-p
+ association-list-p
+ tuplep))
+
+(defmacro %proper-list-p (var &optional (element-type '*))
+ `(loop
+ (typecase ,var
+ (null (return t))
+ (cons (if (or ,(eq element-type '*)
+ (typep (car ,var) ,element-type))
+ (setq ,var (cdr ,var))
+ (return)))
+ (t (return)))))
+
+(defun proper-list-p (object)
+ (declare (optimize . #.*standard-optimize-qualities*))
+ (%proper-list-p object))
+
+(deftype proper-list (&optional (element-type '*))
+ (declare (ignore element-type))
+ '(and list (satisfies proper-list-p)))
+
+(defun property-list-p (object)
+ (declare (optimize . #.*standard-optimize-qualities*))
+ (typecase object
+ (null t)
+ (cons
+ (loop
+ (if (null object)
+ (return t)
+ (let ((key (car object))
+ (next (cdr object)))
+ (if (or (not (keywordp key))
+ (not (consp next)))
+ (return)
+ (setq object (cdr next)))))))))
+
+(deftype property-list (&optional (value-type '*))
+ (declare (ignore value-type))
+ '(and list (satisfies property-list-p)))
+
+(defun association-list-p (var)
+ (declare (optimize . #.*standard-optimize-qualities*))
+ (%proper-list-p var 'cons))
+
+(deftype association-list (&optional (key-type '*) (value-type '*))
+ `(proper-list (cons ,key-type ,value-type)))
+
+(defun tuplep (object)
+ (declare (optimize . #.*standard-optimize-qualities*))
+ (%proper-list-p object))
+
+(deftype tuple (&rest element-types)
+ `(and list
+ ,(reduce (lambda (element-type type) `(cons ,element-type ,type))
+ element-types
+ :from-end t
+ :initial-value 'null)))
28 src/packages.lisp
@@ -0,0 +1,28 @@
+(in-package :cl-user)
+
+(defpackage :cl-more-types
+ (:nicknames :more-types)
+ (:use :cl)
+ (:export ;; combinators.lisp
+ #:non-nil
+ ;; streams.lisp
+ #:file-associated-stream-p
+ #:file-associated-stream
+ ;; lists.lisp
+ #:proper-list-p
+ #:proper-list
+ #:property-list-p
+ #:property-list
+ #:association-list-p
+ #:association-list
+ #:tuplep
+ #:tuple
+ ;; designators.lisp
+ #:character-designator
+ #:function-designator
+ #:file-position-designator
+ #:list-designator
+ #:package-designator
+ #:pathname-designator
+ #:stream-designator
+ #:string-designator))
8 src/specials.lisp
@@ -0,0 +1,8 @@
+(in-package :cl-more-types)
+
+(defvar *standard-optimize-qualities*
+ '((speed 3)
+ (safety 0)
+ (space 0)
+ (debug 1)
+ (compilation-speed 0)))
14 src/streams.lisp
@@ -0,0 +1,14 @@
+(in-package :cl-more-types)
+
+(defun file-associated-stream-p (stream)
+ (declare (optimize . #.*standard-optimize-qualities*))
+ (or (typep stream 'file-stream)
+ (and (typep stream 'synonym-stream)
+ (let* ((target-symbol (synonym-stream-symbol stream))
+ (target-stream (symbol-value target-symbol)))
+ (declare (type symbol target-symbol)
+ (type stream target-stream))
+ (file-associated-stream-p target-stream)))))
+
+(deftype file-associated-stream ()
+ '(and stream (satisfies file-associated-stream-p)))
Please sign in to comment.
Something went wrong with that request. Please try again.