Skip to content

Commit

Permalink
feature branch/head merged
Browse files Browse the repository at this point in the history
  • Loading branch information
Dan Lentz committed Jun 11, 2013
1 parent e75ac7f commit 912908e
Show file tree
Hide file tree
Showing 17 changed files with 1,424 additions and 2,015 deletions.
30 changes: 23 additions & 7 deletions cl-ctrie.asd
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,11 @@

(in-package :cl-user)

#+()
(eval-when (:load-toplevel :execute)
(asdf:operate 'asdf:load-op :cffi-grovel)
(asdf:operate 'asdf:load-op :cffi-objects))


(asdf:defsystem :cl-ctrie
:serial t
Expand Down Expand Up @@ -69,18 +74,23 @@
this is not necessarily a high priority for the initial development
cycle."

:weakly-depends-on (:cldoc)
:depends-on (:closer-mop :contextl :alexandria :unicly ;:local-time :userial
:cl-ppcre :uuid :flexi-streams :osicat :iterate :cl-irregsexp
:hu.dwim.stefil :hu.dwim.serializer :cl-store :rucksack)
;; :weakly-depends-on (:cldoc)
:depends-on (:closer-mop :contextl :alexandria :printv :cldoc :unicly :uuid
:com.informatimago.common-lisp.heap :cl-ppcre :osicat
:iterate :cl-irregsexp :hu.dwim.stefil :hu.dwim.serializer
:cl-store)

:components ((:static-file "cl-ctrie.asd")
(:static-file "readme.md")
(:file "common-readtable")
(:file "common-macro")
; (:file "common-condition")
(:file "common-ord")
(:file "common-io")
(:file "common-pointer")
; (:file "common-tty")
; (:file "common-diff")
; (:file "common-stream")
(:file "common-array")
(:file "common-instance")
(:file "common-vm")
Expand All @@ -97,18 +107,22 @@
(:file "mmap-storage")
(:file "mmap-string")
(:file "mmap-mcons")
(:file "mmap-gc")
(:file "mmap-gc")
(:file "ctrie-package")
(:file "ctrie-special")
(:file "ctrie-conditions")
(:file "ctrie-cas")
(:file "ctrie-util")
(:file "ctrie-codec")
(:file "ctrie-store")
(:file "ctrie-pool")
(:file "ctrie-layers")
(:file "ctrie-protocol")
(:file "ctrie")
(:file "ctrie-lambda")
;; (:file "ctrie-lambda")
(:file "cvm-package")
(:file "cvm-memory")
(:file "cvm-host")
(:file "cvm-ctrie")
#+cldoc (:file "ctrie-doc")
(:file "tree-package")
(:file "tree-node")
Expand All @@ -119,6 +133,7 @@




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PACKAGING
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Expand Down Expand Up @@ -207,3 +222,4 @@
nil)



97 changes: 56 additions & 41 deletions common-instance.lisp
View file
Original file line number Diff line number Diff line change
@@ -1,9 +1,11 @@
;;;;; -*- mode: common-lisp; common-lisp-style: modern; coding: utf-8; -*-
;;;;;

(defpackage :object
(:nicknames :obj)
(:use :closer-common-lisp :c2mop :alexandria)
(:export :proto
:fc
:find-class*
:finalized-class
:new
:slot-value*
Expand All @@ -24,17 +26,22 @@
:serializable-slots
:serializable-slots-using-class
:find-direct-slot-definition-by-initarg
:subclasses
:superclasses
:class-subclasses
:class-superclasses
:class-slot-names
:clone-instance
:cloned-object-as
:cloned-object
:copy-instance
:make-uninitialized-instance))
:make-uninitialized-instance
:unparse-direct-slot-definition
:class-add-slot))

(in-package :object)

(unless (find-package :mop)
(rename-package (package-name :c2mop) (package-name :c2mop) '(:mop :c2mop)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; CLOS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Expand All @@ -43,15 +50,14 @@
(defvar *nuke-existing-classes* nil)
(defvar *store-class-superclasses* t)

(defun fc (class-designator)
(defun find-class* (class-designator)
(typecase class-designator
(class class-designator)
(keyword (fc (string class-designator)))
(string (fc (read-from-string class-designator)))
(keyword (find-class* (string class-designator)))
(string (find-class* (read-from-string class-designator)))
(symbol (find-class class-designator))
(t (find-class class-designator))))


(defun proto (thing)
(flet ((get-proto (c)
(let ((cc (find-class c)))
Expand All @@ -62,21 +68,17 @@
(standard-object (get-proto (class-of thing)))
(symbol (get-proto thing)))))


(defun finalized-class (class-designator)
(finalize-inheritance (fc class-designator))
(fc class-designator))

(finalize-inheritance (find-class* class-designator))
(find-class* class-designator))

(defun new (&rest args)
(apply #'make-instance args))


(defun slot-value* (obj slot &optional (unbound-return :unbound))
(handler-case (values (slot-value obj slot) t)
(unbound-slot (c) (values unbound-return c))))


(defun required-arg (name)
(error "~S is a required argument" name))

Expand All @@ -85,6 +87,25 @@
;; MOP
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun unparse-direct-slot-definition (slotd)
"Return a list of slot details which can be used as an argument to ensure-class"
(list
:name (sb-mop:slot-definition-name slotd)
:type (sb-mop:slot-definition-type slotd)
:initfunction (sb-mop:slot-definition-initfunction slotd)
:allocation (sb-mop:slot-definition-allocation slotd)
:initargs (sb-mop:slot-definition-initargs slotd)
:readers (sb-mop:slot-definition-readers slotd)
:writers (sb-mop:slot-definition-writers slotd)))


(defun class-add-slot (class-name slot-name)
(sb-mop:ensure-class-using-class
(find-class class-name) class-name
:direct-slots (cons `(:name ,slot-name)
(mapcar #'unparse-direct-slot-definition
(sb-mop:class-direct-slots (find-class class-name))))))

(defun find-direct-slot-definition-by-initarg (class initarg)
(loop named outer
for super-class in (cdr (c2mop:class-precedence-list class))
Expand All @@ -102,8 +123,8 @@
(mapappend fun (mapcar 'cdr args)))))


;; (let ((result (mapappend #'(lambda (c) (when c (class-direct-subclasses c))) (list (fc class))))) result))
;; (unless proper? (push (fc class) result))
;; (let ((result (mapappend #'(lambda (c) (when c (class-direct-subclasses c))) (list (find-class* class))))) result))
;; (unless proper? (push (find-class* class) result))
;; (remove-duplicates result)))

;; (subclasses 'standard-object)
Expand All @@ -116,19 +137,27 @@
;; :proper? proper?)
;; (nreverse result)))

(defun class-subclasses (thing &key proper)
(labels ((all-subclasses (class)
(cons class
(mapcan #'all-subclasses
(c2mop:class-direct-subclasses class)))))
(let ((result (all-subclasses (find-class* thing))))
(if proper (rest result) result))))

(defun superclasses (thing &key (proper? t))
"Returns a list of superclasses of thing. Thing can be a class, object or symbol naming a class.
The list of classes returned is 'proper'; it does not include the class itself."
(let ((result (class-precedence-list (fc thing))))
(if proper? (rest result) result)))
(defun class-superclasses (thing &key (proper t))
"Returns a list of superclasses of thing. Thing can be a class,
object or symbol naming a class. The list of classes returned is
'proper'; it does not include the class itself."
(let ((result (class-precedence-list (find-class* thing))))
(if proper (rest result) result)))


(defun class-slot-names (thing)
(let ((class (fc thing)))
(let ((class (find-class* thing)))
(if class
(mapcar 'mop:slot-definition-name
(mop:class-slots (finalized-class class)))
(mapcar #'c2mop:slot-definition-name
(c2mop:class-slots (finalized-class class)))
(progn
(warn "class for ~a not found)" thing)
nil))))
Expand Down Expand Up @@ -196,7 +225,7 @@ REINITIALIZE-INSTANCE is called to update the copy with INITARGS.")
;; C3C72EC2-A553-4436-9B61-589516002CD4

;; (cloned-object-as 'cl-ctrie::context (uuid:make-v4-uuid))
;; 4DCBAA4C-8461-46E5-AA54-BFFCC047D4F8
;; 4DCBAA4C-8461-46E5-AA54-BFFIND-CLASS*C047D4F8

;; (class-of (cloned-object-as 'cl-ctrie::context (uuid:make-v4-uuid)))
;; #<STANDARD-CLASS CL-CTRIE::CONTEXT>
Expand Down Expand Up @@ -238,22 +267,8 @@ REINITIALIZE-INSTANCE is called to update the copy with INITARGS.")
:suppress-properties suppress-properties)) obj))
(t obj)))))

(defgeneric slot-definition-sexp (slot-definition)
(declare (optimize speed))
(:documentation
"Return a list of slot details which can be used
as an argument to ensure-class")
(:method ((slot-definition #+(or ecl abcl (and clisp (not mop))) t
#-(or ecl abcl (and clisp (not mop))) slot-definition))
(list
:name (slot-definition-name slot-definition)
:allocation (slot-definition-allocation slot-definition)
:initargs (slot-definition-initargs slot-definition)
:readers (slot-definition-readers slot-definition)
:type (slot-definition-type slot-definition)
:writers (slot-definition-writers slot-definition))))

;; (mapcar #'get-slot-details (sb-mop:class-slots (fc 'cl-user::test-file)))

;; (mapcar #'get-slot-details (sb-mop:class-slots (find-class* 'cl-user::test-file)))
;;
;; ((:NAME ASDF::NAME :ALLOCATION :INSTANCE :INITARGS (:NAME) :READERS NIL
;; :TYPE STRING :WRITERS NIL)
Expand Down
3 changes: 3 additions & 0 deletions common-io.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -40,6 +40,7 @@
:head
:tail))


(in-package :io)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Expand Down Expand Up @@ -357,6 +358,8 @@
(last (read-file-to-string-list pathname) lines))




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Figlet
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Expand Down
54 changes: 49 additions & 5 deletions common-macro.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,8 +8,8 @@
:defun/inline
:once-only
:defmacro/once
:build-list
:build-vector
:building-list
:building-vector
:with-thread
:anaphoric
:aprog1
Expand All @@ -18,7 +18,10 @@
:atypecase
:define-lazy-singleton
:defun-dynamic
:flet-dynamic))
:flet-dynamic
:map-cut
:cut
:define-synonym))

(in-package :macro)

Expand Down Expand Up @@ -108,12 +111,24 @@
(define-symbol-macro ,(intern (format nil "<~A>" name)) (,name)))))


(defmacro/once build-list (&once n &body body)
(defmacro define-synonym (alias orig &optional doc-string)
`(progn
(setf (documentation ',alias 'function)
,doc-string)
(cl:if (macro-function ',orig)
(setf (macro-function ',alias) (macro-function ',orig))
(setf (symbol-function ',alias) (symbol-function ',orig)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Generating Sequences
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmacro/once building-list (&once n &body body)
"Execute `body' `n' times, collecting the results into a list."
`(loop :repeat ,n :collect (progn ,@body)))


(defmacro/once build-vector (&once n &body body)
(defmacro/once building-vector (&once n &body body)
"Execute `body' `n' times, collecting the results into a vector."
(alexandria:with-gensyms (result index)
`(let1 ,result (make-array ,n)
Expand All @@ -127,6 +142,33 @@
:name ,name)))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; "Cut"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun map-cut (fn &rest args &aux arg-list)
(let* ((body (mapcar (lambda (arg) (case arg
(<> (let ((sym (gensym)))
(push sym arg-list)
sym))
(otherwise arg)))
args))
(fn-form (nconc (etypecase fn
(symbol (list fn))
(function `(funcall ,fn)))
body)))
`(lambda ,(nreverse arg-list) ,fn-form)))

(defmacro cut (function-name &rest args-or-<>)
`(apply #'map-cut ',function-name (quote ,args-or-<>)))


;; CL-USER> (#.(cut list 1 2 <> 4 <>) 3 "t")
;; (1 2 3 4 "t")
;; CL-USER> (apply #'map-cut '(list 1 2 <> 4 <>))
;; (LAMBDA (#:G925 #:G926) (LIST 1 2 #:G925 4 #:G926))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Anaphora
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Expand Down Expand Up @@ -209,3 +251,5 @@
;; (flet-dynamic ((foo (x) (* 10 x)))
;; (bar 3)))))))
;; :ok)


Loading

0 comments on commit 912908e

Please sign in to comment.