├── LICENSE ├── README.org ├── bootstrap.lisp ├── clclojure.asd ├── common-utils.lisp ├── cowmap.lisp ├── dustbin ├── bootstrap.lisp ├── clclojure.lisp ├── common-utils.lisp ├── cowmap.lisp ├── eval.lisp ├── evaltest.lisp ├── example.lisp ├── keywordfunc.lisp ├── lexical.lisp ├── literals.lisp ├── methoderr.lisp ├── pmap.lisp ├── protocols.lisp ├── pvector.lisp ├── reader.lisp ├── recurtest.lisp ├── sequences.lisp ├── symbols.lisp ├── variadic.lisp └── wrappers.lisp ├── eval.lisp ├── examples └── example.lisp ├── keywordfunc.lisp ├── lexical.lisp ├── literals.lisp ├── pmap.lisp ├── protocols.lisp ├── pvector.lisp ├── reader.lisp ├── sequences.lisp ├── symbols.lisp ├── tests ├── evaltest.lisp └── recurtest.lisp └── walk.lisp /LICENSE: -------------------------------------------------------------------------------- 1 | Eclipse Public License - v 1.0 2 | 3 | THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE PUBLIC 4 | LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF THE PROGRAM 5 | CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. 6 | 7 | 1. DEFINITIONS 8 | 9 | "Contribution" means: 10 | 11 | a) in the case of the initial Contributor, the initial code and documentation 12 | distributed under this Agreement, and 13 | b) in the case of each subsequent Contributor: 14 | i) changes to the Program, and 15 | ii) additions to the Program; 16 | 17 | where such changes and/or additions to the Program originate from and are 18 | distributed by that particular Contributor. A Contribution 'originates' from 19 | a Contributor if it was added to the Program by such Contributor itself or 20 | anyone acting on such Contributor's behalf. Contributions do not include 21 | additions to the Program which: (i) are separate modules of software 22 | distributed in conjunction with the Program under their own license 23 | agreement, and (ii) are not derivative works of the Program. 24 | 25 | "Contributor" means any person or entity that distributes the Program. 26 | 27 | "Licensed Patents" mean patent claims licensable by a Contributor which are 28 | necessarily infringed by the use or sale of its Contribution alone or when 29 | combined with the Program. 30 | 31 | "Program" means the Contributions distributed in accordance with this Agreement. 32 | 33 | "Recipient" means anyone who receives the Program under this Agreement, 34 | including all Contributors. 35 | 36 | 2. GRANT OF RIGHTS 37 | a) Subject to the terms of this Agreement, each Contributor hereby grants 38 | Recipient a non-exclusive, worldwide, royalty-free copyright license to 39 | reproduce, prepare derivative works of, publicly display, publicly perform, 40 | distribute and sublicense the Contribution of such Contributor, if any, and 41 | such derivative works, in source code and object code form. 42 | b) Subject to the terms of this Agreement, each Contributor hereby grants 43 | Recipient a non-exclusive, worldwide, royalty-free patent license under 44 | Licensed Patents to make, use, sell, offer to sell, import and otherwise 45 | transfer the Contribution of such Contributor, if any, in source code and 46 | object code form. This patent license shall apply to the combination of the 47 | Contribution and the Program if, at the time the Contribution is added by 48 | the Contributor, such addition of the Contribution causes such combination 49 | to be covered by the Licensed Patents. The patent license shall not apply 50 | to any other combinations which include the Contribution. No hardware per 51 | se is licensed hereunder. 52 | c) Recipient understands that although each Contributor grants the licenses to 53 | its Contributions set forth herein, no assurances are provided by any 54 | Contributor that the Program does not infringe the patent or other 55 | intellectual property rights of any other entity. Each Contributor 56 | disclaims any liability to Recipient for claims brought by any other entity 57 | based on infringement of intellectual property rights or otherwise. As a 58 | condition to exercising the rights and licenses granted hereunder, each 59 | Recipient hereby assumes sole responsibility to secure any other 60 | intellectual property rights needed, if any. For example, if a third party 61 | patent license is required to allow Recipient to distribute the Program, it 62 | is Recipient's responsibility to acquire that license before distributing 63 | the Program. 64 | d) Each Contributor represents that to its knowledge it has sufficient 65 | copyright rights in its Contribution, if any, to grant the copyright 66 | license set forth in this Agreement. 67 | 68 | 3. REQUIREMENTS 69 | 70 | A Contributor may choose to distribute the Program in object code form under its 71 | own license agreement, provided that: 72 | 73 | a) it complies with the terms and conditions of this Agreement; and 74 | b) its license agreement: 75 | i) effectively disclaims on behalf of all Contributors all warranties and 76 | conditions, express and implied, including warranties or conditions of 77 | title and non-infringement, and implied warranties or conditions of 78 | merchantability and fitness for a particular purpose; 79 | ii) effectively excludes on behalf of all Contributors all liability for 80 | damages, including direct, indirect, special, incidental and 81 | consequential damages, such as lost profits; 82 | iii) states that any provisions which differ from this Agreement are offered 83 | by that Contributor alone and not by any other party; and 84 | iv) states that source code for the Program is available from such 85 | Contributor, and informs licensees how to obtain it in a reasonable 86 | manner on or through a medium customarily used for software exchange. 87 | 88 | When the Program is made available in source code form: 89 | 90 | a) it must be made available under this Agreement; and 91 | b) a copy of this Agreement must be included with each copy of the Program. 92 | Contributors may not remove or alter any copyright notices contained within 93 | the Program. 94 | 95 | Each Contributor must identify itself as the originator of its Contribution, if 96 | any, in a manner that reasonably allows subsequent Recipients to identify the 97 | originator of the Contribution. 98 | 99 | 4. COMMERCIAL DISTRIBUTION 100 | 101 | Commercial distributors of software may accept certain responsibilities with 102 | respect to end users, business partners and the like. While this license is 103 | intended to facilitate the commercial use of the Program, the Contributor who 104 | includes the Program in a commercial product offering should do so in a manner 105 | which does not create potential liability for other Contributors. Therefore, if 106 | a Contributor includes the Program in a commercial product offering, such 107 | Contributor ("Commercial Contributor") hereby agrees to defend and indemnify 108 | every other Contributor ("Indemnified Contributor") against any losses, damages 109 | and costs (collectively "Losses") arising from claims, lawsuits and other legal 110 | actions brought by a third party against the Indemnified Contributor to the 111 | extent caused by the acts or omissions of such Commercial Contributor in 112 | connection with its distribution of the Program in a commercial product 113 | offering. The obligations in this section do not apply to any claims or Losses 114 | relating to any actual or alleged intellectual property infringement. In order 115 | to qualify, an Indemnified Contributor must: a) promptly notify the Commercial 116 | Contributor in writing of such claim, and b) allow the Commercial Contributor to 117 | control, and cooperate with the Commercial Contributor in, the defense and any 118 | related settlement negotiations. The Indemnified Contributor may participate in 119 | any such claim at its own expense. 120 | 121 | For example, a Contributor might include the Program in a commercial product 122 | offering, Product X. That Contributor is then a Commercial Contributor. If that 123 | Commercial Contributor then makes performance claims, or offers warranties 124 | related to Product X, those performance claims and warranties are such 125 | Commercial Contributor's responsibility alone. Under this section, the 126 | Commercial Contributor would have to defend claims against the other 127 | Contributors related to those performance claims and warranties, and if a court 128 | requires any other Contributor to pay any damages as a result, the Commercial 129 | Contributor must pay those damages. 130 | 131 | 5. NO WARRANTY 132 | 133 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS PROVIDED ON AN 134 | "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER EXPRESS OR 135 | IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR CONDITIONS OF TITLE, 136 | NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. Each 137 | Recipient is solely responsible for determining the appropriateness of using and 138 | distributing the Program and assumes all risks associated with its exercise of 139 | rights under this Agreement , including but not limited to the risks and costs 140 | of program errors, compliance with applicable laws, damage to or loss of data, 141 | programs or equipment, and unavailability or interruption of operations. 142 | 143 | 6. DISCLAIMER OF LIABILITY 144 | 145 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR ANY 146 | CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, 147 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION LOST 148 | PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 149 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 150 | OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE EXERCISE OF ANY RIGHTS 151 | GRANTED HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 152 | 153 | 7. GENERAL 154 | 155 | If any provision of this Agreement is invalid or unenforceable under applicable 156 | law, it shall not affect the validity or enforceability of the remainder of the 157 | terms of this Agreement, and without further action by the parties hereto, such 158 | provision shall be reformed to the minimum extent necessary to make such 159 | provision valid and enforceable. 160 | 161 | If Recipient institutes patent litigation against any entity (including a 162 | cross-claim or counterclaim in a lawsuit) alleging that the Program itself 163 | (excluding combinations of the Program with other software or hardware) 164 | infringes such Recipient's patent(s), then such Recipient's rights granted under 165 | Section 2(b) shall terminate as of the date such litigation is filed. 166 | 167 | All Recipient's rights under this Agreement shall terminate if it fails to 168 | comply with any of the material terms or conditions of this Agreement and does 169 | not cure such failure in a reasonable period of time after becoming aware of 170 | such noncompliance. If all Recipient's rights under this Agreement terminate, 171 | Recipient agrees to cease use and distribution of the Program as soon as 172 | reasonably practicable. However, Recipient's obligations under this Agreement 173 | and any licenses granted by Recipient relating to the Program shall continue and 174 | survive. 175 | 176 | Everyone is permitted to copy and distribute copies of this Agreement, but in 177 | order to avoid inconsistency the Agreement is copyrighted and may only be 178 | modified in the following manner. The Agreement Steward reserves the right to 179 | publish new versions (including revisions) of this Agreement from time to time. 180 | No one other than the Agreement Steward has the right to modify this Agreement. 181 | The Eclipse Foundation is the initial Agreement Steward. The Eclipse Foundation 182 | may assign the responsibility to serve as the Agreement Steward to a suitable 183 | separate entity. Each new version of the Agreement will be given a 184 | distinguishing version number. The Program (including Contributions) may always 185 | be distributed subject to the version of the Agreement under which it was 186 | received. In addition, after a new version of the Agreement is published, 187 | Contributor may elect to distribute the Program (including its Contributions) 188 | under the new version. Except as expressly stated in Sections 2(a) and 2(b) 189 | above, Recipient receives no rights or licenses to the intellectual property of 190 | any Contributor under this Agreement, whether expressly, by implication, 191 | estoppel or otherwise. All rights in the Program not expressly granted under 192 | this Agreement are reserved. 193 | 194 | This Agreement is governed by the laws of the State of New York and the 195 | intellectual property laws of the United States of America. No party to this 196 | Agreement will bring a legal action under this Agreement more than one year 197 | after the cause of action arose. Each party waives its rights to a jury trial in 198 | any resulting litigation. 199 | -------------------------------------------------------------------------------- /clclojure.asd: -------------------------------------------------------------------------------- 1 | ;;note: for quicklisp users... 2 | ;;compile and load this file, 3 | ;;or from emacs/SLIM (C-c C-k) 4 | ;;then quicklisp can load it for us 5 | ;;easy... 6 | ;;(ql:quickload :clclojure) 7 | (asdf:defsystem :clclojure 8 | :depends-on (:named-readtables :cl-package-locks :cl-murmurhash) ;copied from example. debate using :cl-hamt 9 | :components ((:file "common-utils") 10 | (:file "walk" 11 | :depends-on ("common-utils")) 12 | (:file "sequences" 13 | :depends-on ("common-utils")) 14 | (:file "reader" 15 | :depends-on ("pvector" "cowmap" "sequences")) 16 | (:file "eval" 17 | :depends-on ("common-utils" "walk" "reader")) 18 | (:file "literals" 19 | :depends-on ("eval" "pvector" "cowmap")) 20 | (:file "keywordfunc") 21 | (:file "pvector") 22 | (:file "cowmap") 23 | (:file "lexical" 24 | :depends-on ("keywordfunc")) 25 | (:file "protocols" 26 | :depends-on ("literals" "common-utils" "reader" "pvector" "cowmap")) 27 | (:file "bootstrap" 28 | :depends-on ("literals" 29 | "common-utils" 30 | "lexical" 31 | "keywordfunc" 32 | "protocols" 33 | "pvector" 34 | "cowmap"))) 35 | ) 36 | -------------------------------------------------------------------------------- /cowmap.lisp: -------------------------------------------------------------------------------- 1 | ;;A lame copy-on-write implementation of persistent maps 2 | ;;useful for bootstrapping. 3 | 4 | ;;Notably, none of the operations on these guys are 5 | ;;lazy. Uses copies for otherwise destructive operations. 6 | ;;Wraps a mutable hashtable. 7 | (defpackage :clclojure.cowmap 8 | (:use :common-lisp) 9 | (:export :persistent-map 10 | :empty-map? 11 | :map-count 12 | :map-assoc 13 | :map-dissoc 14 | :map-entry-at 15 | :map-contains? 16 | :map-seq 17 | :empty-map 18 | :map-get 19 | :cowmap-table 20 | :cowmap) 21 | (:shadow :assoc 22 | :find)) 23 | (in-package clclojure.cowmap) 24 | 25 | (EVAL-WHEN (:compile-toplevel :load-toplevel :execute) 26 | (defstruct cowmap (table (make-hash-table))) 27 | 28 | ;;From stack overflow. It looks like the compiler needs a hint if we're 29 | ;;defining struct/class literals and using them as constants. 30 | (defmethod make-load-form ((m cowmap) &optional env) 31 | (declare (ignore env)) 32 | (make-load-form-saving-slots m))) 33 | 34 | (defun ->cowmap () 35 | "Simple persistent vector builder. Used to derive from other pvectors 36 | to share structure where possible." 37 | (make-cowmap)) 38 | 39 | (common-utils::defconstant! +empty-cowmap+ (make-cowmap)) 40 | (defun empty-map () +empty-cowmap+) 41 | (defun empty-map? (m) (eq m +empty-cowmap+)) 42 | 43 | (defun map-count (m) 44 | (hash-table-count (cowmap-table m))) 45 | 46 | 47 | (defun insert-keys! (tbl xs) 48 | (assert (evenp (length xs))) 49 | (loop for (k v) in (common-utils::partition! 2 xs) 50 | do (setf (gethash k tbl) v)) 51 | tbl) 52 | 53 | (defun persistent-map (&rest xs) 54 | "Funcallable constructor for building vectors from arglists. Used for 55 | read-macro dispatch as well." 56 | (if (null xs) 57 | +empty-cowmap+ 58 | (progn 59 | (assert (evenp (length xs))) 60 | (let* ((cm (->cowmap)) 61 | (tbl (cowmap-table cm))) 62 | (insert-keys! tbl xs) 63 | cm)))) 64 | 65 | (defun map-contains? (m k) 66 | (multiple-value-bind (v present) (gethash k (cowmap-table m)) 67 | (declare (ignore v)) 68 | present)) 69 | 70 | (defun map-get (m k &optional default) 71 | (gethash k (cowmap-table m) default)) 72 | 73 | (defun map-entry-at (m k) 74 | (multiple-value-bind (v present) (map-get m k) 75 | (when present (list k v)))) 76 | 77 | (defun map-assoc (m k v) 78 | (let ((tbl (common-utils::copy-hash-table (cowmap-table m)))) 79 | (setf (gethash k tbl) v) 80 | (make-cowmap :table tbl))) 81 | 82 | (defun map-dissoc (m k) 83 | (if (map-contains? m k) 84 | (let ((tbl (common-utils::copy-hash-table (cowmap-table m)))) 85 | (remhash k tbl) 86 | (make-cowmap :table tbl)) 87 | m)) 88 | 89 | (defun map-seq (m) 90 | (common-utils::hash-table->entries (cowmap-table m))) 91 | 92 | (defmethod print-object ((obj cowmap) stream) 93 | (common-utils::print-map (cowmap-table obj) stream)) 94 | -------------------------------------------------------------------------------- /dustbin/clclojure.lisp: -------------------------------------------------------------------------------- 1 | ;;DEPRECATED 2 | ;;========= 3 | 4 | ;;see boostrap.lisp for current effort! 5 | ;;Retained for possible pedagogical/historical value.... 6 | 7 | ;;this is a simple set of utils I'd like to have around 8 | ;;to further my knowledge, I'll stick it in a package 9 | ;;using common lisp parlance. 10 | (load "pvector.lisp") 11 | (load "protocols.lisp") 12 | 13 | (defpackage :clojurecl 14 | (:use :common-lisp 15 | :clojure.protocol 16 | :clojure.pvector) 17 | (:export :take 18 | :drop 19 | :ndrop 20 | :take-while 21 | :drop-while 22 | :ndrop-while 23 | :filter 24 | :fold 25 | :partition 26 | :partition-offset 27 | :interleave 28 | :->> 29 | :-> 30 | :lazy 31 | :force 32 | :lazy-null 33 | :lazy-nil 34 | :lazy-car 35 | :lazy-cdr 36 | :lazy-cons 37 | :make-lazy 38 | :iterate) 39 | (:shadow :first 40 | :rest 41 | :cons)) 42 | ;:export -> names of stuff to export. 43 | 44 | (in-package :clojurecl) 45 | 46 | (defgeneric seq (x) 47 | (:documentation 48 | "Basic constructor for lazy sequences.") 49 | 50 | 51 | ;using protocols to implement library functionality 52 | ;now. 53 | 54 | ;; clojure.lang.ISeq 55 | ;; (first [self] (first a)) 56 | ;; (next [self] (next a)) 57 | ;; (more [self] (rest a)) 58 | 59 | ;; ;Ported from clojurescript compiler. Fundamental protocols. 60 | (defprotocol ICounted 61 | (-count [coll] "constant time count")) 62 | 63 | (defprotocol IEmptyableCollection 64 | (-empty [coll])) 65 | 66 | (defprotocol ICollection 67 | (-conj [coll o])) 68 | 69 | (defprotocol IOrdinal 70 | (-index [coll])) 71 | 72 | (defprotocol IIndexed 73 | (-nth [coll n] [coll n not-found])) 74 | 75 | (defprotocol ASeq) 76 | 77 | (defprotocol ISeq 78 | (-first [coll]) 79 | (-rest [coll])) 80 | 81 | (defprotocol INext 82 | (-next [coll])) 83 | 84 | (defprotocol ILookup 85 | (-lookup [o k] [o k not-found])) 86 | 87 | (defprotocol IAssociative 88 | (-contains-key? [coll k]) 89 | #_(-entry-at [coll k]) 90 | (-assoc [coll k v])) 91 | 92 | (defprotocol IMap 93 | #_(-assoc-ex [coll k v]) 94 | (-dissoc [coll k])) 95 | 96 | (defprotocol IMapEntry 97 | (-key [coll]) 98 | (-val [coll])) 99 | 100 | (defprotocol ISet 101 | (-disjoin [coll v])) 102 | 103 | (defprotocol IStack 104 | (-peek [coll]) 105 | (-pop [coll])) 106 | 107 | (defprotocol IVector 108 | (-assoc-n [coll n val])) 109 | 110 | (defprotocol IDeref 111 | (-deref [o])) 112 | 113 | (defprotocol IDerefWithTimeout 114 | (-deref-with-timeout [o msec timeout-val])) 115 | 116 | (defprotocol IMeta 117 | (-meta [o])) 118 | 119 | (defprotocol IWithMeta 120 | (-with-meta [o meta])) 121 | 122 | (defprotocol IReduce 123 | (-reduce [coll f] [coll f start])) 124 | 125 | (defprotocol IKVReduce 126 | (-kv-reduce [coll f init])) 127 | 128 | (defprotocol IEquiv 129 | (-equiv [o other])) 130 | 131 | (defprotocol IHash 132 | (-hash [o])) 133 | 134 | (defprotocol ISeqable 135 | (-seq [o])) 136 | 137 | (defprotocol ISequential 138 | "Marker interface indicating a persistent collection of sequential items") 139 | 140 | (defprotocol IList 141 | "Marker interface indicating a persistent list") 142 | 143 | (defprotocol IRecord 144 | "Marker interface indicating a record object") 145 | 146 | (defprotocol IReversible 147 | (-rseq [coll])) 148 | 149 | (defprotocol ISorted 150 | (-sorted-seq [coll ascending?]) 151 | (-sorted-seq-from [coll k ascending?]) 152 | (-entry-key [coll entry]) 153 | (-comparator [coll])) 154 | 155 | ;; (defprotocol ^:deprecated IPrintable 156 | ;; "Do not use this. It is kept for backwards compatibility with existing 157 | ;; user code that depends on it, but it has been superceded by IPrintWithWriter 158 | ;; User code that depends on this should be changed to use -pr-writer instead." 159 | ;; (-pr-seq [o opts])) 160 | 161 | ;; (defprotocol IWriter 162 | ;; (-write [writer s]) 163 | ;; (-flush [writer])) 164 | 165 | ;; (defprotocol IPrintWithWriter 166 | ;; "The old IPrintable protocol's implementation consisted of building a giant 167 | ;; list of strings to concatenate. This involved lots of concat calls, 168 | ;; intermediate vectors, and lazy-seqs, and was very slow in some older JS 169 | ;; engines. IPrintWithWriter implements printing via the IWriter protocol, so it 170 | ;; be implemented efficiently in terms of e.g. a StringBuffer append." 171 | ;; (-pr-writer [o writer opts])) 172 | 173 | (defprotocol IPending 174 | (-realized? [d])) 175 | 176 | (defprotocol IWatchable 177 | (-notify-watches [this oldval newval]) 178 | (-add-watch [this key f]) 179 | (-remove-watch [this key])) 180 | 181 | (defprotocol IEditableCollection 182 | (-as-transient [coll])) 183 | 184 | (defprotocol ITransientCollection 185 | (-conj! [tcoll val]) 186 | (-persistent! [tcoll])) 187 | 188 | (defprotocol ITransientAssociative 189 | (-assoc! [tcoll key val])) 190 | 191 | (defprotocol ITransientMap 192 | (-dissoc! [tcoll key])) 193 | 194 | (defprotocol ITransientVector 195 | (-assoc-n! [tcoll n val]) 196 | (-pop! [tcoll])) 197 | 198 | (defprotocol ITransientSet 199 | (-disjoin! [tcoll v])) 200 | 201 | (defprotocol IComparable 202 | (-compare [x y])) 203 | 204 | (defprotocol IChunk 205 | (-drop-first [coll])) 206 | 207 | (defprotocol IChunkedSeq 208 | (-chunked-first [coll]) 209 | (-chunked-rest [coll])) 210 | 211 | (defprotocol IChunkedNext 212 | (-chunked-next [coll])) 213 | 214 | (defprotocol ISeq 215 | (first (s) "Returns the first element of a sequence.") 216 | (next (s) "Returns the next element of the sequence or nil") 217 | (more (s) "Returns the rest of sequence s as a lazy seq.")) 218 | 219 | ;(defprotocol IReduce...) 220 | 221 | ;Include lists and arrays.... 222 | (extend-protocol ISeq 223 | null (first (s) nil) 224 | (next (s) nil) 225 | (more (s) nil) 226 | cons (first (s) (common-lisp:first s)) 227 | (next (s) (common-lisp:rest s)) 228 | (more (s) (seq (common-lisp:rest s))) 229 | clojure.pvector::pvec 230 | (first (s) (nth-vec s 0)) 231 | (next (s) (subvec s 1)) 232 | (more (s) (seq (subvec s 1)))) 233 | 234 | ;; clojure.lang.IPersistentCollection 235 | ;; (seq [self] (if (seq a) self nil)) 236 | ;; (cons [self o] (Foo. a (conj b o))) 237 | ;; (empty [self] (Foo. [] [])) 238 | ;; (equiv 239 | ;; [self o] 240 | ;; (if (instance? Foo o) 241 | ;; (and (= a (.a o)) 242 | ;; (= b (.b o))) 243 | ;; false)) 244 | 245 | (defprotocol IPersistentCollection 246 | (seq (x) "Returns a lazy sequence of the input.") 247 | (cons (x y) "Returns a lazy sequence constructed from x and s.") 248 | (empty (x) "Determines if x is empty.") 249 | (equiv (x y) "Equality comparison between x and y.")) 250 | 251 | ;;borrowed shamelessly from Conrad Barksi's excellent 252 | ;;Land of Lisp....the definitive work on building lisp 253 | ;;games and being a better person! 254 | 255 | (defmacro lazy (&body body) 256 | "Creates a lazy value from v, returning a thunk'd 257 | function that, upon evaluation, caches the result." 258 | (let ((forced? (gensym)) 259 | (val (gensym))) 260 | `(let ((,forced? nil) 261 | (,val nil)) 262 | (lambda () 263 | (unless ,forced? 264 | (setf ,val (progn ,@body)) 265 | (setf ,forced? 't)) 266 | ,val)))) 267 | 268 | (defun force (lazy-value) 269 | "Ensures that any thunks are evaluated, thus providing 270 | the rich, tender values underneath. I added a quick 271 | function check to allow non-thunked values to be 272 | forced, for consistency...." 273 | (if (functionp lazy-value) 274 | (funcall lazy-value) 275 | lazy-value)) 276 | 277 | (defmacro lazy-cons (x y) 278 | "Creates a lazy cons-cell from x and y." 279 | `(lazy (cons ,x ,y))) 280 | 281 | (defun lazy-car (x) 282 | "Lazified version of car...note that since I 283 | generalized force, we can use it on either lazy 284 | or non-lazy lists." 285 | (car (force x))) 286 | 287 | (defun lazy-cdr (x) 288 | "Lazified version of cdr...again, since force 289 | can handle eager values, this works for any 290 | list." 291 | (cdr (force x))) 292 | 293 | (defun lazy-nil () 294 | (lazy nil)) 295 | 296 | (defun lazy-null (x) 297 | (not (force x))) 298 | 299 | 300 | (defprotocol ILazySeq 301 | (make-lazy (coll) "Converts collection into a lazy sequence.")) 302 | ;IChunkedSeq is a lot like subvec, in that it works in chunks. 303 | ;Basically, as we pull elements out of our chunked sequence, 304 | ;we return light wrapper objects that refer to the chunk. 305 | (defprotocol IChunkedSeq 306 | (chunked-first (coll) "Get the first lazy chunk") 307 | (chunked-next (coll) "Get the next lazy chunk") 308 | (chunked-more (coll) "Get the next lazy chunk")) 309 | 310 | (extend-protocol ILazySeq 311 | null (make-lazy (coll) nil) 312 | cons (make-lazy (coll) 313 | (lazy (when coll 314 | (cons (first coll) 315 | (make-lazy (rest coll))))))) 316 | ;; clojure.pvector:pvec 317 | ;; (make-lazy (coll) 318 | ;; (fn 319 | 320 | 321 | ;; (defgeneric make-lazy (lst)) 322 | ;; (defmethod make-lazy ((lst cons)) 323 | ;; "Converts a normal list into a lazy list." 324 | 325 | 326 | (defmacro ->> (x form &rest more) 327 | "Threading operator, identical to Clojure. 328 | Threads x as the last argument through form. 329 | If more forms are passed in, nests the threading, 330 | so that each preceding form is evaluated as the 331 | last form in next form." 332 | (if (null more) 333 | (if (atom form) 334 | (list form x) 335 | `(,(first form) ,@(rest form) ,x)) 336 | `(->> (->> ,x ,form) ,@more))) 337 | 338 | (defmacro -> (x form &rest more) 339 | "Threading operator, identical to Clojure. 340 | Threads x as the second argument through form. 341 | If more forms are passed in, nests the threading, 342 | so that each preceding form is evaluated as the 343 | second form in next form." 344 | (if (null more) 345 | (if (atom form) 346 | (list form x) 347 | `(,(first form) ,x ,@(rest form))) 348 | `(->> (->> ,x ,form) ,@more))) 349 | 350 | (defgeneric conj (x coll)) 351 | ;;(defmethod conj (x 352 | ;(defgeneric take (n l)) 353 | ;; (defmethod take (n (l cons)) 354 | ;; "Takes n elements from a list" 355 | ;; (do ((remaining l (rest remaining)) 356 | ;; (acc (list)) 357 | ;; (i n (decf i))) 358 | ;; ((or (= 0 i) (null remaining)) (nreverse acc)) 359 | ;; (push (first remaining) acc))) 360 | 361 | (defun take (n coll) 362 | "Takes n elements from a sequence." 363 | (do ((remaining l (rest remaining)) 364 | (acc [] () 365 | (i n (decf i))) 366 | ((or (= 0 i) (null remaining)) acc) 367 | (push (first remaining) acc))) 368 | 369 | 370 | (defun drop (n coll) 371 | "Drops the first n elements from a sequence." 372 | (do ((remaining l (rest remaining)) 373 | (acc nil) 374 | (i n (decf i))) 375 | ((null remaining) acc) 376 | (when (zerop i) 377 | (progn (setf acc (copy-list remaining)) 378 | (setf remaining nil))))) 379 | 380 | ;(defgeneric drop (n l)) 381 | ;; (defmethod drop (n (l cons)) 382 | ;; "Drops the first n elements from a list" 383 | ;; (do ((remaining l (rest remaining)) 384 | ;; (acc nil) 385 | ;; (i n (decf i))) 386 | ;; ((null remaining) acc) 387 | ;; (when (zerop i) 388 | ;; (progn (setf acc (copy-list remaining)) 389 | ;; (setf remaining nil))))) 390 | 391 | (defun ndrop (n l) 392 | "Drops the first n elements from a list. Returns the sublist 393 | of the inputlist, rather than accumulate a copy." 394 | (do ((remaining l) 395 | (i n (decf i))) 396 | ((or (= 0 i) (null remaining)) remaining) 397 | (when (not (zerop i)) 398 | (setf remaining (rest remaining))))) 399 | 400 | (defgeneric filter (f l)) 401 | (defmethod filter (f (l cons)) 402 | "Returns a new list l, for all elements where 403 | applications of f yield true." 404 | (do ((remaining l (rest remaining)) 405 | (acc (list))) 406 | ((null remaining) (nreverse acc)) 407 | (when (funcall f (first remaining)) 408 | (push (first remaining) acc)))) 409 | 410 | (defgeneric take-while (f l)) 411 | (defmethod take-while (f (l cons)) 412 | "Draws elements from a list while f yields true. 413 | Returns the resulting list." 414 | (do ((remaining l (rest remaining)) 415 | (acc (list))) 416 | ((null remaining) (nreverse acc)) 417 | (if (funcall f (first remaining)) 418 | (push (first remaining) acc) 419 | (setf remaining nil)))) 420 | 421 | (defgeneric drop-while (f l)) 422 | (defmethod drop-while (f (l cons)) 423 | "Draws elements from a list while f yields true. 424 | Returns the resulting list." 425 | (do ((remaining l (rest remaining)) 426 | (acc (list))) 427 | ((null remaining) acc) 428 | (when (not (funcall f (first remaining))) 429 | (progn (setf acc (copy-list remaining)) 430 | (setf remaining nil))))) 431 | 432 | (defun ndrop-while (f l) 433 | "Draws elements from a list while f yields true. 434 | Returns the resulting list. Impure." 435 | (do ((remaining l (rest remaining)) 436 | (acc nil)) 437 | ((null remaining) acc) 438 | (when (not (funcall f (first remaining))) 439 | (progn (setf acc remaining) 440 | (setf remaining nil))))) 441 | 442 | (defun fold (f init l) 443 | "A simple wrapper for reduce." 444 | (reduce f l :initial-value init)) 445 | 446 | (defgeneric partition (n l &key offset)) 447 | (defmethod partition (n (l cons) &key (offset n)) 448 | "Akin to partition from clojure. Builds 449 | a list of lists, where each list is size n 450 | elements." 451 | (do ((remaining l (ndrop offset remaining)) 452 | (acc (list))) 453 | ((null remaining) (nreverse acc)) 454 | (let ((nxt (take n remaining))) 455 | (if (= (length nxt) n) 456 | (push nxt acc) 457 | (setf remaining nil))))) 458 | 459 | (defun partition-offset (n offset l) 460 | "A form of partition, with adjustable offsetting 461 | that is friendly to the ->> threading macro." 462 | (partition n l :offset offset)) 463 | 464 | (defgeneric interleave (xs ys)) 465 | (defmethod interleave ((xs cons) (ys cons)) 466 | "Returns a list composed of interwoven values drawn from 467 | input lists xs and ys. Stops the interleaving process 468 | when either list is exhausted." 469 | (do ((left xs (rest left)) 470 | (right ys (rest right)) 471 | (acc nil)) 472 | ((or (null left) (null right)) (nreverse acc)) 473 | (progn 474 | (push (first left) acc) 475 | (push (first right) acc)))) 476 | 477 | 478 | 479 | (defun iterate (f init) 480 | "Produces a lazy sequence of results, where 481 | f is applied repeatedly, first to init, then 482 | to the result (f (f (f init)))" 483 | (let ((res (funcall f init))) 484 | (if res 485 | (lazy-cons res (iterate f res)) 486 | nil))) 487 | 488 | ;(lazy-cons 2 nil) 489 | ;(lazy-list 2) 490 | ;(lazy-list 2 3 4) -> (lazy-cons 2 (lazy-cons 3 (lazy-cons 4))) 491 | 492 | ;;(->> (list) 493 | ;; (mapcar #'1+)) 494 | 495 | ;;(mapcar #'1+ (list)) 496 | 497 | -------------------------------------------------------------------------------- /dustbin/cowmap.lisp: -------------------------------------------------------------------------------- 1 | ;;A lame copy-on-write implementation of persistent maps 2 | ;;useful for bootstrapping. 3 | 4 | ;;Notably, none of the operations on these guys are 5 | ;;lazy. Uses copies for otherwise destructive operations. 6 | ;;Wraps a mutable hashtable. 7 | (defpackage :clclojure.cowmap 8 | (:use :common-lisp) 9 | (:export :persistent-map 10 | :empty-map? 11 | :map-count 12 | :map-assoc 13 | :map-seq 14 | :empty-map 15 | :cowmap-table 16 | :cowmap) 17 | (:shadow :assoc 18 | :find)) 19 | (in-package clclojure.cowmap) 20 | 21 | (EVAL-WHEN (:compile-toplevel :load-toplevel :execute) 22 | (defstruct cowmap (table (make-hash-table))) 23 | 24 | ;;From stack overflow. It looks like the compiler needs a hint if we're 25 | ;;defining struct/class literals and using them as constants. 26 | (defmethod make-load-form ((m cowmap) &optional env) 27 | (declare (ignore env)) 28 | (make-load-form-saving-slots m))) 29 | 30 | (defun ->cowmap () 31 | "Simple persistent vector builder. Used to derive from other pvectors 32 | to share structure where possible." 33 | (make-cowmap)) 34 | 35 | (common-utils::defconstant! +empty-cowmap+ (make-cowmap)) 36 | (defun empty-map () +empty-cowmap+) 37 | (defun empty-map? (m) (eq m +empty-cowmap+)) 38 | 39 | (defun map-count (m) 40 | (hash-table-count (cowmap-table m))) 41 | 42 | 43 | (defun insert-keys! (tbl xs) 44 | (assert (evenp (length xs))) 45 | (loop for (k v) in (common-utils::partition! 2 xs) 46 | do (setf (gethash k tbl) v)) 47 | tbl) 48 | 49 | (defun persistent-map (&rest xs) 50 | "Funcallable constructor for building vectors from arglists. Used for 51 | read-macro dispatch as well." 52 | (if (null xs) 53 | +empty-cowmap+ 54 | (progn 55 | (assert (evenp (length xs))) 56 | (let* ((cm (->cowmap)) 57 | (tbl (cowmap-table cm))) 58 | (insert-keys! tbl xs) 59 | cm)))) 60 | 61 | (defun map-contains? (m k) 62 | (second (values (gethash k (cowmap-table m))))) 63 | 64 | (defun map-get (m k &optional default) 65 | (gethash k (cowmap-table m) default)) 66 | 67 | (defun map-entry-at (m k) 68 | (multiple-value-bind (v present) (map-get m k) 69 | (when present (list k v)))) 70 | 71 | (defun map-assoc (m k v) 72 | (let ((tbl (common-utils::copy-hash-table (cowmap-table m)))) 73 | (setf (gethash k tbl) v) 74 | (make-cowmap :table tbl))) 75 | 76 | (defun map-dissoc (m k) 77 | (if (map-contains? m k) 78 | (let ((tbl (common-utils::copy-hash-table (cowmap-table m)))) 79 | (remhash k tbl) 80 | (make-cowmap :table tbl)) 81 | m)) 82 | 83 | (defun map-seq (m) 84 | (common-utils::hash-table->entries (cowmap-table m))) 85 | 86 | (defmethod print-object ((obj cowmap) stream) 87 | (common-utils::print-map (cowmap-table obj) stream)) 88 | -------------------------------------------------------------------------------- /dustbin/eval.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :clclojure.eval 2 | (:use :common-lisp 3 | :cl-package-locks) 4 | (:export :custom-eval :enable-custom-eval :disable-custom-eval 5 | :simple-eval-in-lexenv)) 6 | 7 | (in-package clclojure.eval) 8 | 9 | (defgeneric custom-eval (obj)) 10 | ;;We perform the same thing existing eval does for unknown 11 | ;;datums. Just return the data as-is. This is effectively 12 | ;;what sbcl does by default. 13 | (defmethod custom-eval (obj) obj) 14 | 15 | ;;another option is to use find-method... 16 | ;(find-method #'custom-eval '() '(t) nil) 17 | (defvar +original-eval+ (symbol-function 'SB-IMPL::simple-eval-in-lexenv)) 18 | 19 | ;;This is identical to the default sbcl eval.. 20 | ;;with the exception of the hook to our custom method. 21 | 22 | (unlock-package :sb-impl) 23 | (in-package :sb-impl) 24 | 25 | (defun custom-eval-in-lexenv (original-exp lexenv) 26 | (declare (optimize (safety 1))) 27 | ;; (aver (lexenv-simple-p lexenv)) 28 | (incf *eval-calls*) 29 | (sb-c:with-compiler-error-resignalling 30 | (let ((exp (macroexpand original-exp lexenv))) 31 | (handler-bind ((eval-error 32 | (lambda (condition) 33 | (error 'interpreted-program-error 34 | :condition (encapsulated-condition condition) 35 | :form exp)))) 36 | (typecase exp 37 | (symbol 38 | (ecase (info :variable :kind exp) 39 | ((:special :global :constant :unknown) 40 | (symbol-value exp)) 41 | ;; FIXME: This special case here is a symptom of non-ANSI 42 | ;; weirdness in SBCL's ALIEN implementation, which could 43 | ;; cause problems for e.g. code walkers. It'd probably be 44 | ;; good to ANSIfy it by making alien variable accessors 45 | ;; into ordinary forms, e.g. (SB-UNIX:ENV) and (SETF 46 | ;; SB-UNIX:ENV), instead of magical symbols, e.g. plain 47 | ;; SB-UNIX:ENV. Then if the old magical-symbol syntax is to 48 | ;; be retained for compatibility, it can be implemented 49 | ;; with DEFINE-SYMBOL-MACRO, keeping the code walkers 50 | ;; happy. 51 | (:alien 52 | (sb-alien-internals:alien-value exp)))) 53 | (list 54 | (let ((name (first exp)) 55 | (n-args (1- (length exp)))) 56 | (case name 57 | ((function) 58 | (unless (= n-args 1) 59 | (error "wrong number of args to FUNCTION:~% ~S" exp)) 60 | (let ((name (second exp))) 61 | (if (and (legal-fun-name-p name) 62 | (not (consp (let ((sb-c:*lexenv* lexenv)) 63 | (sb-c:lexenv-find name funs))))) 64 | (%coerce-name-to-fun name) 65 | ;; FIXME: This is a bit wasteful: it would be nice to call 66 | ;; COMPILE-IN-LEXENV with the lambda-form directly, but 67 | ;; getting consistent source context and muffling compiler notes 68 | ;; is easier this way. 69 | (%simple-eval original-exp lexenv)))) 70 | ((quote) 71 | (unless (= n-args 1) 72 | (error "wrong number of args to QUOTE:~% ~S" exp)) 73 | (second exp)) 74 | (setq 75 | (unless (evenp n-args) 76 | (error "odd number of args to SETQ:~% ~S" exp)) 77 | (unless (zerop n-args) 78 | (do ((name (cdr exp) (cddr name))) 79 | ((null name) 80 | (do ((args (cdr exp) (cddr args))) 81 | ((null (cddr args)) 82 | ;; We duplicate the call to SET so that the 83 | ;; correct value gets returned. 84 | (set (first args) 85 | (simple-eval-in-lexenv (second args) lexenv))) 86 | (set (first args) 87 | (simple-eval-in-lexenv (second args) lexenv)))) 88 | (let ((symbol (first name))) 89 | (case (info :variable :kind symbol) 90 | (:special) 91 | (t (return (%simple-eval original-exp lexenv)))) 92 | (unless (type= (info :variable :type symbol) 93 | *universal-type*) 94 | ;; let the compiler deal with type checking 95 | (return (%simple-eval original-exp lexenv))))))) 96 | ((progn) 97 | (simple-eval-progn-body (rest exp) lexenv)) 98 | ((eval-when) 99 | ;; FIXME: DESTRUCTURING-BIND returns ARG-COUNT-ERROR 100 | ;; instead of PROGRAM-ERROR when there's something wrong 101 | ;; with the syntax here (e.g. missing SITUATIONS). This 102 | ;; could be fixed by hand-crafting clauses to catch and 103 | ;; report each possibility, but it would probably be 104 | ;; cleaner to write a new macro 105 | ;; DESTRUCTURING-BIND-PROGRAM-SYNTAX which does 106 | ;; DESTRUCTURING-BIND and promotes any mismatch to 107 | ;; PROGRAM-ERROR, then to use it here and in (probably 108 | ;; dozens of) other places where the same problem 109 | ;; arises. 110 | (destructuring-bind (eval-when situations &rest body) exp 111 | (declare (ignore eval-when)) 112 | (multiple-value-bind (ct lt e) 113 | (sb-c:parse-eval-when-situations situations) 114 | ;; CLHS 3.8 - Special Operator EVAL-WHEN: The use of 115 | ;; the situation :EXECUTE (or EVAL) controls whether 116 | ;; evaluation occurs for other EVAL-WHEN forms; that 117 | ;; is, those that are not top level forms, or those 118 | ;; in code processed by EVAL or COMPILE. If the 119 | ;; :EXECUTE situation is specified in such a form, 120 | ;; then the body forms are processed as an implicit 121 | ;; PROGN; otherwise, the EVAL-WHEN form returns NIL. 122 | (declare (ignore ct lt)) 123 | (when e 124 | (simple-eval-progn-body body lexenv))))) 125 | ((locally) 126 | (simple-eval-locally (rest exp) lexenv)) 127 | ((macrolet) 128 | (destructuring-bind (definitions &rest body) (rest exp) 129 | (let ((sb-c:*lexenv* lexenv)) 130 | (sb-c::funcall-in-macrolet-lexenv 131 | definitions 132 | (lambda (&optional funs) 133 | (simple-eval-locally body sb-c:*lexenv* 134 | :funs funs)) 135 | :eval)))) 136 | ((symbol-macrolet) 137 | (destructuring-bind (definitions &rest body) (rest exp) 138 | (let ((sb-c:*lexenv* lexenv)) 139 | (sb-c::funcall-in-symbol-macrolet-lexenv 140 | definitions 141 | (lambda (&optional vars) 142 | (simple-eval-locally body sb-c:*lexenv* 143 | :vars vars)) 144 | :eval)))) 145 | ((if) 146 | (destructuring-bind (test then &optional else) (rest exp) 147 | (eval-in-lexenv (if (eval-in-lexenv test lexenv) 148 | then 149 | else) 150 | lexenv))) 151 | ((let let*) 152 | (%simple-eval exp lexenv)) 153 | (t 154 | (if (and (symbolp name) 155 | (eq (info :function :kind name) :function)) 156 | (collect ((args)) 157 | (dolist (arg (rest exp)) 158 | (args (eval-in-lexenv arg lexenv))) 159 | (apply (symbol-function name) (args))) 160 | (%simple-eval exp lexenv)))))) 161 | (t 162 | ;;Unlike the default SBCL eval, we inject our custom-eval here. 163 | ;;This allows types to define custom evaluation semantics, e.g. 164 | ;;for data literals, otherwise, it behaves exactly like original 165 | ;;eval and returns the type. 166 | (clclojure.eval:custom-eval exp))))))) ; something dangerous 167 | 168 | (in-package :clclojure.eval) 169 | (lock-package :sb-impl) 170 | 171 | (defun enable-custom-eval () 172 | (with-packages-unlocked (:sb-impl :sb-int) 173 | (setf (symbol-function 'SB-IMPL::simple-eval-in-lexenv) 174 | (symbol-function 'SB-IMPL::custom-eval-in-lexenv))) ; something dangerous 175 | ) 176 | 177 | (defun disable-custom-eval () 178 | (with-packages-unlocked (:sb-impl :sb-int) 179 | (setf (symbol-function 'SB-IMPL::simple-eval-in-lexenv) 180 | +original-eval+) ; something dangerous 181 | t)) 182 | -------------------------------------------------------------------------------- /dustbin/evaltest.lisp: -------------------------------------------------------------------------------- 1 | ;;quick test to see if we get compiler support for our 2 | ;;eval hack... 3 | (ql:quickload :cl-package-locks) 4 | (load "eval.lisp") 5 | 6 | (defstruct blah (x)) 7 | 8 | (defparameter b (make-blah :x 2)) 9 | 10 | (defmethod clclojure.eval:custom-eval 11 | ((obj blah)) 12 | (list :this-is-custom (blah-x obj))) 13 | 14 | (clclojure.eval:enable-custom-eval) 15 | (defparameter custom (eval b)) 16 | ;;(:THIS-IS-CUSTOM 2) 17 | 18 | (clclojure.eval:disable-custom-eval) 19 | (defparameter normal (eval b)) 20 | ;;#S(BLAH :X 2) 21 | 22 | -------------------------------------------------------------------------------- /dustbin/example.lisp: -------------------------------------------------------------------------------- 1 | (ql:quickload :clclojure) 2 | 3 | ;;we'll eventually morph this 4 | ;;into an ns call somehow.... 5 | (defpackage :clclojure.example 6 | (:use :common-lisp :clclojure.base) 7 | (:shadowing-import-from :clclojure.base 8 | :deftype :let)) 9 | (in-package :clclojure.example) 10 | 11 | ;;we have persistent vectors, which will 12 | ;;be replaced by bootstrapped variants from 13 | ;;clclojure.base... 14 | 15 | ;;some clojure-0 expressions demonstrating 16 | ;;fundamentals of the language primitives... 17 | 18 | ;;def and defn export by default, 19 | ;;also unify the function and symbol 20 | ;;namespaces. Working on metadata and 21 | ;;reader support... 22 | 23 | (def v [1 2 3]) 24 | 25 | ;;some core protocol stuff... 26 | (clclojure.base::-conj v 4) 27 | ;;=> [1 2 3 4] 28 | 29 | (clclojure.base::-count v) 30 | ;;=> 3 31 | 32 | ;;fn - single-arity, no meta, no destructuring 33 | (def f (fn [x] (+ x 2))) 34 | 35 | ;;naive defn (no meta, no destructuring) 36 | (defn plus [x y] (+ x y)) 37 | 38 | (plus 1 2) 39 | ;;=> 3 40 | 41 | (defprotocol IBlah 42 | (blah [obj])) 43 | 44 | (defprotocol IBlee 45 | (blee [obj msg])) 46 | 47 | (deftype blather [name x] 48 | IBlah 49 | (blah [this] (str :blaH! name x))) 50 | 51 | (def the-blather (->blather :joinr "blech!!!")) 52 | 53 | (blah the-blather) 54 | ;;gives us ":BLAH!:JOINRblech!!!" 55 | 56 | ;;reify works....under current single arity limitations 57 | ;;we generate effectively an anonoymous, throwaway 58 | ;;CLOS class via deftype, letting deftype do the work.. 59 | 60 | ;;Note: we get warnings about being unable to find 61 | ;;the specializer class for the reified class, 62 | ;;need to check that out, may be missing a quote. 63 | ;;It works tho! 64 | (def the-blither 65 | (let [msg "HOHOHO, MEEERRRRYY REIFY"] 66 | (reify 67 | IBlah 68 | (blah [this] msg) 69 | IBlee 70 | (blee [this custom-msg] (str "custom! " custom-msg) )))) 71 | 72 | (blah the-blither) 73 | ;;gives us "HOHOHO, MEEERRRRYY REIFY" 74 | (blee the-blither "Honk!") 75 | ;;gives us "custom! Honk!" 76 | 77 | ;;protocols are just structs.... 78 | IBlah 79 | ;; #S(CLCLOJURE.PROTOCOLS::PROTOCOL 80 | ;; :NAME IBLAH 81 | ;; :FUNCTIONS (BLAH) 82 | ;; :SATISFIER # 85 | ;; :MEMBERS (REIFY1 BLATHER)) 86 | 87 | ;;On the cusp of greatness, but still 88 | ;;debuggin multiple arities! So close.... 89 | ;; (defn idx [v n] 90 | ;; (-nth v n)) 91 | 92 | 93 | ;;quasiquoting of literals now works... 94 | (defparameter quasi-form 95 | `[,@(list 1 2 ) ,x ,@(list :literal x :hah) 96 | [,x ,x ,x [x] 97 | {:a 2 98 | :b {:unquote ,x} 99 | :c {:quoted x}}]]) 100 | 101 | ;;[1 2 2 :LITERAL 2 :HAH [2 2 2 [X] {:C {:QUOTED X} :B {:UNQUOTE 2} :A 2}]] 102 | 103 | (let [x 2 104 | y `[1 ,x 2 [3 4 ,@[1 2]]]] 105 | y) 106 | 107 | ;;coming soon... 108 | ;;meta, destrutcturing, core clojure functions 109 | ;;per cljs, and more... 110 | 111 | ;;loop/recur (maybe not necessary since we can compile 112 | ;;on most implementations and get TCO) 113 | 114 | 115 | ;;Working on variadic protocol implementations, 116 | ;;will be addressed in clclojure.variadic 117 | (defprotocol IMany 118 | (many [obj] [obj msg])) 119 | 120 | ;;currently broken, close to fixing... 121 | (deftype manytest [] 122 | IMany 123 | (many [this] :one!) 124 | (many [this item] item)) 125 | 126 | 127 | ;;error in vector, vector args aren't being evaluated. 128 | (defn test-my-scope [] 129 | (let 130 | [hello :hello 131 | world :world 132 | k 2 133 | inc (fn [x] (+ x 1)) 134 | add (fn [x y] (+ x y)) 135 | tbl (let [tbl (make-hash-table)] 136 | (setf (gethash :hello tbl) "World") 137 | (setf (gethash :world tbl) "Hello") 138 | (setf (gethash :k tbl) k) 139 | tbl)] 140 | (list (hello tbl) 141 | (world tbl) 142 | (add (inc 39) k) 143 | (gethash :k tbl) ;;(:k tbl);;WIP 144 | ))) 145 | 146 | ;;EXAMPLE> (test-my-scope) 147 | ;;("World" "Hello" 42 2) 148 | 149 | ;;named functions don't currently parse! 150 | ;;This fails too, we have some jank with the 151 | ;;reader when we're inside a macro... 152 | ;;Need to fix the quasi quoter, should 153 | ;;be in backtick.lisp. 154 | (defn test-arities [] 155 | (let [sum (fn ([x] x) 156 | ([x y] (+ x y)) 157 | ([x y &rest zs] (reduce #'+ zs :initial-value (+ x y))))] 158 | (clclojure.pvector:persistent-vector 159 | (sum 1) 160 | (sum 1 2) 161 | (sum 1 2 3 4 5 6)))) 162 | -------------------------------------------------------------------------------- /dustbin/keywordfunc.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :clclojure.keywordfunc 2 | (:use :common-lisp ;:clclojure.base 3 | :common-utils) 4 | ;; (:shadowing-import-from :clclojure.base 5 | ;; :deftype :let) 6 | (:export :keyfn? :key-accessor :->keyaccess :keyaccess-func :keyaccess-key :with-keyfn)) 7 | (in-package :clclojure.keywordfunc) 8 | 9 | (defparameter keyfns (make-hash-table)) 10 | (defun keyfn? (k) 11 | (gethash k keyfns)) 12 | 13 | ;;this is the general template for implementing 14 | ;;keyword access... 15 | ;; (defun :a (m) (gethash :a m)) 16 | ;; (defun (setf :a) (new-value m) 17 | ;; (setf (gethash :a m) 18 | ;; new-value)) 19 | 20 | (defun key-accessor (k) 21 | (let ((m (gensym "map")) 22 | (v (gensym "newval"))) 23 | `(progn (defun ,k (,m) (gethash ,k ,m)) 24 | (defun (,'setf ,k) (,v ,m) 25 | (,'setf (,'gethash ,k ,m) ,v)) 26 | ;(,'setf (gethash ,k keyfns) ,k) 27 | ))) 28 | 29 | ;;for localized keyaccess, i.e. inside 30 | ;;lets and friends.... 31 | (defclass keyaccess () 32 | ((key :initarg :key :accessor keyaccess-key) 33 | (func :accessor keyaccess-func)) 34 | (:metaclass sb-mop::funcallable-standard-class)) 35 | 36 | (defmethod initialize-instance :after ((obj keyaccess) &key) 37 | (with-slots (key func) obj 38 | (setf func (lambda (ht) 39 | (gethash key ht))) 40 | (sb-mop::set-funcallable-instance-function 41 | obj func) 42 | (eval (key-accessor key)) 43 | (setf (gethash key keyfns) obj) 44 | )) 45 | 46 | ;;keyaccessors print like keywords. 47 | (defmethod print-object ((obj keyaccess) stream) 48 | (prin1 (keyaccess-key obj) stream)) 49 | 50 | (defun ->keyaccess (k) 51 | (or 52 | (gethash k keyfns) 53 | (make-instance 'keyaccess :key k))) 54 | 55 | ;;now, to get the last step of "real" keyword access, we need to 56 | ;;detect when keyword literals used, and create keyword accessors for 57 | ;;them. One dirty way of doing that, is to use a reader macro for 58 | ;;keywords, and ensure that every single keyword that's read has a 59 | ;;commensurate keyaccess obj created. 60 | 61 | ;;That's effective, maybe not efficient, since we're duplicating our 62 | ;;keywords everywhere. A more efficient, but harder to implement, 63 | ;;technique is to macroexpand and walk the code inside a unified-let*. In 64 | ;;theory, we can detect any forms used in the function position, and 65 | ;;if they're keywords, compile them into keyword accessors. 66 | 67 | (defmacro with-keyfn (expr) 68 | (let ((k (first expr)) 69 | ) 70 | (if (keywordp k) 71 | (if (not (keyfn? k)) 72 | (progn (format nil "adding keyword access for: ~a " k ) 73 | (eval (key-accessor k)) 74 | `,expr)) 75 | `,expr))) 76 | 77 | 78 | ;;dumb testing 79 | ;; (defparameter ht (make-hash-table)) 80 | 81 | ;; (with-keyfn (:a ht)) 82 | ;; (with-keyfn (:b ht)) 83 | 84 | ;; (setf (:a ht) :bilbo) 85 | ;; (setf (:b ht) :baggins) 86 | 87 | ;; (with-keyfn (:a ht)) 88 | ;; (with-keyfn (:b ht)) 89 | 90 | 91 | -------------------------------------------------------------------------------- /dustbin/lexical.lisp: -------------------------------------------------------------------------------- 1 | ;;Defining lexically scoped, unified variables and 2 | ;;functions with keyword access. 3 | (defpackage :clclojure.lexical 4 | (:use :common-lisp :clclojure.keywordfunc 5 | :common-utils) 6 | (:export :unified-let*)) 7 | (in-package :clclojure.lexical) 8 | 9 | ;;if the arg can be construed as a function, 10 | ;;the lexical symbol should be unified.. 11 | 12 | ;; (defmacro unify-binding (var) 13 | ;; `(cond ((functionp ,var) 14 | ;; (setf (symbol-function (quote ,var)) 15 | ;; ,var)) 16 | ;; ((keywordp ,var) 17 | ;; (if (not (keyfn? ,var)) 18 | ;; (progn (pprint (format nil "adding keyword access for: ~a " k )) 19 | ;; (eval (key-accessor ,var))))))) 20 | 21 | ;;we need to use let and flet instead of this... 22 | 23 | ;; (defmacro unify-binding (var) 24 | ;; `(cond ((functionp ,var) 25 | ;; (setf (symbol-function (quote ,var)) 26 | ;; ,var)) 27 | ;; ((keywordp ,var) 28 | ;; (if (not (keyfn? ,var)) 29 | ;; (progn (pprint (format nil "adding keyword access for: ~a " ,var )) 30 | ;; ;;(eval (key-accessor ,var)) 31 | ;; (setf (symbol-function (quote ,var)) 32 | ;; (->keyaccess ,var)) 33 | ;; ))))) 34 | 35 | ;;a couple of notes on evaluation and symbol/function namespaces, 36 | ;;including lexical scope.... 37 | ;;we have a few cases to cover... 38 | ;;if we want to cover every possible case and get a lisp1, 39 | ;;in the lexical case, we are relegated to using a combination 40 | ;;of let and flet on all the symbols 41 | ;; (let* ((g (->keyaccess :a)) 42 | ;; (lookup (->keyaccess :b))) 43 | ;; (labels ((g (arg) (funcall (keyaccess-func g) arg)) 44 | ;; (lookup (arg) (funcall (keyaccess-func lookup) arg))) 45 | ;; ;;(mapcar f (list keyfns keyfns)) 46 | ;; (pprint (list :obj lookup :fn (g keyfns))))) 47 | 48 | ;;this is an example of how we can play with lexical binds... 49 | ;;In the extreme case, we may not know what any types are, 50 | ;;which means they're functions or objects.... 51 | ;; (defun some-fn (z) 52 | ;; (let* ((g (lambda (x) (+ x 5))) ;;an actual function object... 53 | ;; (lookup (->keyaccess :b)) 54 | ;; (z (if (keywordp z) 55 | ;; (->keyaccess z) 56 | ;; z))) ;;keyword access function object... 57 | ;; (labels (;;general implementation of fn 58 | ;; (g (&rest args) (apply g args)) 59 | ;; ;;specific implementation for kw lookup.. 60 | ;; (lookup (arg) (funcall (keyaccess-func lookup) arg)) 61 | ;; (z (&rest args) (apply z args)) 62 | ;; ) 63 | ;; (pprint (list :obj g :fn (g 2) :keyaccess lookup 64 | ;; :z z :z-lookup (z keyfns) 65 | ;; (mapcar (lambda (x) (list :type x (type-of x))) 66 | ;; (list g lookup z))))))) 67 | 68 | ;;the only things that we know... are keywords, or fn forms bindings 69 | ;;are already in pairs... 70 | 71 | ;;Scrape the bindings to let*, and if we find keywords, 72 | ;;create an alist that associates the keyword to an 73 | ;;expression that defines a labels lexical function 74 | ;;for the keyword accessor. We compute/construct 75 | ;;a keyaccessor at compile time, and though it's 76 | ;;funcallable, we lookup its associated function 77 | ;;for use (and efficiency). We then provide 78 | ;;a simple function wrapper that invokes the keyword 79 | ;;fn (bear in mind, this is setfable). 80 | (EVAL-WHEN (:compile-toplevel :load-toplevel :execute) 81 | (defun keyword-accessors (bindings) 82 | (let ((arg (gensym "lookup"))) 83 | (mapcar (lambda (lr) 84 | (destructuring-bind (l r) lr 85 | (let ((f (keyaccess-func (->keyaccess r)))) 86 | (list r `(,l (,arg) (funcall (->keyaccess ,r) ,arg)))))) 87 | (filter (lambda (lr) (keywordp (second lr))) bindings)))) 88 | 89 | ;;we use a generic apply here... collect all the args into a list and 90 | ;;apply. In clojure, there's some cost to that. Dunno what the 91 | ;;overhead is in CL. Also, if we "know" anything about the function, 92 | ;;we may be able to do some analysis and compile a more efficient 93 | ;;binding form (i.e. known number of args in the lambda. or simple 94 | ;;funcall... 95 | 96 | ;;There's some question about how much we know about the parameters at 97 | ;;runtime (specifically for let bindings). For certain classes of 98 | ;;lexical environments, we may be a-okay doing significant analysis of 99 | ;;what's involved in the let (case in point: if it's a lambda or a 100 | ;;known function we have meta on, we can derive types / args). Thats 101 | ;;a future optimization... 102 | 103 | ;;Note: if we don't refer to the lexical vars (NOT fns) for the 104 | ;;keywords, we end up with a slew of style warnings, since they don't 105 | ;;appear to be used (they are used for the lexical keyaccessors 106 | ;;though). To prevent this, we define a dummy function (never 107 | ;;invoked) that builds a list composed from the symbol-values. For 108 | ;;now, it's convenient. I may revisit this to see if we can detect if 109 | ;;the symbols aren't validly used... 110 | 111 | ;;we get compiler complaints with this if we don't... 112 | 113 | (defun functionize-bindings (bindings) 114 | (let* ((kwalist (keyword-accessors bindings)) 115 | (vars (mapcar (lambda (lr) (first (second lr))) kwalist)) 116 | (dummy (gensym "dummyfn"))) 117 | (cons `(,dummy () (list :this-prevents-warnings-nothing-else 118 | ,@vars)) 119 | (mapcar (lambda (lr) 120 | (destructuring-bind (l r) lr 121 | (if (keywordp r) 122 | (second (assoc r kwalist)) 123 | `(,l (,'&rest ,'args) (apply ,l ,'args))))) 124 | bindings))))) 125 | 126 | ;;so at the lexical level, we need to analyze the bindings. 127 | ;;determine if an item is a function (or an applicable object like 128 | ;;a keyword), and create matching labels for them... 129 | 130 | ;;this acts like let*, except it allows bindings that may be functions 131 | ;;or things that can act like functions -> keywords. Everything else 132 | ;;should be covered by a funcallable object... We unify the 133 | ;;symbol-value and symbol-function namespaces in the lexical context, 134 | ;;detecting the need to generate keyword accessors. 135 | (defmacro unified-let* (bindings &rest body) 136 | `(let* (,@bindings) 137 | (labels (,@ (functionize-bindings bindings) 138 | ) 139 | ,@body))) 140 | 141 | ;;a simple test function to tie everything together. 142 | (defun test-my-scope () 143 | (unified-let* ((hello :hello) ;;we create (or lookup cached) keyaccess funcallable objects 144 | (world :world) ;;when we have literal keywords bound to symbols. 145 | (k 2) 146 | (inc (lambda (x) (+ x 1))) 147 | (add (lambda (x y) (+ x y))) 148 | (tbl (unified-let* ((tbl (make-hash-table))) 149 | (setf (gethash :hello tbl) "World") 150 | (setf (gethash :world tbl) "Hello") 151 | (setf (gethash :k tbl) k) 152 | tbl))) 153 | (list (hello tbl) 154 | (world tbl) 155 | (add (inc 39) k) 156 | ;;(:k tbl) ;;doesn't work without some extra macro magic... 157 | (funcall (->keyaccess :k) tbl) ;;it will look like this behind the scenes. 158 | ))) 159 | 160 | ;;LEXICAL> (test-my-scope) 161 | ;;("World" "Hello" 42 2) ;;works! 162 | -------------------------------------------------------------------------------- /dustbin/literals.lisp: -------------------------------------------------------------------------------- 1 | (defpackage clclojure.literals 2 | (:use :common-lisp 3 | :clclojure.eval 4 | :clclojure.pvector 5 | :clclojure.cowmap)) 6 | (in-package :clclojure.literals) 7 | ;;Data Literal Eval Semantics 8 | 9 | (EVAL-WHEN (:compile-toplevel :load-toplevel :execute) 10 | (clclojure.eval:enable-custom-eval) 11 | ;;(eval [x y z]) => (vector (eval x) (eval y) (eval z)) 12 | ;;this is somewhat inefficient since we're not exploiting 13 | ;;chunks, but good enough for proof of concept. We do 14 | ;;have chunks, fyi. 15 | (defmethod custom-eval ((obj pvec)) 16 | (vector-map (lambda (x) (eval x)) obj)) 17 | 18 | (defmethod custom-eval ((obj subvector)) 19 | (vector-map (lambda (x) (eval x)) obj)) 20 | 21 | ;;(map {x y j k} => (persistent-map (eval x) (eval y) (eval j) (eval k)) 22 | (defmethod custom-eval ((obj cowmap)) 23 | (reduce (lambda (acc kv) 24 | (destructuring-bind (k v) kv 25 | (map-assoc acc (eval k) (eval v)))) (map-seq obj) :initial-value (empty-map))) 26 | ) 27 | -------------------------------------------------------------------------------- /dustbin/methoderr.lisp: -------------------------------------------------------------------------------- 1 | (defgeneric blah (obj)) 2 | 3 | (defparameter *global-msg* "global!") 4 | 5 | (let ((local-msg "local1!")) 6 | (progn 7 | (defclass test1 () ()) 8 | (defmethod blah ((obj test1)) local-msg))) 9 | 10 | (blah (make-instance 'test1)) 11 | 12 | (let [local-msg "local2!"] 13 | (progn 14 | (defclass test2 () ()) 15 | (defmethod blah ((obj test2)) local-msg))) 16 | 17 | 18 | (def x 19 | (let [local-msg "local3!"] 20 | (progn 21 | (defclass test3 () ()) 22 | (defmethod blah ((obj test3)) local-msg)))) 23 | 24 | (blah (make-instance 'test3)) 25 | 26 | (defprotocol IBlee (blee [this])) 27 | (def result 28 | (let [local-msg "local4!"] 29 | (progn 30 | (defclass test4 () ()) 31 | (eval '(DEFMETHOD BLEE ((THIS TEST4)) LOCAL-MSG))))) 32 | 33 | 34 | (defgeneric blah (obj)) 35 | (defclass test () ()) 36 | 37 | (let ((local-msg "local1!")) 38 | (DEFMETHOD BLAH ((THIS TEST)) LOCAL-MSG)) 39 | 40 | ;;=>(blah (make-instance 'test)) 41 | ;;"local1!" 42 | 43 | (let ((local-msg "local2!")) 44 | (eval (list 'DEFMETHOD 'BLAH '((THIS TEST4)) LOCAL-MSG))) 45 | -------------------------------------------------------------------------------- /dustbin/pmap.lisp: -------------------------------------------------------------------------------- 1 | ;This is an implementation of Clojure's 2 | ;persistent map for Common Lisp. 3 | (defpackage :clclojure.pmap 4 | (:use :common-lisp) 5 | (:export :persistent-map 6 | :empty-map? 7 | :pmap-count 8 | :pmap-map 9 | :pmap-reduce) 10 | (:shadow :assoc 11 | :find)) 12 | ; :pmap-chunks 13 | ; :pmap-element-type 14 | ; :pmap-assoc 15 | ; :pmap-nth)) 16 | (in-package clojure.pmap) 17 | 18 | ;Original from Stack Overflow, with some slight modifications. 19 | (defun |brace-reader| (stream char) 20 | "A reader macro that allows us to define persistent maps 21 | inline, just like Clojure." 22 | (declare (ignore char)) 23 | `(persistent-map ,@(read-delimited-list #\] stream t))) 24 | (set-macro-character #\{ #'|brace-reader|) 25 | (set-syntax-from-char #\} #\)) 26 | 27 | 28 | ;;Currently deferred... 29 | ;;For now, we'll just use a COW map implementation 30 | ;;i.e. wrap a hashtable and copy its contents... 31 | 32 | 33 | (define-condition not-implemented (error) 34 | ((text :initarg :text :reader text))) 35 | 36 | ;utility functions 37 | 38 | ;Persistent maps require a lot of array copying, and 39 | ;according to the clojure implementation, bit-twiddling. 40 | 41 | ;porting from Spiewak's excellent blog post, 42 | ;which is a port from Clojure's implementation. 43 | (defconstant +branches+ 32) ;use a 32-way trie.... 44 | ;a bytespec is like a window.. 45 | ;it's a user-defined set of continugous bits in an integer 46 | ;use (byte width position) to define the window... 47 | (defconstant +bit-width+ 5) 48 | (defconstant +mask+ (byte +bit-width+ 0)) ;denotes [00000] with "weights" [2^4 2^3 2^2 2^1 2^0] 49 | 50 | (defun >>> (i n) 51 | "Shift integer i by n bits to the right." 52 | (ash i (* -1 n))) 53 | 54 | (defun <<< (i n) 55 | "Shift integer i by n bits to the left." 56 | (ash i n)) 57 | 58 | (defun last-five-bits (n) 59 | "Helper to mask everything but the 5 least-significant bits." 60 | (mask-field +mask+ n)) 61 | 62 | (defun mask (hash shift) 63 | "Helper, used by maps. Maps a hash into a local index at 64 | given level in the trie." 65 | (last-five-bits (>>> hash shift))) 66 | 67 | (defun bit-pos (hash shift) 68 | "Helper to compute the bit-position of n from a mask. This provides 69 | a mapping to the nth bit" 70 | (<<< 1 (mask hash shift))) 71 | 72 | (defun index (n) 73 | "Given an index into a hash, which represents a sparse mapping of values 74 | from [0 31] to n children, we can find out which child the index represents 75 | by using a logical count of the 1 bits in n." 76 | (logcount (1- n))) 77 | 78 | (define-condition index-out-of-bounds (error) 79 | ((text :initarg :text :reader text))) 80 | 81 | (defun copy-vector (array n &key 82 | (element-type (array-element-type array)) 83 | (fill-pointer (and (array-has-fill-pointer-p array) 84 | (fill-pointer array))) 85 | (adjustable (adjustable-array-p array))) 86 | "Returns an undisplaced copy of ARRAY, with same fill-pointer and 87 | adjustability (if any) as the original, unless overridden by the keyword 88 | arguments. " 89 | (let* ((dimensions (incf (first (array-dimensions array)) n)) 90 | (new-array (make-array dimensions 91 | :element-type element-type 92 | :adjustable adjustable 93 | :fill-pointer fill-pointer))) 94 | (dotimes (i (array-total-size array)) 95 | (setf (row-major-aref new-array i) 96 | (row-major-aref array i))) 97 | new-array)) 98 | 99 | ;Persistent Map definition: 100 | 101 | ;A persistent hashmap is a small structure that points to a root node. 102 | ;It also contains information about the underlying trie, such as null 103 | ;keys, the count of elements, etc. 104 | (defstruct pmap (count 0) (root nil) (has-null nil) (null-value nil)) 105 | (defun ->pmap (count root has-null null-value) 106 | (make-instance pmap :count count 107 | :root root 108 | :has-null has-null 109 | :null-value null-value)) 110 | (defconstant +empty-map+ (->pmap)) 111 | (defun empty-map () +empty-map+) 112 | 113 | ;The INode interface is crucial. We dispatch based on the node types... 114 | ;We'll implement the interface as a set of generic functions. 115 | 116 | (defgeneric assoc (nd shift hash key val &optional addedLeaf)) 117 | (defgeneric without (nd shift hash key)) 118 | (defgeneric find (shift hash key)) 119 | ;(defgeneric find(shift hash key notFound)) 120 | (defgeneric nodeSeq (nd)) 121 | ; assoc(AtomicReference edit, int shift, int hash, Object key, Object val, Box addedLeaf); 122 | ;INode without(AtomicReference edit, int shift, int hash, Object key, Box removedLeaf); 123 | (defgeneric kvreduce (f init)) 124 | ;(defgeneric fold (combinef reducef fjtask fjfork fjjoin)) 125 | 126 | ;;note -> clojure's implementation uses an object array... 127 | ;;so that the distinction between nodes and data is blurred. 128 | ;;a node is just a thread-safe wrapper around an object array. 129 | ;;in CL, this is just an array without an initial type arg. 130 | (defun make-data (&key (branches +branches+) (element-type t) (initial-element nil)) 131 | "Standard constructor for a node in our hash trie." 132 | (if (and (null initial-element) 133 | (not (eq element-type t))) 134 | (make-array branches :element-type element-type) 135 | (make-array branches :element-type element-type :initial-element initial-element))) 136 | 137 | (defun make-node () (make-data)) 138 | (defun make-indexed-node () 139 | (make-data :branches +indexed-branches+)) 140 | 141 | ;define implementations for different node types: 142 | 143 | ;-Type identifier for empty nodes, i.e. empty maps. 144 | ;empty-node 145 | ;(defstruct empty-node 146 | 147 | ;-Type identifier for nodes with a single value. 148 | ;-This is optimized away in the clojure java implementation... 149 | ;leaf-node 150 | 151 | ;-Type identifier for nodes with 16 key/vals (full or array nodes). 152 | (defstruct array-node count (nodes (make-data))) 153 | (defun ->array-node (count nodes) 154 | (make-array-node :count count :nodes nodes)) 155 | 156 | ;-Type identifier for nodes that project a 32-bit index, the 157 | ;-bitmap, onto an array with less than 32 elements. 158 | ;bitmapindexed-node 159 | (defconstant +indexed-branches+ 16) ;indexes contained 8 keyval pairs. 160 | (defstruct indexed-node (bitmap 0) (nodes (make-data :branches +indexed-branches+)) ) 161 | (defun ->indexed-node (bitmap nodes) 162 | (make-indexed-node :bitmap bitmap :nodes nodes)) 163 | (defconstant +empty-indexed-node+ (make-indexed-node)) 164 | (defun empty-indexed-node () +empty-indexed-node+) 165 | 166 | (declaim (inline key-idx val-idx key-at-idx val-at-idx)) 167 | (defun key-idx (idx) 168 | "Return the offset key of an index" 169 | (* 2 idx)) 170 | (defun val-idx (idx) 171 | "Return the offset value of an index" 172 | (1+ (* 2 idx))) 173 | 174 | 175 | (defun equiv (x y) 176 | "Generic equality predicate." 177 | (error 'not-implemented)) 178 | 179 | (defun key-at-idx (idx nodes) 180 | "Fetches the offset key from an array 181 | packed like a propertylist, key/val/key/val/..." 182 | (aref nodes (* 2 idx))) 183 | 184 | (defun val-at-idx (idx nodes) 185 | "Fetches the offset value from an array 186 | packed like a propertylist, key/val/key/val/..." 187 | (aref nodes (1+ (* 2 idx)))) 188 | 189 | (defun pairs (xs) 190 | "Aux function that converts a list of xs into 191 | a list of pairs." 192 | (do ((acc (list)) 193 | (remaining xs (rest (rest remaining)))) 194 | ((null remaining) (nreverse acc)) 195 | (let ((x (first remaining)) 196 | (y (second remaining))) 197 | (when (and x y) 198 | (push (list x y) acc))))) 199 | 200 | (defun assoc-array (arr idx k v) 201 | (progn (setf (aref arr (key-idx idx)) k) 202 | (setf (aref arr (val-idx idx)) v))) 203 | 204 | (defun hash (o) 205 | "Generic hash function." 206 | (error 'not-implemented)) 207 | 208 | (defun remove-pair (array idx) 209 | "Auxillary function to drop pairs from an array 210 | where the pairs are packed akin to a plist, ex. 211 | key/val/key/val....returns a new, smaller array 212 | with the pair removed." 213 | (error 'not-implemented) 214 | (cond ((> idx (- (1- (array-total-size array)) 2)) 215 | (error 'index-out-of-bounds)) 216 | ((and (= (array-total-size array) 2) (= idx 0)) 217 | nil) 218 | (t 219 | (let* ((dimensions (decf (first (array-dimensions array)) 2)) 220 | (new-array (make-array dimensions 221 | :element-type (array-element-type array) 222 | :fill-pointer (and (array-has-fill-pointer-p array) 223 | (fill-pointer array)) 224 | :adjustable (adjustable-array-p array)))) 225 | (loop for i from 0 to (1- idx) 226 | do (assoc-array new-array i (key-at-idx i array) (val-at-idx i array))) 227 | (loop for i from (1+ idx) to (- (array-total-size new-array) 2) 228 | do (assoc-array new-array (1- i) (key-at-idx i array) (val-at-idx i array))) 229 | new-array)))) 230 | 231 | (defun insert-pair (array idx k v) 232 | "Auxillary function to drop pairs from an array 233 | where the pairs are packed akin to a plist, ex. 234 | key/val/key/val....returns a new, smaller array 235 | with the pair removed." 236 | (error 'not-implemented) 237 | (cond ((> idx (1- (- (array-total-size array) 2))) 238 | (error 'index-out-of-bounds)) 239 | (t 240 | (let* ((dimensions (incf (first (array-dimensions array)) 2)) 241 | (new-array (make-array dimensions 242 | :element-type (array-element-type array) 243 | :fill-pointer (and (array-has-fill-pointer-p array) 244 | (fill-pointer array)) 245 | :adjustable (adjustable-array-p array)))) 246 | (loop for i from 0 to (1- idx) 247 | do (assoc-array new-array i (key-at-idx i array) (val-at-idx i array))) 248 | (assoc-array new-array idx k v) 249 | (when (< idx (1- (/ (array-total-size array) 2))) 250 | (loop for i from idx to (1- (/ (array-total-size new-array) 2)) 251 | do (assoc-array new-array (1+ i) (key-at-idx i array) (val-at-idx i array)))) 252 | new-array)))) 253 | ;; INode createNode(int shift, Object key1, Object val1, int key2hash, Object key2, Object val2) { 254 | ;; int key1hash = hash(key1); 255 | ;; if(key1hash == key2hash) 256 | ;; return new HashCollisionNode(null, key1hash, 2, new Object[] {key1, val1, key2, val2}); 257 | ;; Box _ = new Box(null); 258 | ;; AtomicReference edit = new AtomicReference(); 259 | ;; return BitmapIndexedNode.EMPTY 260 | ;; .assoc(edit, shift, key1hash, key1, val1, _) 261 | ;; .assoc(edit, shift, key2hash, key2, val2, _) 262 | ; 263 | (defun create-node (shift key1 val1 key2hash key2 val2) 264 | "Generic function to create nodes....I need a better 265 | explanation. Also, the box var may not be necessary. 266 | I have to see how it's used..." 267 | (let ((key1hash (hash key1))) 268 | (if (= key1hash key2hash) 269 | ;record the hash collision with a new collision node, these will chain. 270 | (->collision-node key1hash 2 (vector key1 val1 key2 val2)) 271 | (let ((box (list))) ;else assoc both values into an empty indexed node. 272 | (assoc (assoc (empty-indexed-node) shift key1hash key1 val1 box) 273 | shift key2hash key2 val2 box))))) 274 | 275 | (defun clone-and-set (arr &rest kvps) 276 | "Aux function that clones an array and 277 | sets the element at idx = to v, where 278 | idx and v are drawn from the list kvps." 279 | (let ((acc (copy-vector arr 0))) 280 | (loop for (idx v) in (pairs kvps) 281 | do (setf (aref acc idx) v) 282 | finally (return acc)))) 283 | 284 | (declaim (inline bit-set?)) 285 | (defun bit-set? (bitmap i) 286 | "Determines if the ith bit is set in bitmap." 287 | (not (zerop (logand (>>> bitmap i) 1)))) 288 | 289 | (defun indexed-array->full-array (nodes bitmap shift hash key val addedleaf) 290 | "Projects an indexed array, indexed by a 32-bit map, 16 (unknown) 291 | bits of which indicate the presence of a key in an an underlying 292 | 32-element assoc array, onto an full array. The full array is 293 | a direct mapping of a 32-bit key, projected onto a 32 element 294 | array of nodes, by masking all but the last 5 bits. This is 295 | basically an optimization, so that we use indexed nodes while 296 | the node is sparse, when the keys are <= 16, then shift to a 297 | node with no intermediate bit mapping." 298 | (let ((newnodes (make-data)) ;create the 32 element array for the arraynode. 299 | (jdx (mask hash shift)) ;set the index for the element we're adding. 300 | (j 0)) 301 | (progn (setf (aref newnodes jdx) ;initialze the newly added node. 302 | (assoc (empty-indexed-node) 303 | (+ 5 shift) hash key val addedleaf)) 304 | (loop for i from 0 to 32 ;traverse the bitmap, cloning... 305 | do (when (bit-set? bitmap i) ;bit i is stored at j 306 | (if (null (aref nodes j)) 307 | (setf (aref newnodes i) (aref nodes (1+ j))) 308 | (assoc (empty-indexed-node) 309 | (+ 5 shift) 310 | (hash (aref nodes j)) 311 | (aref nodes j) 312 | (aref nodes (1+ j)) 313 | addedleaf)) 314 | (incf j 2))) 315 | newnodes))) 316 | 317 | 318 | (defun indexed-node->array-node (nd shift hash key val addedleaf) 319 | "Projects an indexed node, indexed by a 32-bit map, 16 (unknown) 320 | bits of which indicate the presence of a key in an an underlying 321 | 32-element assoc array, onto an array node. The array node is 322 | a direct mapping of a 32-bit key, projected onto a 32 element 323 | array of nodes, by masking all but the last 5 bits. This is 324 | basically an optimization, so that we use indexed nodes while 325 | the node is sparse, when the keys are <= 16, then shift to a 326 | node with no intermediate bit mapping." 327 | (with-slots (bitmap nodes) nd 328 | (->array-node (1+ (logcount bitmap)) 329 | (indexed-array->full-array nodes bitmap shift 330 | hash key val addedleaf)))) 331 | 332 | ;Partially implemented. 333 | ;; (defmethod assoc ((nd indexed-node) shift hash key val addedLeaf) 334 | ;; (with-slots (bitmap nodes) nd 335 | ;; (let ((b (bit-pos hash shift)) 336 | ;; (idx (index b)) 337 | ;; (exists? (not (zerop (logand bitmap b))))) 338 | ;; (if exists? 339 | ;; (let ((k (key-at-idx idx nodes)) 340 | ;; (v (val-at-idx idx nodes))) 341 | ;; (cond ((null k) 342 | ;; (let ((newnode (assoc v (+ 5 shift) hash key val addedleaf))) 343 | ;; (if (eq val-at-idx newnode) 344 | ;; nd ;no node to add to null key. 345 | ;; ;actually have val associated with null, causes changed. 346 | ;; (->indexed-node bitmap (clone-and-set nodes (val-idx idx) newnode))))) 347 | ;; ((equiv key k) ;key exists. 348 | ;; (if (eq v val) 349 | ;; nd ;no change 350 | ;; ;value changed 351 | ;; (->indexed-node bitmap (clone-and-set nodes (val-idx idx) val)))) 352 | ;; (t 353 | ;; (->indexed-node bitmap (clone-and-set nodes (key-idx idx) nil 354 | ;; (val-idx idx) (create-node (+ 5 shift) k v hash key val))))) 355 | ;; ) 356 | ;; (if (>= (logcount bitmap) +indexed-branches+) 357 | ;; ;create an array node, or full node, if the number of on-bits is excessive. 358 | ;; (indexed-node->array-node nd shift hash key val addedleaf) 359 | ;; (let ((newarray (copy-vector nodes 2))) 360 | ;; (progn ( 361 | 362 | ;; )))))) 363 | 364 | 365 | ;-Type identifier for nodes that have a direct correspondence 366 | ;-between a 5 bit integer hash and an entry in the 32 element 367 | ;-node array. 368 | ;full-node 369 | 370 | 371 | ;-Type identifier for nodes that collide. Essentially, a 32 372 | ;-element array of nodes that have the same hash. I have an 373 | ;-idea of how this works using the 5 bit hashing scheme. 374 | ;collision-node 375 | (defstruct collision-node hash count nodes) 376 | (defun ->collision-node (hash count nodes) 377 | (make-instance collision-node 378 | :hash hash 379 | :count count 380 | :nodes nodes)) 381 | 382 | (defconstant +empty-pvec+ (make-pvec)) 383 | (defun empty-vec () +empty-pvec+) 384 | (defun empty-vec? (v) (eq v +empty-pvec+)) 385 | 386 | (defgeneric vector-count (v) 387 | (:documentation 388 | "Fetches the count of items in the persistent vector.")) 389 | 390 | (defmethod vector-count ((v pvec)) 391 | (pvec-counter v)) 392 | 393 | (defun tail-end (n &optional (b +branches+)) 394 | "Given a count of items, n, where is the tail located in an integer 395 | hash? Note, this assumes a 5 bit encoding for levels in an 32-way 396 | trie. I might generalize this later..." 397 | (if (< n b) 398 | 0 399 | (<<< (>>> (1- n) +bit-width+) +bit-width+))) 400 | 401 | (defun tail-off (v) 402 | "Defines the integer index at which the tail starts." 403 | (tail-end (pvec-counter v) +branches+)) 404 | 405 | (defun count-tail (v) (length (pvec-tail v))) 406 | 407 | (defun find-node (rootnode shift idx) 408 | "Given a rootnode with child nodes, a bit-shift amount, and an index, 409 | traverses the rootnode's children for the node defined by idx." 410 | (if (<= shift 0) 411 | rootnode ;found our guy 412 | (find-node (aref rootnode (last-five-bits (>>> idx shift))) 413 | (- shift +bit-width+) idx))) 414 | 415 | (defun copy-path (root shift0 idx &optional (leaf-function #'identity)) 416 | "Copies the nodes from root to idx, returning a new root. If a leaf function 417 | is provided, it will be applied to the final node. If the path does not exist, 418 | intermediate structures WILL be created." 419 | (labels ((walk (rootnode shift) 420 | (if (zerop shift) 421 | (funcall leaf-function rootnode) 422 | (let ((childidx (last-five-bits (>>> idx shift))) 423 | (newnode (if (null rootnode) 424 | (make-node) 425 | (copy-vector rootnode 0)))) 426 | (progn (setf (aref newnode childidx) 427 | (walk (if (null rootnode) 428 | (make-node) 429 | (aref rootnode childidx)) 430 | (- shift +bit-width+))) 431 | newnode))))) 432 | (walk root shift0))) 433 | 434 | (defun insert-path (rootnode shift idx x) 435 | "Copies the path to the node at idx, replacing the value of the final node 436 | on the path, the address at idx, with value x." 437 | (copy-path rootnode shift idx 438 | #'(lambda (node) 439 | (progn (setf (aref node (last-five-bits idx)) x) 440 | node)))) 441 | 442 | (defgeneric get-node (v idx) 443 | (:documentation 444 | "Fetches the node (an object array) at index idx, from 445 | persistent vector v, where idx is 0-based. Currently assumes 446 | 5-bit encoding of integer keys for each level, thus 32 elements 447 | per level.")) 448 | 449 | (defmethod get-node ((v pvec) idx) 450 | (if (and (<= idx (pvec-counter v)) (>= idx 0)) 451 | (if (>= idx (tail-end (pvec-counter v) +branches+)) 452 | (pvec-tail v) 453 | (find-node (pvec-root v) (pvec-shift v) idx)) 454 | (error 'index-out-of-bounds))) 455 | 456 | (defgeneric nth-vec (v idx) 457 | (:documentation "Returns the nth element in a persistent vector.")) 458 | (defmethod nth-vec ((v pvec) idx) 459 | (aref (get-node v idx) (last-five-bits idx))) 460 | 461 | ;copy-vector should probably use displaced arrays. 462 | (defun conj-tail (v x) 463 | "Conjoins item x onto pvector v's tail node, returning a new pvector that 464 | uses the new tail, along with an incremented count." 465 | (let ((newtail (if (null (pvec-tail v)) 466 | (vector x) 467 | (let ((growntail (copy-vector (pvec-tail v) 1))) 468 | (progn (setf (aref growntail (1- (length growntail))) x) 469 | growntail))))) 470 | (make-pvec :root (pvec-root v) 471 | :tail newtail 472 | :shift (pvec-shift v) 473 | :counter (1+ (pvec-counter v))))) 474 | 475 | (defun new-path (shift node) 476 | "Given a node and an amount of initial 'shift', recursively builds 477 | a nested tree of nodes, currently 32-wide arrays, linked by the first element, 478 | with node at the logical 'bottom' of the tree, where shift = 0. This allows us 479 | to inject a node, with the required path structure, into the trie, if the path did 480 | not exist before. Typically used for inserting the tail into the pvector." 481 | (if (zerop shift) 482 | node 483 | (let ((newnode (make-node))) 484 | (progn (setf (aref newnode 0) 485 | (new-path (- shift +bit-width+) node)) 486 | newnode)))) 487 | -------------------------------------------------------------------------------- /dustbin/protocols.lisp: -------------------------------------------------------------------------------- 1 | ;;a simple implementation of clojure protocols, and deftype. 2 | ;;this will help with building libraries, particularly 3 | ;;the seq libraries. 4 | 5 | ;;If we can bolt on a few fundamental operations, we can take 6 | ;;advantage of the bulk of the excellent bootstrapped clojure 7 | ;;defined in the clojurescript compiler. 8 | (defpackage :clclojure.protocols 9 | (:use :common-lisp :common-utils :clclojure.reader :clclojure.pvector) 10 | (:export :defprotocol 11 | :extend-protocol 12 | :extend-type 13 | :satisfies? 14 | :protocol-exists? 15 | :list-protocols 16 | :clojure-deftype)) 17 | 18 | (in-package :clclojure.protocols) 19 | 20 | ;;aux 21 | ;;bootstrapping hack! 22 | (defun vector? (x) (typep x 'clclojure.pvector::pvec)) 23 | (defun vector-expr (x) 24 | (and (listp x) (eq (first x) 'persistent-vector))) 25 | 26 | ;;this keeps args in order....we nreverse all over the place. 27 | ;;Since we prototyped using lists, and now the vector 28 | ;;reader is working well, we're in the middle of migrating 29 | ;;to vectors. For now, we allow backwards compat with both 30 | ;;(perhaps allowing CL to define protocols in their native 31 | ;;tongue, I dunno). In the future, we'll enforce 32 | ;;vectors.... 33 | (defun as-list (xs) 34 | (if (vector? xs) (nreverse (vector-to-list xs)) 35 | (if (vector-expr xs) (rest xs) 36 | xs))) 37 | 38 | ;;changed this since we have lists now... 39 | (defun drop-literals (xs) 40 | (nreverse (filter (lambda (x) (not (or (literal? x) (stringp x)))) (as-list xs)))) 41 | 42 | ;;Note-> we need to add support for variadic functions, 43 | ;;and variadic protocols members. 44 | 45 | ;;protocols are used extensively, as is deftype. There are a 46 | ;;few additional data types that we need to provide. 47 | 48 | ;Protocol specifications take on the form below: 49 | ;(protocolname 50 | ; (function-name1 (args) &optional doc) 51 | ; function-name2 (args) &optional doc)) 52 | 53 | ;; (defparameter samplespec 54 | ;; '(ISeq 55 | ;; (next (coll) 56 | ;; "Gets the next element from the sequence") 57 | ;; (more (coll) 58 | ;; "Gets the rest of the sequence."))) 59 | 60 | 61 | 62 | (defun spec-name (protocolspec) 63 | (car protocolspec)) 64 | 65 | (defun spec-functions (protocolspec) 66 | (remove-if-not #'listp (as-list protocolspec))) 67 | 68 | ;;bombing out since we can't extend SEQUENCE to 69 | ;;our own types (thanks hyperspec!) 70 | ;;We can, however, enforce that one must use persistent 71 | ;;vectors....or....we can coerce the vectors to lists, which 72 | ;;are acceptable sequences.... 73 | (defun function-names (protocolspec) 74 | (mapcar #'first (spec-functions protocolspec))) 75 | 76 | (defun make-satisfier (protocolspec) 77 | "From a list of function specs, builds a function that compares a 78 | list of function specs to ensure both specifications have the same 79 | function names. If no function specs are provided, the identity 80 | function is returned." 81 | (let ((names (function-names protocolspec))) 82 | (if (null names) 83 | (lambda (x) 84 | (declare (ignore x)) 85 | t) 86 | (lambda (newspec) 87 | (null (set-difference names (function-names newspec))))))) 88 | 89 | ;a sample implementation for ISeqs... 90 | (comment 91 | (defparameter sampleimp 92 | '(ISeq 93 | (next (coll) (car coll)) 94 | (more (coll) (cdr coll))))) 95 | 96 | ;;From stack overflow. It looks like the compiler needs a hint if we're 97 | ;;defining struct/class literals and using them as constants. 98 | (EVAL-WHEN (:compile-toplevel :load-toplevel :execute) 99 | ;;A protocol is a name, a set of generic functions, and a set of 100 | ;;types that implement the protocol. 101 | (defstruct protocol name functions satisfier (members (list))) 102 | (defmethod make-load-form ((v protocol) &optional env) 103 | (declare (ignore env)) 104 | (make-load-form-saving-slots v))) 105 | 106 | (defun ->protocol (name functions &optional satisfier) 107 | (make-protocol :name name :functions functions :satisfier satisfier)) 108 | 109 | (defun protocol-to-spec (p) 110 | (with-slots (name functions) p 111 | (list name functions))) 112 | 113 | ;;We won't keep a central listing of protocols. They'll be first class objects, 114 | ;;as in Clojure on the JVM. 115 | 116 | ;Debating whether to keep this around, 117 | ;I may not need it... 118 | (defparameter *protocols* (make-hash-table :test #'eq)) 119 | ;Probably deprecated soon... 120 | (defun get-protocol (name) 121 | (gethash name *protocols*)) 122 | 123 | ;;we can replace this using CLOS. We just add a generic function that 124 | ;;tells us if an object satisfies a protocol. 125 | ;;like (satisfies-protocol? (protocol obj)) 126 | ;;Since protocols are actual objects (structs in this case), we call 127 | ;;(satisfies? the-protocol-obj the-obj) 128 | ;;which delegates to 129 | ;;((get-slot 'satisfier the-protocol-obj) the-obj) 130 | ;;So we let the protocol tell us if an object satisfies its protocol. 131 | 132 | ;;When we do defprotocol then, we add an implementation of 133 | 134 | (defun add-protocol-member (pname membername) 135 | "Identifies membername as an implementor of protocol 136 | pname" 137 | (multiple-value-bind (p exists?) (get-protocol pname) 138 | (when exists? 139 | (push membername (protocol-members p))))) 140 | 141 | ;Probably deprecated soon... 142 | (defun protocol-exists? (name) 143 | (not (null (get-protocol name)))) 144 | 145 | (defun drop-protocol (name) 146 | "Eliminates any bindings to the quoted protocol name, 147 | including generic functions." 148 | (if (protocol-exists? name) 149 | (let ((p (get-protocol name))) 150 | (progn (unintern (protocol-name p)) 151 | (dolist (n (protocol-functions p)) 152 | (unintern n)) 153 | (remhash name *protocols*))))) 154 | 155 | (defun list-protocols () 156 | "Lists all known protocols." 157 | (loop for k being the hash-keys in *protocols* collect k)) 158 | 159 | ;;we should cache this.... 160 | (defgeneric satisfies? (p x)) 161 | (defmethod satisfies? ((p protocol) x) 162 | (not (null (find (type-of x) (protocol-members p))))) 163 | 164 | (defmethod satisfies? ((p protocol) x) 165 | (not (null (find (type-of x) (protocol-members p))))) 166 | 167 | (define-condition protocol-exists (error) 168 | ((text :initarg :text :reader text))) 169 | 170 | (define-condition malformed-protocol (error) 171 | ((text :initarg :text :reader text))) 172 | 173 | (define-condition missing-implementations (error) 174 | ((text :initarg :text :reader text))) 175 | 176 | (define-condition name-collision (error) 177 | ((text :initarg :text :reader text))) 178 | 179 | 180 | ;when we add protocols, we just want to ensure that the 181 | ;right generic functions are implemented. 182 | ;We let Common Lisp sort out whether the generic functions 183 | ;are actually correct. 184 | (defun add-protocol (p) 185 | (with-slots (name) p 186 | (if (null (get-protocol name)) (setf (gethash name *protocols*) p) 187 | ; (error 'protocol-exists)))) 188 | (progn (print (format nil "Overwriting existing protocol ~A" name)) 189 | (drop-protocol `(quote ,name)) 190 | (setf (gethash name *protocols*) p))))) 191 | 192 | ;;We need to add the multiple-dispatch function that's in bootstrap at the moment. 193 | ;;A multiple-body protocol implementation could be... 194 | 195 | (defparameter proto-spec 196 | '(defprotocol ITough 197 | (get-toughness [x] [x y] 198 | "gets the toughness of x, or if x is compared to y, the relative toughness"))) 199 | 200 | ;;If we want to use generic functions to mirror single-dispatch implementations of 201 | ;;protocols, we have to allow for multiple-body functions. 202 | ;;So, there's probably a protocol dispatch function.. 203 | ;;Just like our fn macro... 204 | 205 | 206 | 207 | ;;If we have multiple specs, [x] [x y], in this case, we need a generic function 208 | ;;that dispatches based on the first arg of the spec. 209 | ;;Alternately....we can just use the fn body from before... 210 | ;;This only ever matters if there are multiple function bodies. If there's only one, 211 | ;;we're golden (that's the current situation). 212 | 213 | ;;note: dealing with reader-literals and how macros parse stuff, like pvectors, 214 | ;;so we're just filtering them out of arglists. 215 | 216 | ;; (defun build-generic (functionspec) 217 | ;; (let* ((args (drop-literals (second functionspec))) 218 | ;; (name (first functionspec)) 219 | ;; (docs (if (= (length functionspec) 3) 220 | ;; (third functionspec) 221 | ;; "Not Documented"))) 222 | ;; `(progn (defgeneric ,name ,args (:documentation ,docs)) 223 | ;; ;;lets us use protocol fns as values... 224 | ;; (defparameter ,name (function ,name)) 225 | ;; (setf (symbol-function (quote ,name)) (symbol-value (quote ,name))) 226 | ;; ,name))) 227 | 228 | (defun build-generic (functionspec) 229 | (let* ((args (drop-literals (rest functionspec))) 230 | (name (first functionspec)) 231 | (docs (if (stringp (last functionspec)) 232 | (last functionspec) 233 | "Not Documented"))) 234 | (case (length args) 235 | (1 (let ((args (drop-literals (first args)))) 236 | `(progn (defgeneric ,name ,args (:documentation ,docs)) 237 | ;;lets us use protocol fns as values... 238 | (defparameter ,name (function ,name)) 239 | (setf (symbol-function (quote ,name)) (symbol-value (quote ,name))) 240 | ,name))) 241 | (otherwise `(progn (defgeneric ,name (,'this ,'&rest ,'args) (:documentation ,docs)) 242 | ;;lets us use protocol fns as values... 243 | (defparameter ,name (function ,name)) 244 | (setf (symbol-function (quote ,name)) (symbol-value (quote ,name))) 245 | ,name)) 246 | ))) 247 | 248 | (defun quoted-names (xs) 249 | (mapcar (lambda (x) (list 'quote x)) 250 | (function-names xs))) 251 | 252 | (defun spec-to-protocol (protocolspec) 253 | `(progn ,@(mapcar #'build-generic (spec-functions protocolspec)) 254 | (->protocol (quote ,(spec-name protocolspec)) 255 | (list ,@(mapcar (lambda (x) (list 'quote x)) (function-names protocolspec))) 256 | (make-satisfier (quote ,protocolspec))))) 257 | 258 | ;;we'll have to update this guy later, but for now it's okay. 259 | ;;Added that a symbol gets created in the current package. 260 | (defmacro defprotocol (name &rest functions) 261 | (let ((p (gensym)) 262 | (spec (cons name functions))) 263 | `(let ((,p (eval (spec-to-protocol (quote ,spec))))) 264 | (progn (add-protocol ,p) 265 | (defparameter ,name ,p))))) 266 | 267 | ;extends protocol defined by name to 268 | ;each type in the typespecs, where typespecs 269 | ;are of the form... 270 | ;(typename1 (func1 (x) (body)) 271 | ; (func2 (x) (body)) 272 | ; typename2 (func1 (x) (body)) 273 | ; (func2 (x) (body))) 274 | ;bascially converts the implementations into a 275 | ;defmethod.. 276 | ;;takes a list of 277 | (defun parse-implementations (x) 278 | (labels ((get-spec (acc specs) 279 | (if (null specs) 280 | acc 281 | (let ((arg (first specs))) 282 | (if (symbolp arg) 283 | (get-spec (cons (list arg) acc) (rest specs)) 284 | (let ((currentspec (first acc))) 285 | (get-spec (cons (cons arg currentspec) (rest acc)) 286 | (rest specs)))))))) 287 | (mapcar #'nreverse (get-spec (list) x)))) 288 | 289 | ;; (defparameter samplext 290 | ;; '(pvec 291 | ;; (next (coll) (nth coll 0)) 292 | ;; (more (coll) (subvec coll)) 293 | ;; cons 294 | ;; (next (coll) (first coll)) 295 | ;; (more (coll) (rest coll)))) 296 | 297 | (defun implement-function (typename spec) 298 | (let* ((args (cond ((vector? (second spec)) 299 | (vector-to-list (second spec))) 300 | ;this is a crappy hack. 301 | ((vector-expr (second spec)) 302 | (rest (second spec))) 303 | (t 304 | (drop-literals (second spec))))) 305 | (newargs (cons (list (first args) typename) (rest args))) 306 | (body (third spec))) 307 | `(defmethod ,(first spec) ,newargs ,body))) 308 | 309 | ;; (defmacro implement-function (typename spec) 310 | ;; (let* ((args (if (vector? (second spec)) 311 | ;; (vector-to-list (second spec)) 312 | ;; (drop-literals (second spec)))) 313 | ;; (newargs (cons (list (first args) typename) (rest args))) 314 | ;; (body (third spec))) 315 | ;; ;(print spec) 316 | ;; `(defmethod ,(first spec) ,newargs ,body))) 317 | 318 | (defmacro emit-method (name typename imp) 319 | `(progn (add-protocol-member (quote ,name) (quote ,typename)) 320 | ,@(mapcar (lambda (spec) 321 | (implement-function typename spec)) 322 | (rest imp)))) 323 | 324 | (defun emit-implementation (name satvar imp) 325 | (let ((quoted-imp (gensym "quotedimp"))) 326 | `(let ((,quoted-imp (quote ,imp))) 327 | (if (funcall ,satvar ,quoted-imp) 328 | (emit-method ,name ,(first imp) ,imp) 329 | (error 'missing-implementations (str `(,,name ,,quoted-imp))))))) 330 | 331 | (defmacro extend-protocol (name &rest typespecs) 332 | (let ((imps (parse-implementations typespecs)) 333 | (satisfies? (gensym))) 334 | `(let ((,satisfies? (protocol-satisfier (get-protocol (quote ,name))))) 335 | ,@(mapcar (lambda (imp) (emit-implementation name satisfies? imp)) 336 | imps)))) 337 | 338 | ;Extend-type is also particularly useful. 339 | ;;Pending -> implement deftype. 340 | 341 | (comment 342 | ;Testing.... 343 | (defprotocol INamed 344 | (get-name (thing) "gets the name of the thing!") 345 | (say-name (thing) "Says the name of the thing!")) 346 | 347 | (extend-protocol 348 | INamed 349 | cons (get-name (thing) (car thing)) 350 | (say-name (thing) (pprint (format nil "The name is: ~A" (get-name thing))))) 351 | 352 | (defun test () 353 | (let ((data '(:tom))) 354 | (when (satisfies? INamed data) 355 | (pprint (get-name data))) 356 | (say-name data)) 357 | 358 | (defmacro cljmacro (name argvec & body) 359 | (let ((args (if (vector? argvec argvec) 360 | (eval `(clclojure.reader/quoted-children ,argvec))))) 361 | `(,@body))) 362 | ) 363 | 364 | ;;Deftype implementation. 365 | ;;Once we have protocols, deftype is pretty easy. 366 | ;;deftype is a hook into the type definition or object system of 367 | ;;the host environment. We'll use it to generate CLOS classes via 368 | ;;defclass. I may include an option to use deftype to build structs 369 | ;;which would likely kick ass for performance. 370 | 371 | ;;A deftype form is pretty easy: 372 | ;;(deftype name-of-type (field1 field2 ... fieldn) 373 | ;; Protocol1 374 | ;; (function1 (args) body1) 375 | ;; Protocol2 376 | ;; (function2 (args) body2)) 377 | ;; 378 | ;;Should expand into: 379 | ;;(progn 380 | ;; (defclass name-of-type 381 | ;; ((field1 :init-arg :field1) 382 | ;; (field2 :init-arg :field2))) 383 | ;; (extend-protocol Protocol1 name-of-type 384 | ;; (function1 (args) body1)) 385 | ;; (extend-protocol Protool2 name-of-type 386 | ;; (function2 (args) body2))) 387 | 388 | ) 389 | 390 | (defun symbolize (x) (read-from-string x)) 391 | 392 | (defun emit-class-field (nm s) 393 | `(,s :initarg ,(make-keyword s) 394 | :accessor ,(symbolize (str nm "-" s)))) 395 | 396 | (defun emit-protocol-extension (proto-name type-name imps) 397 | `(extend-protocol ,proto-name ,type-name ,@imps)) 398 | 399 | ;;impl has protocol (pfn ...) (pfn ...) 400 | (defmacro extend-type (typename &rest impls) 401 | (let ((imps (parse-implementations impls)) 402 | ;(name (gensym)) 403 | ;(the-imp (gensym)) 404 | ) 405 | `(progn ,@(mapcar (lambda (the-imp) 406 | (let ((expr `(emit-protocol-extension (quote ,(first the-imp)) 407 | (quote ,typename) 408 | (quote ,(rest the-imp))))) 409 | (eval expr))) 410 | 411 | imps)) 412 | 413 | ;; (if (funcall ,satisfies? imp) 414 | ;; (progn (add-protocol-member (quote ,name) typename) 415 | ;; (dolist (spec (rest imp)) 416 | ;; (eval (implement-function ,typename spec)))) 417 | ;; (error 'missing-implementation)) 418 | )) 419 | 420 | ;;the goal here is to define "instance-local" operations 421 | ;;at the method level, where fields refer to slots on the object. 422 | ;;so, we may have a object like {:a 2 :b 3} 423 | ;;fields [a b], 424 | ;;our implementations could be 425 | ;;(blah [obj] a) ;;undefined! 426 | ;;(blee [a] a) ;;defined, shadowing, poor form, but meh. 427 | 428 | ;;we need to extend the lexcial environment to include 429 | ;;field access... 430 | ;;(blah [obj] a) => 431 | ;;(blah [obj] 432 | ;; (with-slots ((a obj)) 433 | ; a)) 434 | 435 | ;;we can be more efficient if we walk the implementations 436 | ;;to detect field usage. For NOW, we'll just 437 | ;;bind all the fields in the lexical environment 438 | ;;of body, less the field names that are shadowed 439 | ;;by protocol args. 440 | 441 | ;;TODO: walk the body and collect fields to determine 442 | ;;the final set of fields to use (tailored). 443 | (defun with-fields (fields method args &rest body) 444 | (let* ((arglist (as-list args)) 445 | (var (first arglist)) 446 | (flds (set-difference (as-list fields) arglist))) 447 | ;;naive implementation is just bind all the slots.... 448 | (if flds 449 | `(,method ,args 450 | (with-slots ,flds ,var 451 | ,@body)) 452 | `(,method ,args ,@body)))) 453 | 454 | ;;we need to mod this. If the implementations refer to a field (and 455 | ;;the field is NOT shadowed as an argument to their method impl), we 456 | ;;need a call to with-slots to pull the referenced fields out to 457 | ;;mirror clojure's behavior. 458 | (defmacro clojure-deftype (name fields &rest implementations) 459 | (let* ((flds (cond ((vector? fields) 460 | (vector-to-list fields)) 461 | ((vector-expr fields) 462 | (rest fields)) 463 | (t 464 | fields))) 465 | (impls (mapcar (lambda (impl) 466 | (if (atom impl) impl 467 | (apply #'with-fields (cons flds impl)))) implementations))) 468 | `(progn 469 | (defclass ,name () 470 | ,(mapcar (lambda (f) (emit-class-field name f) ) flds)) 471 | ;;we need to parse the implementations to provide 472 | ;;instance-level fields... 473 | (extend-type ,name ,@impls) 474 | ;;debugging 475 | (defun ,(symbolize (str "->" name)) ,flds 476 | (make-instance ,`(quote ,name) ,@(flatten (mapcar (lambda (f) `(,(make-keyword f) ,f)) flds )))) 477 | 478 | ))) 479 | 480 | 481 | ;;Deftype exists in common lisp. 482 | (comment 483 | 484 | 485 | ;;An experimental class-bassed approach; putting this on ice for now. 486 | 487 | ;;This is our interface, which is a base class all protocols will 488 | ;;derive from. 489 | ;; (defclass IProtocol () 490 | ;; (name 491 | ;; functions 492 | ;; satisfier 493 | ;; (members 494 | ;; :initform (list)))) 495 | 496 | ;;Defining a protocol is just a matter of defining a new class that inherits 497 | ;;from IProtocol. 498 | 499 | ;; (defmacro defprotocol-1 (name functions &optional satisifer) 500 | ;; `(defclass ,name (IProtocol) 501 | ;; ((name :initform ,name) 502 | ;; (functions :initform functions) 503 | ;; ( 504 | ;; ) 505 | ) 506 | -------------------------------------------------------------------------------- /dustbin/reader.lisp: -------------------------------------------------------------------------------- 1 | ;;A package for defining read table extensions 2 | ;;for clojure data structures. 3 | 4 | ;;Pending.................. 5 | (defpackage :clclojure.reader 6 | (:use :common-lisp :common-utils :named-readtables :clclojure.pvector :clclojure.cowmap) 7 | (:export :*literals* :*reader-context* :quoted-children :quote-sym :literal?)) 8 | (in-package :clclojure.reader) 9 | 10 | 11 | 12 | (comment 13 | (defconstant +left-bracket+ #\[) 14 | (defconstant +right-bracket+ #\]) 15 | (defconstant +left-brace+ #\{) 16 | (defconstant +right-brace+ #\}) 17 | (defconstant +comma+ #\,) 18 | (defconstant +colon+ #\:) 19 | 20 | 21 | (defconstant +at+ #\@) 22 | (defconstant +tilde+ #\~)) 23 | 24 | (EVAL-WHEN (:compile-toplevel :load-toplevel :execute) 25 | 26 | ;;Problem right now is that, when we read using delimited-list, 27 | ;;we end up losing out on the reader literal for pvecs and the like... 28 | ;;When we have quoted 29 | 30 | ;;we can use a completely custom reader...perhaps that's easiet.. 31 | ;;Have to make this available to the compiler at compile time! 32 | ;;Maybe move this into a clojure-readers.lisp or something. 33 | 34 | ;;alist of literals... 35 | (defparameter *literals* '(list) ; '(list cons) 36 | ) 37 | (defparameter *reader-context* :read) 38 | ;;default quote...o 39 | ;; (comment 40 | ;; (set-macro-character #\' 41 | ;; #'(lambda (stream char) 42 | ;; (declare (ignore char)) 43 | ;; `(quote ,(read stream t nil t))))) 44 | (defun quote-sym (sym) (list 'quote sym)) ;`(quote ,sym) 45 | ;; (defmacro quoted-children (c) 46 | ;; `(,(first c) ,@(mapcar #'quote-sym (rest c)))) 47 | 48 | (defun dotted-pair? (xs) 49 | (and (listp xs) 50 | (not (listp (cdr xs))))) 51 | 52 | (defun literal? (s) (or (and (listp s) (find (first s) *literals*)) 53 | (and (symbolp s) (find s *literals*)))) 54 | 55 | (defmacro quoted-children (c) 56 | `(,(first c) 57 | ,@(mapcar (lambda (s) 58 | (cond ((literal? s) ;;we need to recursively call quoted-children.. 59 | `(quoted-children ,s)) 60 | ((dotted-pair? s) 61 | `(quote ,s)) 62 | ((listp s) 63 | `(quoted-children ,(cons (quote list) s))) 64 | (t (funcall #'quote-sym s)))) (rest c)))) 65 | 66 | ;;Enforces quoting semantics for literal data structures.. 67 | (defmacro clj-quote (expr) 68 | 69 | (cond ((literal? expr) `(quoted-children ,expr)) 70 | ((dotted-pair? expr) `(quote ,expr)) 71 | ((listp expr) 72 | `(quoted-children ,(cons (quote list) expr))) 73 | (t 74 | (quote-sym expr)))) 75 | 76 | (defun as-char (x) 77 | (cond ((characterp x) x) 78 | ((and (stringp x) 79 | (= 1 (length x))) (char x 0)) 80 | ((symbolp x) (as-char (str x))) 81 | (t (error (str (list "invalid-char!" x) )))) 82 | ) 83 | 84 | ;;Gives us clj->cl reader for chars... 85 | (set-macro-character #\\ 86 | #'(lambda (stream char) 87 | (declare (ignore char)) 88 | (let ((res (read stream t nil t))) 89 | (as-char res))) 90 | ) 91 | 92 | ;;Doesn't work currently, since we can't redefine 93 | ;;print-method for chars... 94 | (defun print-clj-char (c &optional (stream t)) 95 | "Generic char printer for clojure-style syntax." 96 | (format stream "\~c" c)) 97 | 98 | (defun print-cl-char (c &optional (stream t)) 99 | "Generic char printer for common lisp syntax." 100 | (format stream "#\~c" c)) 101 | 102 | (comment (defmethod print-object ((obj standard-char) stream) 103 | (print-clj-char obj stream))) 104 | 105 | (defun quoted-read (stream char) 106 | (declare (ignore char)) 107 | (let ((res (read stream t nil t))) 108 | (if (atom res) `(quote ,res) 109 | `(clj-quote ,res)))) 110 | 111 | ;;This should be consolidated... 112 | (set-macro-character #\' 113 | #'quoted-read) 114 | 115 | 116 | ;;need to define quasiquote extensions... 117 | ;;quasiquoting has different behavior for literal datastructures.. 118 | ;;in the case of clojure, we provide fully-qualified symbols vs. 119 | ;;standard CL-symbols. We have reader support for them, 120 | ;;that is, blah/x vs x. 121 | 122 | ;;so, clojure resolves the symbol in the current ns, at read-time. 123 | 124 | (defun resolved-symbol (s) 125 | (let* ((this-package (package-name *package*))) 126 | (multiple-value-bind (x y) 127 | (find-symbol (symbol-name s)) 128 | (if x 129 | ;;symbol exists 130 | `(,(package-name (symbol-package x)) ,(symbol-name x)) 131 | `(,this-package ,(symbol-name s)) 132 | )))) 133 | 134 | (defun qualify (s) 135 | (apply #'common-utils::symb 136 | (let ((res (resolved-symbol s))) 137 | (list (first res) "::" (second res))))) 138 | 139 | (defun quasi-quoted-read (stream char) 140 | (declare (ignore char)) 141 | (let ((res (read stream t nil t))) 142 | (cond ((symbolp res) 143 | (let ((resolved ))) 144 | `(quote ,res)) 145 | (t `(clj-quote ,res))))) 146 | 147 | ;;Additionally, for dataliterals, quasiquote serves as a template 148 | ;;for building said datastructure, as if by recursively quasiquoting 149 | ;;elements in the expression. 150 | 151 | ;;Additionally, clojure 152 | 153 | ;;we can get package-qualified symbols via: 154 | ;;`(common-lisp-user::x) 155 | ;;but they print as 'x 156 | 157 | ;;s.t. `[x y] 158 | ;;namespace-qualified symbols are kind of out of bounds at the 159 | ;;moment... 160 | 161 | 162 | (defun push-reader! (literal ldelim rdelim rdr) 163 | (progn (setf *literals* (union (list literal) *literals*)) 164 | (set-macro-character ldelim rdr) 165 | (set-syntax-from-char rdelim #\)))) 166 | 167 | (defun quoting? () (> sb-impl::*backquote-depth* 0)) 168 | 169 | ;;This now returns the actual pvector of items read from 170 | ;;the stream, versus a quoted form. Should work nicely 171 | ;;with our protocol definitions now! 172 | 173 | 174 | ;;The issue we run into with our EDN forms is this: 175 | ;;(defparameter x 2) 176 | ;;(eval [x]) 177 | ;;should yield [2] 178 | 179 | ;;we don't currently. 180 | ;;So, 181 | 182 | ;;Quasiquoting custom data literals.. 183 | ;;=================================== 184 | ;;THis is way janky... 185 | ;;I'm not afraid to say I don't know how I pulled this off. 186 | ;;The key is that the quasiquoting mechanism in backq.lisp 187 | ;;has a sb-int:comma struct to denote 3 kinds of commas: 188 | ;;0 -> ,x 189 | ;;1 -> ,.x 190 | ;;2 -> ,@x 191 | 192 | ;;We ignore the dot version for now, although it's probably simple 193 | ;;enough to get working. 194 | ;;So we just manually build the expression. 195 | ;;If it's not a comma, we quasiquote it and let the macroexpander 196 | ;;figure it out. 197 | (defun quasify (xs) 198 | (nreverse 199 | (reduce (lambda (acc x) x 200 | (if (sb-int:comma-p x) 201 | (let ((expr (sb-int:comma-expr x))) 202 | (case (sb-int:comma-kind x) 203 | (0 (cons expr acc)) 204 | (2 (reduce (lambda (a b) (cons b a)) (eval expr) :initial-value acc)) 205 | (1 (error "comma-dot not handled!")))) 206 | (cons (list 'sb-int:quasiquote x) acc))) xs :initial-value '()))) 207 | 208 | ;;Original from Stack Overflow, with some slight modifications. 209 | ;;Have to make this available to the compiler at compile time! 210 | ;;Maybe move this into a clojure-readers.lisp or something. 211 | ;;We need to modify this. It implicity acts like quote for 212 | ;;symbols, since we're using read-delimited-list. 213 | (defun |bracket-reader| (stream char) 214 | "A reader macro that allows us to define persistent vectors 215 | inline, just like Clojure." 216 | (declare (ignore char)) 217 | (if (not (quoting?)) 218 | (apply #'persistent-vector (read-delimited-list #\] stream t)) 219 | (eval `(persistent-vector ,@(quasify (read-delimited-list #\] stream t)))))) 220 | 221 | ;;Original from Stack Overflow, with some slight modifications. 222 | (defun |brace-reader| (stream char) 223 | "A reader macro that allows us to define persistent maps 224 | inline, just like Clojure." 225 | (declare (ignore char)) 226 | (if (not (quoting?)) 227 | (apply #'persistent-map `(,@(read-delimited-list #\} stream t))) 228 | (eval `(persistent-map ,@(quasify (read-delimited-list #\} stream t)))))) 229 | 230 | (set-macro-character #\{ #'|brace-reader|) 231 | (set-syntax-from-char #\} #\)) 232 | 233 | ;;this is for not just reading, but evaluating as well... 234 | ;;in theory, the default reader function will suffice for 235 | ;;quoted or unevaluated forms. We will need to evaluate 236 | ;;our args otherwise.... 237 | ;; (defun |bracket-reader| (stream char) 238 | ;; "A reader macro that allows us to define persistent vectors 239 | ;; inline, just like Clojure." 240 | ;; (declare (ignore char)) 241 | ;; (eval `(apply #'persistent-vector (list ,@(read-delimited-list #\] stream t))))) 242 | 243 | ;;TODO move to named-readtable 244 | (push-reader! 'persistent-vector #\[ #\] #'|bracket-reader|) 245 | ;;TODO move to named-readtable 246 | (push-reader! 'clclojure.pvector:persistent-vector #\[ #\] #'|bracket-reader|) 247 | 248 | (comment (set-macro-character #\[ #'|bracket-reader|) 249 | (set-syntax-from-char #\] #\)) 250 | 251 | ;;This should be consolidated... 252 | (set-macro-character #\' 253 | #'(lambda (stream char) 254 | (let ((res (read stream t nil t))) 255 | (if (atom res) `(quote ,res) 256 | (case (first res) 257 | (persistent-vector `(quoted-children ,res))) 258 | )))))) 259 | 260 | (comment 261 | ;;WIP, moving to more elegant solution from named-readtables.... 262 | ;; (defreadtable clojure:syntax 263 | ;; (:merge :standard) 264 | ;; (:macro-char #\[ #'|bracket-reader| t) 265 | ;; (:case :preserve)) 266 | ) 267 | 268 | ;; (comment (defun |brace-reader| (stream char) 269 | ;; "A reader macro that allows us to define persistent vectors 270 | ;; inline, just like Clojure." 271 | ;; (declare (ignore char)) 272 | ;; `(persistent-vector ,@(read-delimited-list #\] stream t))) 273 | ;; (set-macro-character #\{ #'|brace-reader|) 274 | ;; (set-syntax-from-char #\} #\)) 275 | 276 | ;; ;;standard quote dispatch 277 | ;; (set-macro-character #\' #'(lambda (stream char) 278 | ;; (list 'quote (read stream t nil t)))) 279 | 280 | 281 | ;; (set-macro-character #\' #'(lambda (stream char) 282 | ;; (let ((res (read stream t nil t))) 283 | ;; (case (first res) 284 | ;; ('persistent-vector 'persistent- )) 285 | ;; (list 'quote ))))) 286 | 287 | 288 | 289 | ;;https://gist.github.com/chaitanyagupta/9324402 290 | ;;https://common-lisp.net/project/named-readtables/ 291 | 292 | 293 | 294 | -------------------------------------------------------------------------------- /dustbin/recurtest.lisp: -------------------------------------------------------------------------------- 1 | (defpackage common-utils.recurtest 2 | (:use :common-lisp :common-utils)) 3 | (in-package :common-utils.recurtest) 4 | 5 | ;;can we implement (recur ...) ? 6 | 7 | ;; (block some-name 8 | ;; (tagbody some-point 9 | ;; :dostuff 10 | ;; (when :recur 11 | ;; (progn (update-vars) 12 | ;; (go some-point)) 13 | ;; ) 14 | ;; ) 15 | ;; result) 16 | 17 | ;; (defun custom-loop (x) 18 | ;; (let ((res)) 19 | ;; (macrolet ((recur (xnew) 20 | ;; `(progn (setf ,'x ,xnew) 21 | ;; (pprint ,'x) 22 | ;; (go ,'recur-from)))) 23 | ;; (tagbody recur-from 24 | ;; (setf res 25 | ;; (if (= x 10) 26 | ;; x 27 | ;; (recur (1+ x))))) 28 | ;; res))) 29 | 30 | ;; (defmacro with-recur (args &rest body) 31 | ;; (let* ((recur-sym (intern "RECUR")) ;HAVE TO CAPITALIZE! 32 | ;; (local-args (mapcar (lambda (x) 33 | ;; (intern (symbol-name x))) args)) 34 | ;; (res (gensym "res")) 35 | ;; (recur-from (gentemp "recur-from")) 36 | ;; (recur-args (mapcar (lambda (x) (gensym (symbol-name x))) local-args 37 | ;; )) 38 | ;; (bindings (mapcar (lambda (xy) 39 | ;; `(setf ,(car xy) ,(cdr xy))) (pairlis local-args recur-args)))) 40 | ;; `(let ((,res)) 41 | ;; (tagbody ,recur-from 42 | ;; (flet ((,recur-sym ,recur-args 43 | ;; (progn ,@bindings 44 | ;; (go ,recur-from)) 45 | ;; )) 46 | ;; (setf ,res ,@body))) 47 | ;; ,res))) 48 | 49 | 50 | ;; (defmacro with-recur (args &rest body) 51 | ;; (let* ((recur-sym (intern "RECUR")) ;HAVE TO CAPITALIZE! 52 | ;; (local-args (mapcar (lambda (x) 53 | ;; (intern (symbol-name x))) args)) 54 | ;; (res (gensym "res")) 55 | ;; (recur-from (gentemp "recur-from")) 56 | ;; (recur-args (mapcar (lambda (x) (gensym (symbol-name x))) local-args 57 | ;; )) 58 | ;; (update-binds (gentemp "update-binds")) 59 | ;; (bindings (mapcar (lambda (xy) 60 | ;; `(setf ,(car xy) ,(cdr xy))) (pairlis local-args recur-args)))) 61 | ;; `(let ((,res)) 62 | ;; (flet ((,update-binds ,recur-args 63 | ;; (progn ,@bindings))) 64 | ;; (macrolet ((,recur-sym ,args 65 | ;; `(progn (,,update-binds ,,@args) 66 | ;; (go ,,recur-from))))) 67 | ;; (tagbody ,recur-from 68 | ;; (setf ,res ,@body))) 69 | ;; ,res))) 70 | 71 | ;; (with-recur (x 2) 72 | ;; (if (< x 4) 73 | ;; (recur (1+ x)) 74 | ;; x)) 75 | 76 | ;; (let ((continue? t) 77 | ;; (x 2) 78 | ;; (res) 79 | ;; (continue? nil)) 80 | ;; (flet ((recur (x) 81 | ;; (setf x x) 82 | ;; (setf continue? t))) 83 | ;; (tagbody recur-from 84 | ;; (progn 85 | ;; (setf res 86 | ;; (if (< x 4) 87 | ;; (recur (1+ x)) 88 | ;; x)) 89 | ;; (when continue? 90 | ;; (setf continue? nil) 91 | ;; (go recur-from)))) 92 | ;; res)) 93 | 94 | (comment 95 | ;;we can call simmary-tails on all these and get nil, 96 | ;;or some combination of (t, nil), (t, some-list-of illegal callsites) 97 | (defparameter normal-call 98 | `(if (= 2 3) 99 | :equal 100 | (progn (print :otherwise) 101 | :inequal))) 102 | 103 | (defparameter good-tail 104 | '(if (= 2 3) 105 | (recur 2) 106 | (recur 3))) 107 | 108 | (defparameter bad-tail 109 | '(progn 110 | (recur 2) 111 | 3)) 112 | 113 | (defparameter gnarly-bad-tail 114 | '(lambda (x) 115 | (with-recur (acc x) 116 | (let ((blah 5) 117 | (blee 3)) 118 | (if (<= acc blah) 119 | (recur (1+ x)) 120 | (progn (when (< 2 3) 121 | (recur 44)) 122 | 2)))))) 123 | 124 | (defparameter gnarly-good-tail 125 | '(lambda (x) 126 | (with-recur (acc x) 127 | (let ((blah 5) 128 | (blee 3)) 129 | (if (<= acc blah) 130 | (recur (1+ x)) 131 | (progn (when (< 2 3) 132 | (print 44)) 133 | 2)))))) 134 | ) 135 | 136 | 137 | ;(with-recur (x 2 y 3) (+ x y)) 138 | (with-recur (x 0) 139 | (if (< x 10) 140 | (recur (1+ x)) 141 | x)) 142 | 143 | (with-recur (x 0) 144 | (if (> x 9) 145 | x 146 | (recur (1+ x)))) 147 | 148 | (defun good-tail () 149 | (with-recur (x 2) 150 | (if (> x 5) 151 | x 152 | (if (= x 2) 153 | (recur 5) 154 | (recur (1+ x)))))) 155 | 156 | ;;not currently checked! 157 | (defun bad-tail () 158 | (with-recur () 159 | (progn 160 | (recur 2) 161 | 3))) 162 | 163 | (defun gnarly-bad-tail (x) 164 | (with-recur (acc x) 165 | (let ((blah 5) 166 | (blee 3)) 167 | (if (<= acc blah) 168 | (recur (1+ x)) 169 | (progn (when (< 2 3) 170 | (recur 44)) 171 | 2))))) 172 | 173 | (defun gnarly-good-tail (x) 174 | (with-recur (acc x) 175 | (let ((blah 5) 176 | (blee 3)) 177 | (if (<= acc blah) 178 | (recur (1+ acc)) 179 | (progn (when (< 2 3) 180 | (print 44)) 181 | 2))))) 182 | 183 | 184 | ;;test function for sussing out the correct way to 185 | ;;handle recur forms with varargs... 186 | (defun tst () 187 | (flet ((blah (&rest args) (pprint :hobart) nil)) 188 | (macrolet ((recur (&whole whole-form &rest args) 189 | (let* ((frm (list* 'apply (list 'function 'blah) args))) 190 | (progn (pprint (list :expanding whole-form :to frm)) 191 | frm)))) 192 | (labels ((blah (x &rest xs) 193 | (pprint (list x xs)) 194 | (if (null xs) x 195 | (progn (pprint (macroexpand-1 `(recur (+ ,x (first ,xs)) (rest ,xs)))) 196 | (recur (+ x (first xs)) (rest xs)))))) 197 | #'blah)))) 198 | 199 | ;; ;;looking at using with-recur... 200 | ;; ;;possible naive way to inline using with-recur... 201 | ;; (defun blah (&rest xs) 202 | ;; (labels ((aux (&rest xs) 203 | ;; (macrolet ((blah (&rest args) 204 | ;; `(apply #'aux ,args))) 205 | ;; (case (length xs) 206 | ;; (1 (with-recur (x (first xs)) 207 | ;; (pprint x))) 208 | ;; (2 (with-recur (acc (first xs) 209 | ;; bound (second xs)) 210 | ;; (if (< acc bound) 211 | ;; (blah (+ acc 3) bound) 212 | ;; acc))) 213 | ;; (otherwise (with-recur ((x y &rest zs) xs) 214 | ;; (+ x y (apply #'+ zs)))))))) 215 | ;; (apply #'aux xs))) 216 | 217 | ;; (with-recur (x 2) 218 | ;; (if (< x 10) (recur (1+ x)) x)) 219 | 220 | ;; (LET ((#:|continuex764| T) (#:|res763|) (X 2)) 221 | ;; (FLET ((RECUR (#:X765) 222 | ;; (PROGN (SETF X #:X765) (SETF #:|continuex764| T)))) 223 | ;; (TAGBODY 224 | ;; |recur-from2| 225 | ;; (PROGN 226 | ;; (SETF #:|res763| 227 | ;; (IF (< X 10) 228 | ;; (RECUR (1+ X)) 229 | ;; X)) 230 | ;; (WHEN #:|continuex764| (SETF #:|continuex764| NIL) (GO |recur-from2|)))) 231 | ;; #:|res763|)) 232 | 233 | ;; (with-recur ((x &rest xs) xs) 234 | ;; (if (null zs) 235 | ;; (+ x y) 236 | ;; (recur (+ x y) 237 | ;; (first zs) 238 | ;; (rest zs)))) 239 | 240 | ;; (destructuring-bind (x y &rest zs) xs 241 | ;; (LET ((#:|continuex764| T) 242 | ;; (#:|res763|) 243 | ;; (arg-X x) 244 | ;; (arg-y y) 245 | ;; (rest-zs zs)) 246 | ;; (FLET ((RECUR (x y &rest zs) 247 | ;; (PROGN (SETF arg-X x) 248 | ;; (setf arg-y y) 249 | ;; (setf rest-zs zs) 250 | ;; (SETF #:|continuex764| T)))) 251 | ;; (TAGBODY 252 | ;; |recur-fromvar| 253 | ;; (PROGN 254 | ;; (SETF #:|res763| 255 | ;; (IF (< X 10) 256 | ;; (RECUR (1+ X)) 257 | ;; X)) 258 | ;; (WHEN #:|continuex764| (SETF #:|continuex764| NIL) (GO |recur-fromvar|)))) 259 | ;; #:|res763|))) 260 | 261 | 262 | ;;let's construct one from scratch.. 263 | 264 | (comment 265 | (defun blah (&rest xs) 266 | (let* ((blah-1 (named-fn blah-1 (x) 267 | (pprint x))) 268 | (blah-2 (named-fn blah-2 (acc bound) 269 | (if (< acc bound) 270 | (blah (+ acc 3) bound) 271 | acc))) 272 | (blah-variadic (named-fn blah-variadic (x y &rest zs) 273 | (+ x y (apply #'+ zs))))) 274 | (case (length xs) 275 | (1 (funcall blah-1 (first xs))) 276 | (2 (funcall blah-2 (first xs) (second xs))) 277 | (otherwise (apply blah-variadic xs) )))) 278 | 279 | ;;shouldn't blow the stack..but it does unless compiled. 280 | (defun blah (&rest xs) 281 | (let* ((blah-1 (named-fn blah-1 (x) 282 | (pprint x))) 283 | (blah-2 (named-fn blah-2 (acc bound) 284 | (if (< acc bound) 285 | (recur (+ acc 3) bound) 286 | acc))) 287 | (blah-variadic (named-fn blah-variadic (x y &rest zs) 288 | (+ x y (apply #'+ zs))))) 289 | (case (length xs) 290 | (1 (funcall blah-1 (first xs))) 291 | (2 (funcall blah-2 (first xs) (second xs))) 292 | (otherwise (apply blah-variadic xs) )))) 293 | 294 | ) 295 | 296 | (comment 297 | ;;testing -this works. 298 | (defparameter f (named-fn* blah 299 | ((x) (pprint (list x)) x) 300 | ((x &rest xs) (if (null xs) (blah x) (recur (+ x (first xs)) (rest xs)))))) 301 | ) 302 | 303 | 304 | ;; (defmacro named-fn* (name &rest args-bodies) 305 | ;; (if (= (length args-bodies) 1) 306 | ;; (let ((args-body (first args-bodies))) 307 | ;; `(named-fn ,name ,(first args-body) ,(second args-body))) ;regular named-fn, no dispatch. 308 | ;; (destructuring-bind (cases var) (parse-dispatch-specs args-bodies) 309 | ;; (let* ((args (gensym "args")) 310 | ;; (funcspecs (mapcar (lambda (xs) 311 | ;; (destructuring-bind (n (args body)) xs 312 | ;; (let* ((fname (func-name name n)) 313 | ;; (fbody `(named-fn ,fname ,args ,body))) 314 | ;; (if (= n 0) 315 | ;; `(,n ,fname ,fbody) 316 | ;; `(,n ,fname ,fbody))))) cases)) 317 | ;; (varspec (when var 318 | ;; (let* ((fname (func-name name :variadic)) 319 | ;; (fbody `(named-fn ,fname ,(first var) ,(second var)))) 320 | ;; `(:variadic ,fname ,fbody)))) 321 | ;; (specs (if var (append funcspecs (list varspec)) funcspecs)) 322 | ;; (aux (gensym "aux")) 323 | ;; (dummy (gensym "stupid-var"))) 324 | ;; `(let ((,dummy nil) ) 325 | ;; (declare (ignore ,dummy)) 326 | ;; (macrolet ((,name (,'&rest ,'args) 327 | ;; (list 'apply (list 'function (quote ,aux)) (list* 'list ,'args)))) 328 | ;; (let (,@(mapcar (lambda (xs) `(,(second xs) ,(third xs))) 329 | ;; specs)) 330 | ;; (labels ((,aux (,'&rest ,args) 331 | ;; (case (length ,args) 332 | ;; ,@(mapcar (lambda (xs) (let ((n (first xs)) 333 | ;; (name (second xs))) 334 | ;; (if (= n 0) 335 | ;; `(,n (funcall ,name)) 336 | ;; `(,n (apply ,name ,args))))) funcspecs) 337 | ;; (otherwise ,(if var `(apply ,(second varspec) ,args) 338 | ;; `(error 'no-matching-args)))))) 339 | ;; (function ,aux))))))))) 340 | 341 | ;;testing 342 | (comment 343 | (defparameter e 344 | (named-fn* blah 345 | ((acc bound) (if (< acc bound) (recur (+ acc 3) bound) acc)) 346 | )) 347 | (defparameter f 348 | (named-fn* blah 349 | ((acc bound) (if (< acc bound) (recur (+ acc 3) bound) acc)) 350 | ((x &rest xs) (if (null xs) x (recur (+ x (first xs)) (rest xs)))) 351 | )) 352 | 353 | ;;we shouldn't need progn... 354 | (defparameter g 355 | (named-fn* blah 356 | ((x) 357 | (progn 358 | (pprint (list :blah-1 :result x)) 359 | x)) 360 | ((acc bound) 361 | (progn (pprint (list :blah-2 :counting acc :to bound)) 362 | (if (< acc bound) (recur (+ acc 3) bound) acc))) 363 | ((x &rest xs) 364 | (progn (pprint (list :blah-variadic :adding x :to xs)) 365 | (if (null xs) x (recur (+ x (first xs)) (rest xs))))))) 366 | 367 | (defparameter h 368 | (named-fn* blah 369 | ((x) 370 | (progn 371 | (pprint (list :blah-1 :result x)) 372 | x)) 373 | ((acc bound) 374 | (progn (pprint (list :blah-2 :counting acc :to bound)) 375 | (if (< acc bound) (blah (+ acc 3) bound) acc))) 376 | ;; ((x &rest xs) 377 | ;; (progn (pprint (list :blah-variadic :adding x :to xs)) 378 | ;; (if (null xs) x (recur (+ x (first xs)) (rest xs))))) 379 | )) 380 | 381 | ) 382 | 383 | ;; (defmacro named-fn* (name &rest args-bodies) 384 | ;; (if (= (length args-bodies) 1) 385 | ;; (let ((args-body (first args-bodies))) 386 | ;; `(named-fn ,name ,(first args-body) ,(second args-body))) ;regular named-fn, no dispatch. 387 | ;; (destructuring-bind (cases var) (parse-dispatch-specs args-bodies) 388 | ;; (let* ((recur-sym (intern "RECUR")) 389 | ;; (args (gensym "args")) 390 | ;; (funcspecs (mapcar (lambda (xs) 391 | ;; (destructuring-bind (n (args body)) xs 392 | ;; (let* ((fname (func-name name n)) 393 | ;; (fbody `(named-fn ,fname ,args ,body))) 394 | ;; (if (= n 0) 395 | ;; `(,n ,fname ,fbody) 396 | ;; `(,n ,fname ,fbody))))) cases)) 397 | ;; (varspec (when var 398 | ;; (let* ((fname (func-name name :variadic)) 399 | ;; (fbody `(named-fn ,fname ,(first var) ,(second var)))) 400 | ;; `(:variadic ,fname ,fbody)))) 401 | ;; (specs (if var (append funcspecs (list varspec)) funcspecs)) 402 | ;; (aux (gensym "aux"))) 403 | ;; `(let ((,name)) 404 | ;; (macrolet ((,name (,'&rest ,args) 405 | ;; (list* 'funcall ',name ,args) 406 | ;; )) 407 | ;; (let* (,@(mapcar (lambda (xs) `(,(second xs) ,(third xs))) specs)) 408 | ;; (labels ((,aux (,'&rest ,args) 409 | ;; (case (length ,args) 410 | ;; ,@(mapcar (lambda (xs) (let ((n (first xs)) 411 | ;; (name (second xs))) 412 | ;; (if (= n 0) 413 | ;; `(,n (funcall ,name)) 414 | ;; `(,n (apply ,name ,args))))) funcspecs) 415 | ;; (otherwise ,(if var `(apply ,(second varspec) ,args) 416 | ;; `(error 'no-matching-args)))))) 417 | ;; (setf ,name (lambda (&rest ,args) (apply ,aux ,args))) 418 | ;; (labels ((,name (,'&rest ,args) (apply ,name ,args))) 419 | ;; (function ,aux)))))))))) 420 | 421 | ;;testing 422 | (comment 423 | (defparameter the-func 424 | (lambda* 425 | (() 2) 426 | ((x) (+ x 1)) 427 | ((x y) (+ x y)) 428 | ((&rest xs) (reduce #'+ xs)))) 429 | 430 | ) 431 | -------------------------------------------------------------------------------- /dustbin/sequences.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :sequences 2 | (:use :common-lisp :common-utils :clclojure.protocols) 3 | (:shadow :first :rest :second :map :filter :reduce :cons) 4 | (:export 5 | :first 6 | :second 7 | :rest 8 | :map 9 | :filter 10 | :reduce 11 | :flatten 12 | :take 13 | :drop 14 | :take-while 15 | :drop-while 16 | :filter 17 | :fold 18 | :partition 19 | :partition-offset 20 | :interleave 21 | :iterate)) 22 | 23 | (in-package :sequences) 24 | ;;an abstract lazy sequence. 25 | ;;This is meant to serve as an interface for anything that 26 | ;;wants to act like a seq. We stick it in s and pass all the 27 | ;;sequence functions onto s. 28 | 29 | ;;maybe extend to sbcl's sequence type later. 30 | ;;I had this deriving from sbcl's extensible sequence deal, 31 | ;;but ran into problems with method dispatch causing things to 32 | ;;break (like literally crashing sbcl). Removed for now. 33 | (defclass LazySeq () ;(sequence standard-object) 34 | ((value :initarg :value) 35 | (pending :initarg :pending))) 36 | 37 | (defclass FuncSeq () 38 | ((sequence :initarg :sequence) 39 | (sval :initarg :sval) 40 | (seed :initarg :seed))) 41 | 42 | (defun seq? (s) 43 | (or (eq (type-of s) 'LazySeq) 44 | (eq (type-of s) 'FuncSeq))) 45 | 46 | 47 | (defmacro lazy-seq (&rest body) 48 | `(make-instance 'FuncSeq 49 | :sequence nil 50 | :sval nil 51 | :seed (delay ,@body))) 52 | 53 | (defmethod sval ((obj FuncSeq)) 54 | (with-slots (sval seed sequence) obj 55 | (when seed 56 | (setf sval (force seed)) 57 | (setf seed nil)) 58 | (if (not (null sval)) 59 | sval 60 | sequence))) 61 | 62 | (defun func-seq? (s) (eq (type-of s) 'FuncSeq)) 63 | 64 | (defmethod seq ((obj FuncSeq)) 65 | (sval obj) 66 | (with-slots (sval sequence) obj 67 | (if (not (null sval)) 68 | (let ((ls sval)) 69 | (setf sval nil) 70 | (setf sequence 71 | (loop until (not (func-seq? ls)) 72 | do (setf ls (sval ls)) 73 | finally (return ls))) 74 | sequence)))) 75 | 76 | ;;sb-sequence claims these are its fundamental protocol: 77 | 78 | ;;Ugh....It's easier to just define our own stuff and use that internally. 79 | ;;length 80 | ;;elt 81 | ;;(setf elt [sb-sequence]) 82 | ;;adjust-sequence 83 | ;;make-sequence-like 84 | 85 | ;;Naive protocol for singly-linked sequences. We don't 86 | ;;take advantage of chunking here for now. 87 | (defgeneric seq-first (obj)) 88 | 89 | (defmethod seq-first ((obj common-lisp:cons)) 90 | (common-lisp:first obj)) 91 | (defmethod seq-first ((obj null)) 92 | nil) 93 | 94 | (defmethod seq-first ((obj LazySeq)) 95 | (slot-value obj 'value)) 96 | (defmethod seq-first ((obj FuncSeq)) 97 | (seq-first (seq obj))) 98 | 99 | (defgeneric seq-rest (obj)) 100 | 101 | (defmethod seq-rest ((obj common-lisp:cons)) 102 | (common-lisp:rest obj)) 103 | (defmethod seq-rest ((obj FuncSeq)) 104 | (seq-rest (seq obj))) 105 | 106 | ;;this only works for single-arity stuff.... 107 | (defun implements? (method x) 108 | (find-method method '() (list (class-of x)) nil)) 109 | 110 | ;;general lazy sequence constructors. 111 | ;;Coerce a thing into a LazySeq 112 | (defgeneric seq (xs)) 113 | ;;maybe inefficient unless we 114 | ;;memoize, but fine for bootstrapping. 115 | (defun seqable? (x) 116 | (or (seq? x) 117 | (when (implements? #'seq x)) 118 | t)) 119 | 120 | (defmethod seq ((xs LazySeq)) xs) 121 | 122 | (defmacro lazy-cons (x y) 123 | "Creates a LazySeq from x and y." 124 | `(make-instance 'LazySeq :value ,x :pending (delay ,y))) 125 | 126 | (defmethod seq ((xs common-lisp:cons)) 127 | (if (not (null xs)) 128 | (lazy-cons (seq-first xs) (seq-rest xs)) 129 | nil)) 130 | 131 | (defmethod seq ((xs null)) 132 | nil) 133 | 134 | ;; (defmethod more ((obj LazySeq)) 135 | ;; (promise? (slot-value obj '))) 136 | 137 | (defmethod lazy-rest ((s LazySeq)) 138 | (let ((old (slot-value s 'pending))) 139 | (if (not (promise? old)) 140 | old 141 | (let ((new (force old))) 142 | (setf (slot-value s 'pending) new) 143 | new)))) 144 | 145 | (defmethod seq-rest ((obj LazySeq)) 146 | (let ((xs (lazy-rest obj))) 147 | (when (not (null xs)) 148 | (lazy-cons (seq-first xs) (seq-rest xs))))) 149 | 150 | (defmethod seq-rest ((obj null)) 151 | nil) 152 | 153 | ;;temporary printing helper 154 | ;;we'd really like to lazily print. 155 | (defun seq->list (lz) 156 | (loop with head = (seq lz) 157 | until (null head) 158 | collect (seq-first head) 159 | do (setf head (seq-rest head)))) 160 | 161 | ;;I like this one way better. 162 | ;; (defun seq->list (lz) 163 | ;; (labels ((aux (acc xs) 164 | ;; (if (seq xs) 165 | ;; (aux (cons (seq-first xs) acc) (seq-rest xs)) 166 | ;; acc))) 167 | ;; (nreverse (aux '() lz)))) 168 | 169 | ;;naive eager version. 170 | (defun print-seq (s &optional (stream t)) 171 | "Generic vector printer." 172 | (format stream "(~{~s~^ ~})" (seq->list s))) 173 | 174 | ;extend printing to both pvecs and subvectors 175 | (defmethod print-object ((obj LazySeq) stream) 176 | (print-seq obj stream)) 177 | 178 | (defmethod print-object ((obj FuncSeq) stream) 179 | (print-seq obj stream)) 180 | 181 | ;;Basic Seq API 182 | ;;============= 183 | (defun first (xs) (seq-first (seq xs))) 184 | (defun rest (xs) (seq-rest (seq xs))) 185 | (defun next 186 | (coll) 187 | "Returns a seq of the items after the first. Calls seq on its 188 | argument. If there are no more items, returns nil" 189 | (when-not (nil? coll) 190 | (seq (rest coll)))) 191 | 192 | (defun cons (x obj) 193 | (cond ((null obj) (list x)) 194 | ((listp obj) 195 | (common-lisp:cons x obj)) 196 | (t (lazy-cons x (seq obj))))) 197 | 198 | (defgeneric empty? (obj)) 199 | (defmethod empty? ((obj common-lisp:cons)) 200 | (null obj)) 201 | (defmethod empty? ((obj LazySeq)) 202 | (null (seq obj))) 203 | (defmethod empty? ((obj null)) 204 | t) 205 | 206 | 207 | ;;defines a simple protocol for objects that 208 | ;;natively implement efficient reductions. 209 | (defgeneric internal-reduce (obj f)) 210 | (defgeneric init-reduce (obj f init)) 211 | 212 | ;;This will likely be superceded or buttress clojure protocol. 213 | (defgeneric -deref (obj)) 214 | (defmethod -deref (obj) obj) 215 | 216 | (defun deref? (obj) (implements? #'-deref obj)) 217 | (defun deref (obj) (if (not (deref? obj)) 218 | obj (-deref obj))) 219 | 220 | (defstruct (reduced-value 221 | (:constructor reduced (v))) 222 | v) 223 | 224 | (defmethod -deref ((obj reduced-value)) 225 | (reduced-value-v obj)) 226 | 227 | (defun reduced? (obj) 228 | (eq (type-of obj) 'reduced-value)) 229 | 230 | (defmethod internal-reduce ((obj LazySeq) f) 231 | (let ((init (first obj))) 232 | (loop with head = (rest obj) 233 | with acc = init 234 | until (empty? head) 235 | do (setf acc (funcall f acc (first head))) 236 | (setf head (rest head)) 237 | when (reduced? acc) 238 | return (deref acc) 239 | finally (return acc)))) 240 | 241 | (defmethod init-reduce ((obj LazySeq) f init) 242 | (loop with head = obj 243 | with acc = init 244 | until (empty? head) 245 | do (setf acc (funcall f acc (first head))) 246 | (setf head (rest head)) 247 | when (reduced? acc) 248 | return (deref acc) 249 | finally (return acc))) 250 | 251 | ;;default behavior is to coerce to seq. 252 | (defmethod internal-reduce (obj f) 253 | (internal-reduce (seq obj) f)) 254 | 255 | (defmethod init-reduce (obj f init) 256 | (init-reduce (seq obj) f init)) 257 | 258 | ;;Not proud of this hack. Or am I? 259 | (define-condition early-reduction (error) 260 | ((data :initarg :data :reader data))) 261 | 262 | (defun wrapped-accumulator (f) 263 | (lambda (acc x) 264 | (let ((res (funcall f acc x))) 265 | (if (reduced? res) 266 | (error 'early-reduction :data res) 267 | res)))) 268 | 269 | (defmethod internal-reduce ((obj sequence) f) 270 | (handler-case 271 | (common-lisp:reduce (wrapped-accumulator f) obj) 272 | (early-reduction (res) (deref (data res))))) 273 | 274 | (defmethod init-reduce ((obj sequence) f init) 275 | (handler-case 276 | (common-lisp:reduce (wrapped-accumulator f) obj :initial-value init) 277 | (early-reduction (res) (deref (data res))))) 278 | 279 | ;;Some useful core functions. 280 | ;;this will get replaced by the clojure.core stuff, 281 | ;;but for now it'll be useful for bootstrapping. 282 | ;;Note: using reduce to implement a lot of stuff is great, 283 | ;;except that leveraging the extant common lisp reduce over 284 | ;;cl sequences also means we can't use early termination 285 | ;;criteria, is indicated by (reduced ..). One (inefficient) 286 | ;;solution is to force everything to be a seq. It'd be nice 287 | ;;if we could interop better, but I have no idea how 288 | ;;to stop a reduction in cl, unless we signal an error 289 | ;;intentionally. 290 | (defun* reduce 291 | ((f coll) 292 | (internal-reduce coll f)) 293 | ((f init coll) 294 | (init-reduce coll f init))) 295 | 296 | (defun iterate 297 | (f init) 298 | "Produces a lazy sequence of results, where 299 | f is applied repeatedly, first to init, then 300 | to the result (f (f (f init)))" 301 | (let ((res (funcall f init))) 302 | (when res 303 | (lazy-seq 304 | (cons init (iterate f res)))))) 305 | 306 | (defun every? (pred coll) 307 | (reduce (lambda (acc x) 308 | (if (not (funcall pred x)) 309 | (reduced nil) 310 | acc)) t coll)) 311 | 312 | (defun filter (pred coll)) 313 | 314 | (defun map (f coll) 315 | (labels ((aux (s) 316 | (if-let ((x (first s))) 317 | (lazy-cons (funcall f x) (aux (rest s)))))) 318 | 319 | (aux (seq coll)))) 320 | 321 | ;; (defun map (f coll &rest colls) 322 | ;; (labels (step ((cs) 323 | ;; (lazy-seq 324 | ;; (let [ss (map seq cs)] 325 | ;; (when (every? identity ss) 326 | ;; (cons (map first ss) (step (map rest ss)))))))) 327 | ;; (map #(apply f %) (step (conj colls c3 c2 c1))))) 328 | 329 | (defun filter (f coll) 330 | (labels ((aux (s) 331 | (if-let ((x (first s))) 332 | (if (funcall f x) 333 | (lazy-cons x (aux (rest s))) 334 | (aux (rest s)))))) 335 | (aux (seq coll)))) 336 | 337 | (defun take (n coll) 338 | (labels ((aux (k s) 339 | (when (> k 0) 340 | (if-let ((res (first s))) 341 | (lazy-cons res (aux (1- k) (rest s))))))) 342 | (aux n (seq coll)))) 343 | 344 | (defun take-while (pred coll) 345 | (labels ((aux (s) 346 | (when-let ((res (first s))) 347 | (when (funcall pred res) 348 | (lazy-cons res (aux (rest s))))))) 349 | (aux (seq coll)))) 350 | 351 | (defun drop (n coll) 352 | (labels ((aux (k s) 353 | (if (> k 0) 354 | (if-let ((res (first s))) 355 | (aux (1- k) (rest s))) 356 | s))) 357 | (aux n (seq coll)))) 358 | 359 | (defun drop-while (pred coll) 360 | (labels ((aux (s) 361 | (when-let ((res (first s))) 362 | (if (funcall pred res) (aux (rest s)) s)))) 363 | (aux (seq coll)))) 364 | 365 | (defun get-entry! (iter) 366 | (multiple-value-bind (entry-p key value) (funcall iter) 367 | (when entry-p (list (list key value)) iter))) 368 | 369 | (defun lazy-entries (tbl) 370 | "Converts a hash-table into a lazy sequence of entries" 371 | (with-hash-table-iterator (my-iterator tbl) 372 | (let ((get-entry (lambda () (my-iterator)))) 373 | (labels ((aux (f) 374 | (multiple-value-bind (entry-p key value) (funcall f) 375 | (if entry-p 376 | (lazy-cons (list key value) 377 | (aux f)))))) 378 | (aux get-entry))))) 379 | 380 | (defmethod seq ((obj hash-table)) 381 | (lazy-entries obj)) 382 | 383 | ;;don't have recur implemented yet... 384 | ;; (defun* dorun 385 | ;; ((coll) 386 | ;; (when-let (s (seq coll)) 387 | ;; (recur (next s)))) 388 | ;; ((n coll) 389 | ;; (when (and (seq coll) (pos? n)) 390 | ;; (recur (dec n) (next coll))))) 391 | 392 | ;(defun doall ) 393 | 394 | (defun* partition 395 | ((n offset coll) 396 | (when-let ((s (seq coll))) 397 | (lazy-seq 398 | (cons (take n coll) (partition n offset (drop offset coll)))))) 399 | ((n coll) 400 | (lazy-seq 401 | (cons (take n coll) (partition n n (drop n coll)))))) 402 | 403 | ;;Eager Sequence Functions, may be OBE 404 | ;;==================================== 405 | 406 | (defun flatten (expr) 407 | (labels ((aux (acc xs) 408 | (if (atom xs) xs 409 | (progn (dolist (x xs) 410 | (if (atom x) (push x acc) 411 | (let ((res (nreverse (aux (list) x)))) 412 | (mapcar (lambda (x) (push x acc)) res)))) 413 | acc)))) 414 | (nreverse (aux (list) expr)))) 415 | 416 | (comment 417 | (defgeneric take! (n l)) 418 | (defmethod take! (n (l cons)) 419 | "Takes n elements from a list" 420 | (do ((remaining l (rest remaining)) 421 | (acc (list)) 422 | (i n (decf i))) 423 | ((or (= 0 i) (null remaining)) (nreverse acc)) 424 | (push (first remaining) acc))) 425 | 426 | (defgeneric drop! (n l)) 427 | (defmethod drop! (n (l cons)) 428 | "Drops the first n elements from a list" 429 | (do ((remaining l (rest remaining)) 430 | (acc nil) 431 | (i n (decf i))) 432 | ((null remaining) acc) 433 | (when (zerop i) 434 | (progn (setf acc (copy-list remaining)) 435 | (setf remaining nil))))) 436 | 437 | (defun ndrop! (n l) 438 | "Drops the first n elements from a list. Returns the sublist 439 | of the inputlist, rather than accumulate a copy." 440 | (do ((remaining l) 441 | (i n (decf i))) 442 | ((or (= 0 i) (null remaining)) remaining) 443 | (when (not (zerop i)) 444 | (setf remaining (rest remaining))))) 445 | 446 | (defgeneric filter! (f l)) 447 | (defmethod filter! (f (l cons)) 448 | "Returns a new list l, for all elements where 449 | applications of f yield true." 450 | (do ((remaining l (rest remaining)) 451 | (acc (list))) 452 | ((null remaining) (nreverse acc)) 453 | (when (funcall f (first remaining)) 454 | (push (first remaining) acc)))) 455 | 456 | (defgeneric take-while! (f l)) 457 | (defmethod take-while! (f (l cons)) 458 | "Draws elements from a list while f yields true. 459 | Returns the resulting list." 460 | (do ((remaining l (rest remaining)) 461 | (acc (list))) 462 | ((null remaining) (nreverse acc)) 463 | (if (funcall f (first remaining)) 464 | (push (first remaining) acc) 465 | (setf remaining nil)))) 466 | 467 | 468 | 469 | (defgeneric drop-while! (f l)) 470 | (defmethod drop-while! (f (l cons)) 471 | "Draws elements from a list while f yields true. 472 | Returns the resulting list." 473 | (do ((remaining l (rest remaining)) 474 | (acc (list))) 475 | ((null remaining) acc) 476 | (when (not (funcall f (first remaining))) 477 | (progn (setf acc (copy-list remaining)) 478 | (setf remaining nil))))) 479 | 480 | (defun ndrop-while! (f l) 481 | "Draws elements from a list while f yields true. 482 | Returns the resulting list. Impure." 483 | (do ((remaining l (rest remaining)) 484 | (acc nil)) 485 | ((null remaining) acc) 486 | (when (not (funcall f (first remaining))) 487 | (progn (setf acc remaining) 488 | (setf remaining nil))))) 489 | 490 | (defun fold (f init l) 491 | "A simple wrapper for reduce." 492 | (reduce f l :initial-value init)) 493 | 494 | (defgeneric partition! (n l &key offset)) 495 | (defmethod partition! (n (l cons) &key (offset n)) 496 | "Akin to partition from clojure. Builds 497 | a list of lists, where each list is size n 498 | elements." 499 | (do ((remaining l (ndrop offset remaining)) 500 | (acc (list))) 501 | ((null remaining) (nreverse acc)) 502 | (let ((nxt (take n remaining))) 503 | (if (= (length nxt) n) 504 | (push nxt acc) 505 | (setf remaining nil))))) 506 | 507 | (defun partition-offset! (n offset l) 508 | "A form of partition, with adjustable offsetting 509 | that is friendly to the ->> threading macro." 510 | (partition n l :offset offset)) 511 | 512 | (defgeneric interleave! (xs ys)) 513 | (defmethod interleave! ((xs cons) (ys cons)) 514 | "Returns a list composed of interwoven values drawn from 515 | input lists xs and ys. Stops the interleaving process 516 | when either list is exhausted." 517 | (do ((left xs (rest left)) 518 | (right ys (rest right)) 519 | (acc nil)) 520 | ((or (null left) (null right)) (nreverse acc)) 521 | (progn 522 | (push (first left) acc) 523 | (push (first right) acc)))) 524 | ) 525 | -------------------------------------------------------------------------------- /dustbin/symbols.lisp: -------------------------------------------------------------------------------- 1 | ;;beginnings of custom symbol tables... 2 | ;;symbols have different behavior in 3 | ;;CL and CLJ. We need to 4 | (defpackage :clclojure.symbols 5 | (:use :common-lisp :clclojure.base) 6 | (:shadowing-import-from :clclojure.base 7 | :deftype :let)) 8 | (in-package :clclojure.symbols) 9 | 10 | (defstruct cljsymbol namespace name) 11 | (defun ->symbol (name &optional namespace) 12 | (make-cljsymbol :namespace namespace :name name)) 13 | 14 | ;;where do symbols live in cljs? 15 | ;;I think there's a local var that defines namespaces and symbols. 16 | ;;In clj jvm, there's a map... 17 | 18 | 19 | 20 | ;;good reference here: 21 | ;;http://blogish.nomistech.com/clojure/clojure-symbols-vs-lisp-symbols/ 22 | 23 | ;;this leads, naturally, to vars as well.. 24 | ;;namespaces are just mappings of symbols to vars. 25 | 26 | -------------------------------------------------------------------------------- /dustbin/variadic.lisp: -------------------------------------------------------------------------------- 1 | (ql:quickload :clclojure) 2 | (defpackage :clclojure.variadic 3 | (:use :common-lisp :clclojure.base) 4 | (:shadowing-import-from :clclojure.base 5 | :deftype :let)) 6 | (in-package :clclojure.variadic) 7 | 8 | ;;we need to determine the arity of the function... 9 | ;;For single arity, current approach works fine. 10 | ;;For multiple/variadic... 11 | ;;We need more information. 12 | 13 | ;;Perhaps a higher level generic function? 14 | 15 | ;;two-layers of type specialization. 16 | 17 | ;;Generic function dispatches on 18 | ;;arg-count, type of first arg 19 | ;; (manytest 1) 20 | ;; invokes specialization 21 | ;; (many :: manytest args) 22 | ;; (manytest 2) 23 | 24 | ;;protocol -> one or more proto functions. 25 | ;; protocol :: proto-fn* 26 | ;; proto-fn:: proto-method+ 27 | ;; proto-method :: proto-body+ 28 | ;; proto-body :: type -> args -> something 29 | 30 | 31 | (arities? proto-fn) ;;should be able to determine concrete arities... 32 | ;;functions are registered, along with their arities somewhere... 33 | ;;if more than one arity, need a dispatch-fn. 34 | 35 | ;;dumb solution:: 36 | (defun generic-dispatch (obj &rest args) 37 | (case (count args) 38 | 0 (0-arity obj) 39 | 1 (apply 1-arity obj args) 40 | 2 (apply 2-arity obj args) 41 | ;;variadic? 42 | (apply variadic obj ,@args) 43 | )) 44 | 45 | 46 | (def sat? (clclojure.protocols::protocol-satisfier IMany)) 47 | 48 | (def spec 49 | '(IMANY (MANY [OBJ] 50 | [OBJ MSG]))) 51 | 52 | ;;our satisfier works.... 53 | ;;detects no set difference in the functions implemented. 54 | ;;bet we have 55 | (def newspec 56 | '(IMANY (MANY [THIS] :SINGLE) 57 | (MANY [THIS THAT] THAT))) 58 | [many 59 | {0 many-1 60 | 1 many-2 61 | 2 many-3 62 | :variadic many-v } ] 63 | 64 | (defgeneric many (obj &rest args)) 65 | 66 | 67 | ;;need to look at recur as well.. 68 | ;;need a named lambda. 69 | ;;in the case of recur, the recur point is 70 | ;;the named lambda. 71 | ;;We make the function name available.... 72 | (let ((many-1 (lambda (this) :single)) 73 | (many-2 (lambda (this that) that ))) 74 | (defmethod many ((obj some-type) &rest args) 75 | (case (count args) 76 | ;;only valid cases 77 | 1 (apply #'many-1 args) 78 | 2 (apply #'many-2 args) 79 | ;;else we ditch if there's not a variadic form! 80 | ) 81 | )) 82 | 83 | (generic-fn* many 84 | ((this) ;;1 85 | (this that) ;;2 86 | (this that else &rest args) ;;:variadic 87 | )) 88 | 89 | 90 | ;;one quick and dirty way to track information 91 | ;;about our generic function, without having to 92 | ;;create a wrapper class, is to maintain 93 | ;;a registry of info... 94 | (defun qualified-name (s) 95 | (common-utils::symb (str (package-name *package*) "/" (symbol-name s)))) 96 | (defparameter *metabase* (make-hash-table :test 'eq)) 97 | 98 | ;;register the generic-fn 99 | (defun push-meta! (name meta) 100 | (let ((k (qualified-name name))) 101 | (setf (gethash k *metabase*) meta))) 102 | 103 | (defun get-meta! (name) 104 | (gethash (qualified-name name) *metabase*)) 105 | 106 | (defun variadic? (arglist) 107 | (find '&rest arglist) ) 108 | 109 | (defun compare-arity (l r) 110 | (let ((lv (variadic? l)) 111 | (rv (variadic? r))) 112 | (if (not (and lv rv)) 113 | (< (length l) (length r)) 114 | (if lv 115 | t 116 | nil)))) 117 | 118 | (define-condition arglist-error (error) 119 | ((text :initarg :text :reader text) 120 | (data :initarg :data :reader data)) 121 | (:report (lambda (condition stream) 122 | (format stream "bad arglists: ~a reason: ~a" 123 | (data condition) (text condition))))) 124 | 125 | ;;invariants: 126 | ;;only one variadic arg.... 127 | ;;unique arities for each other arity... 128 | ;;variadic arg must have more concrete args than the largest arglist. 129 | (defun validated-arglists (arglists) 130 | (labels ((aux (acc remaining) 131 | (if (null remaining) 132 | acc 133 | (let* ((xs (first remaining)) 134 | (l (first xs)) 135 | (r (second xs))) 136 | (cond ((and (second l) ;;vararg lesser arity than nonvar 137 | (second r)) 138 | (error 'arglist-error :text "only one variadic arity allowed!" 139 | :data `(,(first (last l)) 140 | ,(first (last r))))) 141 | ((= (first l) (first r)) ;;identical nonvar arity 142 | (error 'arglist-error :text (if (second r) 143 | "identical arities!" 144 | "variadic arglist must have most concrete args") 145 | :data `(,(first (last l)) 146 | ,(first (last r))))) 147 | ((and (second l) ;;vararg lesser arity than nonvar 148 | (not (second r))) 149 | (error 'arglist-error :text "multiple arglists with same arity!" 150 | :data `(,(first (last l)) 151 | ,(first (last r))))) 152 | (t (aux acc (rest remaining)))))))) 153 | (let ((sorted (sort arglists #'compare-arity))) 154 | (common-utils::->> sorted 155 | (mapcar (lambda (args) 156 | (let ((var (variadic? args))) 157 | (list (- (length args) (if var 1 0)) var args)))) 158 | ((lambda (xs) (common-utils::partition! 2 xs :offset 1))) 159 | (aux sorted))))) 160 | 161 | ;;we want to store the arglists for the generic function as meta data 162 | ;;{:arities {0 () 1 (x) 2 (x y) :variadic (x y &rest zs)} 163 | 164 | ;;for now, we'll do an assoc list. 165 | (defun arglist-meta (arglists) 166 | (mapcar (lambda (args) 167 | (list (if (variadic? args) :variadic (length args)) args)) arglists)) 168 | 169 | ;;constraints: 170 | ;;only one variadic body 171 | ;;discrete args must be > non-variadic definitions... 172 | 173 | (defmacro generic-fn* (name &rest args) 174 | (let ((gf (gensym "genfun")) 175 | (arglists (gensym "arglists"))) 176 | `(let ((,arglists (validated-arglists (quote ,args))) 177 | (,gf (defgeneric ,name (,'obj &rest ,arglists)))) 178 | (progn (push-meta! (quote ,name ) (arglist-meta ,arglists)) 179 | ,gf) 180 | ))) 181 | 182 | ;;a, generic function with n bodies. 183 | ;;we need to track that information? 184 | ;;internal implementation detail.... 185 | (generic-methods* 186 | many ;gen-fn name 187 | some-type 188 | ((this) :single) 189 | ((this that) that) 190 | ((this that else &rest args) else)) 191 | 192 | 193 | ;;we need to lookup the meta for the name. 194 | ;;then match the methods to the arities... 195 | 196 | (defun methods->arities (ms) 197 | ) 198 | 199 | (defmacro generic-methods* (name specializer &rest methods) 200 | (let ((obj (gensym "obj")) 201 | (args (gensym "args")) 202 | (bodies (get-meta! name)) 203 | ) 204 | `(let ((many-1 (lambda (this) :single)) 205 | (many-2 (lambda (this that) that ))) 206 | (defmethod ,name ((,obj ,specializer) ,'&rest ,args) 207 | (case (count ,args) 208 | ;;only valid cases 209 | 1 (apply #'many-1 args) 210 | 2 (apply #'many-2 args) 211 | ;;else we ditch if there's not a variadic form! 212 | ) 213 | ))) 214 | 215 | ) 216 | 217 | 218 | ;;moved from base.... 219 | 220 | ;;Experimentation with function objects... 221 | ;;These may be more desireable than the symbol + lambda 222 | ;;approach I've been taking, since we can pack info 223 | ;;onto the slots... 224 | 225 | (comment ;;a function object... 226 | (defclass fob () 227 | ((name :initarg :name :accessor fob-name) 228 | (args :initarg :args :accessor fob-args) 229 | (body :initarg :body :accessor fob-body) 230 | (func :accessor fob-func) 231 | (meta :initarg :meta :accessor fob-meta)) 232 | (:metaclass sb-mop::funcallable-standard-class)) 233 | 234 | (defparameter spec nil) 235 | (defmethod initialize-instance :after ((f fob) &key) 236 | (with-slots (name args body func) f 237 | (let ((argvec args ;(apply #'persistent-vector args) 238 | )) 239 | (setf spec (list argvec body)) 240 | (setf func 241 | (eval `(fn ,argvec 242 | ,body))) 243 | (sb-mop::set-funcallable-instance-function 244 | f func)))) 245 | 246 | (setq f1 (make-instance 'fob :name "plus" 247 | :meta [] 248 | :args '[x y] 249 | :body '(+ x y) 250 | ))) 251 | 252 | (comment 253 | 254 | 255 | (defclass constructor () 256 | ((name :initarg :name :accessor constructor-name) 257 | (fields :initarg :fields :accessor constructor-fields)) 258 | (:metaclass sb-mop::funcallable-standard-class)) 259 | 260 | 261 | (setq c1 (make-instance 'constructor 262 | :name 'position :fields '(x y)))) 263 | 264 | 265 | (comment 266 | ;;clojure-like let... 267 | (eval `(let* ((,'f ,(fn [k] (+ k 1))) 268 | (,'n 2)) 269 | (declare (special ,'f)) 270 | (unify-values ,'f) 271 | (,'f ,'n))) 272 | 273 | ;;we have to declare vars special to use them in 274 | ;;a let context ala clojure, so that we can unify 275 | ;;the symbols. 276 | 277 | (defun specials (vars) 278 | `(,@(mapcar (lambda (v) 279 | `(declare (special ,v))) vars))) 280 | 281 | ;;Our let macro will just defer to this.... 282 | (defmacro clj-let (binds &rest body) 283 | (let ((bs (vector-to-list binds)) 284 | (vars (mapcar ))))) 285 | ) 286 | -------------------------------------------------------------------------------- /dustbin/wrappers.lisp: -------------------------------------------------------------------------------- 1 | ;;Defining classes that can help us to wrap 2 | ;;built-in classes to allow things like 3 | ;;attaching meta to arbitrary objects... 4 | 5 | ;;this isn't that special.... 6 | 7 | ;;storage and wrapper for our functions... 8 | (defclass function-object () 9 | ((name :initarg :name :accessor function-object-name) 10 | (args :initarg :args :accessor function-object-args) 11 | (body :initarg :body :accessor function-object-body) 12 | (func :accessor function-object-func) 13 | (meta :initarg :meta :accessor function-object-meta)) 14 | (:metaclass sb-mop::funcallable-standard-class)) 15 | 16 | ;; (defmethod initialize-instance :after ((f function-object) &key) 17 | ;; (with-slots (name args body func) f 18 | ;; (setf func 19 | ;; (eval `(fn ,args 20 | ;; ,body))) 21 | ;; ;;note: this is not portable...SBCL specific, 22 | ;; ;;may be able to work around this with closer-mop. 23 | ;; (sb-mop::set-funcallable-instance-function f func))) 24 | 25 | ;; (def f1 (make-instance 'function-object :name "plus" 26 | ;; :meta [] 27 | ;; :args '[x y] 28 | ;; :body '(+ x y) 29 | ;; )) 30 | 31 | (defun make-function (f &key (name nil) (args nil) (body nil) (meta {})) 32 | (let ((obj 33 | (make-instance 'function-object :name name 34 | :meta meta 35 | :args args 36 | :body body))) 37 | (sb-mop::set-funcallable-instance-function obj f) 38 | obj)) 39 | 40 | ;;funcallable is not invokable. 41 | 42 | ;;original idea for metadata, particularly 43 | ;;to capture argument 44 | ;;this is a pretty terrible way to attach meta 45 | ;;to objects... 46 | ;;A better way would be to define object-wrappers 47 | ;;the inherit from the wrappee, providing 48 | ;;slots for meta and hash... 49 | 50 | ;;(defparameter *wrapped-meta* (make-hash-table )) 51 | 52 | -------------------------------------------------------------------------------- /examples/example.lisp: -------------------------------------------------------------------------------- 1 | (ql:quickload :clclojure) 2 | 3 | ;;Lame ns call (for now just a 4 | ;;wrapper around defpackage) 5 | (clclojure.base:ns 6 | :clclojure.example) 7 | x 8 | ;;we have persistent vectors, which will 9 | ;;be replaced by bootstrapped variants from 10 | ;;clclojure.base... 11 | 12 | ;;some clojure-0 expressions demonstrating 13 | ;;fundamentals of the language primitives... 14 | 15 | ;;def and defn export by default, 16 | ;;also unify the function and symbol 17 | ;;namespaces. Working on metadata and 18 | ;;reader support... 19 | 20 | (def v [1 2 3]) 21 | 22 | ;;some core protocol stuff... 23 | (clclojure.base::-conj v 4) 24 | ;;=> [1 2 3 4] 25 | 26 | (clclojure.base::-count v) 27 | ;;=> 3 28 | 29 | ;;fn - single-arity, no meta, no destructuring 30 | (def f (fn [x] (+ x 2))) 31 | 32 | ;;naive defn (no meta, no destructuring) 33 | (defn plus [x y] (+ x y)) 34 | 35 | (plus 1 2) 36 | ;;=> 3 37 | 38 | (defprotocol IBlah 39 | (blah [obj])) 40 | 41 | (defprotocol IBlee 42 | (blee [obj msg])) 43 | 44 | (deftype blather [name x] 45 | IBlah 46 | (blah [this] (str :blaH! name x))) 47 | 48 | (def the-blather (->blather :joinr "blech!!!")) 49 | 50 | (blah the-blather) 51 | ;;gives us ":BLAH!:JOINRblech!!!" 52 | 53 | ;;reify works....under current single arity limitations 54 | ;;we generate effectively an anonoymous, throwaway 55 | ;;CLOS class via deftype, letting deftype do the work.. 56 | 57 | ;;Note: we get warnings about being unable to find 58 | ;;the specializer class for the reified class, 59 | ;;need to check that out, may be missing a quote. 60 | ;;It works tho! 61 | (def the-blither 62 | (let [msg "HOHOHO, MEEERRRRYY REIFY"] 63 | (reify 64 | IBlah 65 | (blah [this] msg) 66 | IBlee 67 | (blee [this custom-msg] (str "custom! " custom-msg) )))) 68 | 69 | (blah the-blither) 70 | ;;gives us "HOHOHO, MEEERRRRYY REIFY" 71 | (blee the-blither "Honk!") 72 | ;;gives us "custom! Honk!" 73 | 74 | ;;protocols are just structs.... 75 | IBlah 76 | ;; #S(CLCLOJURE.PROTOCOLS::PROTOCOL 77 | ;; :NAME IBLAH 78 | ;; :FUNCTIONS (#S(CLCLOJURE.PROTOCOLS::PROTOCOL-FUNCTION 79 | ;; :NAME BLAH 80 | ;; :ARGS ([OBJ]) 81 | ;; :BODIES 1 82 | ;; :ARITIES ((:ARGS [OBJ] :ARITY 1 :VARIADIC? NIL)) 83 | ;; :DOC "not documented")) 84 | ;; :SATISFIER # 87 | ;; :DOC "Not Documented" 88 | ;; :MEMBERS (REIFY1 BLATHER)) 89 | 90 | ;;On the cusp of greatness, but still 91 | ;;debuggin multiple arities! So close.... 92 | ;; (defn idx [v n] 93 | ;; (-nth v n)) 94 | 95 | 96 | (def x :ecks) 97 | 98 | ;;quasiquoting of literals now works... 99 | (defparameter quasi-form 100 | `[,@(list 1 2 ) ,x ,@(list :literal x :hah) 101 | [,x ,x ,x [x] 102 | {:a 2 103 | :b {:unquote ,x} 104 | :c {:quoted x}}]]) 105 | 106 | ;;[1 2 :ECKS :LITERAL :ECKS :HAH [:ECKS :ECKS :ECKS [X] {:C {:QUOTED X} :B {:UNQUOTE :ECKS} :A 2}]] 107 | 108 | ;;splicing doesn't work yet, need to work around 109 | ;;unquote-splicing requirement that everything be a common lisp 110 | ;;sequence type, or coerce to lazy-seq, or override reader macro. 111 | 112 | ;;WIP 113 | ;; (let [x 2 114 | ;; y `[1 ,x 2 [3 4 ,@[1 2]]]] 115 | ;; y) 116 | 117 | ;;coming soon... 118 | ;;meta, destrutcturing, core clojure functions 119 | ;;per cljs, and more... 120 | 121 | ;;loop/recur (maybe not necessary since we can compile 122 | ;;on most implementations and get TCO) 123 | 124 | 125 | ;;Working on variadic protocol implementations, 126 | ;;will be addressed in clclojure.variadic 127 | (defprotocol IMany 128 | (many [obj] [obj msg])) 129 | 130 | ;;currently broken, close to fixing... 131 | (deftype manytest [] 132 | IMany 133 | (many [this] :one!) 134 | (many [this item] item)) 135 | 136 | (def mt (->manytest)) 137 | 138 | (many mt) 139 | (many mt :hello) 140 | 141 | ;;EXAMPLE> (many mt) 142 | ;;:ONE! 143 | 144 | (defn test-my-scope [] 145 | (let 146 | [hello :hello 147 | world :world 148 | k 2 149 | inc (fn [x] (+ x 1)) 150 | add (fn [x y] (+ x y)) 151 | tbl (let [tbl (make-hash-table)] 152 | (setf (gethash :hello tbl) "World") 153 | (setf (gethash :world tbl) "Hello") 154 | (setf (gethash :k tbl) k) 155 | tbl)] 156 | (list (hello tbl) 157 | (world tbl) 158 | (add (inc 39) k) 159 | (gethash :k tbl) ;;(:k tbl);;WIP 160 | ))) 161 | 162 | ;;EXAMPLE> (test-my-scope) 163 | ;;("World" "Hello" 42 2) 164 | 165 | ;;named functions don't currently parse! 166 | ;;This fails too, we have some jank with the 167 | ;;reader when we're inside a macro... 168 | ;;Need to fix the quasi quoter, should 169 | ;;be in backtick.lisp. 170 | (defn test-arities [] 171 | (let [sum (fn ([x] x) 172 | ([x y] (+ x y)) 173 | ([x y &rest zs] (reduce #'+ (+ x y) zs)))] 174 | (clclojure.pvector:persistent-vector 175 | (sum 1) 176 | (sum 1 2) 177 | (sum 1 2 3 4 5 6)) )) 178 | 179 | ;;EXAMPLE> (test-arities) 180 | ;;[1 3 21] 181 | 182 | (defn test-arities-literal [] 183 | (let [sum (fn ([x] x) 184 | ([x y] (+ x y)) 185 | ([x y &rest zs] (reduce #'+ (+ x y) zs)))] 186 | [(sum 1) 187 | (sum 1 2) 188 | (sum 1 2 3 4 5 6) 189 | ])) 190 | 191 | (defn test-arities-quasi [] 192 | (let [sum (fn ([x] x) 193 | ([x y] (+ x y)) 194 | ([x y &rest zs] (reduce #'+ (+ x y) zs)))] 195 | `[,(sum 1) 196 | ,(sum 1 2) 197 | ,(sum 1 2 3 4 5 6) 198 | ])) 199 | 200 | (test-my-scope) 201 | (test-arities) 202 | (test-arities-literal) 203 | (test-arities-quasi) 204 | 205 | ;; EXAMPLE> (test-arities-literal) 206 | ;; [1 3 21] 207 | 208 | (let [x 2] [x]) 209 | ;;[2] 210 | 211 | (let [x 2 y `[,x]] `[,y]) 212 | 213 | ;;not passing: 214 | (let [x 2 y `[,x]] 215 | `[,y `[,,y] ]) 216 | 217 | 218 | ;;Function recur 219 | (reduce (fn [acc x] 220 | (if (odd? x) (recur acc (1+ x)) (+ acc x))) 221 | -55 '(1 2 3 4)) 222 | 223 | ;;Named function (e.g. recur) 224 | (reduce (fn accf [acc x] 225 | (if (odd? x) 226 | (accf acc (1+ x)) 227 | (+ acc x))) 228 | -55 '(1 2 3 4)) 229 | 230 | ;;these are cool, but we should be able to 231 | ;;eliminate the funcall need. 232 | (funcall (fn accf 233 | ([x] (list :end x)) 234 | ([x & xs] (reduce conj (vector x) xs) )) 235 | :beans) 236 | 237 | (funcall (fn accf 238 | ([x] (list :end x)) 239 | ([x & xs] (reduce conj (vector :end x) xs) )) 240 | 1 2 3 4) 241 | 242 | (funcall (fn accf 243 | ([x] (list :end x)) 244 | ([x & xs] (reduce conj [:end x] xs) )) 245 | 1 2 3 4) 246 | 247 | (defn count-to-ten [x] 248 | (if (< x 10) 249 | (recur (+ x 1)) 250 | x)) 251 | 252 | (count-to-ten 0) 253 | 254 | (defn count-to-ten-r [x] 255 | (if (< x 10) 256 | (count-to-ten-r (+ x 1)) 257 | x)) 258 | 259 | (defn lazy-count [init] 260 | (when (pos? init) 261 | (lazy-seq 262 | (cons init (lazy-count (- init 1)))))) 263 | -------------------------------------------------------------------------------- /keywordfunc.lisp: -------------------------------------------------------------------------------- 1 | ;;This is a legacy implementation of keywords-as-functions. 2 | ;;We'll probably revisit this. 3 | (defpackage :clclojure.keywordfunc 4 | (:use :common-lisp ;:clclojure.base 5 | :common-utils) 6 | (:export :keyfn? :key-accessor :->keyaccess :keyaccess-func :keyaccess-key :with-keyfn)) 7 | (in-package :clclojure.keywordfunc) 8 | 9 | (defparameter keyfns (make-hash-table)) 10 | (defun keyfn? (k) 11 | (gethash k keyfns)) 12 | 13 | ;;this is the general template for implementing 14 | ;;keyword access... 15 | ;; (defun :a (m) (gethash :a m)) 16 | ;; (defun (setf :a) (new-value m) 17 | ;; (setf (gethash :a m) 18 | ;; new-value)) 19 | 20 | (defun key-accessor (k) 21 | (let ((m (gensym "map")) 22 | (v (gensym "newval"))) 23 | `(progn (defun ,k (,m) (gethash ,k ,m)) 24 | (defun (,'setf ,k) (,v ,m) 25 | (,'setf (,'gethash ,k ,m) ,v)) 26 | ;(,'setf (gethash ,k keyfns) ,k) 27 | ))) 28 | 29 | ;;for localized keyaccess, i.e. inside 30 | ;;lets and friends.... 31 | (defclass keyaccess () 32 | ((key :initarg :key :accessor keyaccess-key) 33 | (func :accessor keyaccess-func)) 34 | (:metaclass sb-mop::funcallable-standard-class)) 35 | 36 | (defmethod initialize-instance :after ((obj keyaccess) &key) 37 | (with-slots (key func) obj 38 | (setf func (lambda (ht) 39 | (gethash key ht))) 40 | (sb-mop::set-funcallable-instance-function 41 | obj func) 42 | (eval (key-accessor key)) 43 | (setf (gethash key keyfns) obj) 44 | )) 45 | 46 | ;;keyaccessors print like keywords. 47 | (defmethod print-object ((obj keyaccess) stream) 48 | (prin1 (keyaccess-key obj) stream)) 49 | 50 | (defun ->keyaccess (k) 51 | (or 52 | (gethash k keyfns) 53 | (make-instance 'keyaccess :key k))) 54 | 55 | ;;now, to get the last step of "real" keyword access, we need to 56 | ;;detect when keyword literals used, and create keyword accessors for 57 | ;;them. One dirty way of doing that, is to use a reader macro for 58 | ;;keywords, and ensure that every single keyword that's read has a 59 | ;;commensurate keyaccess obj created. 60 | 61 | ;;That's effective, maybe not efficient, since we're duplicating our 62 | ;;keywords everywhere. A more efficient, but harder to implement, 63 | ;;technique is to macroexpand and walk the code inside a unified-let*. In 64 | ;;theory, we can detect any forms used in the function position, and 65 | ;;if they're keywords, compile them into keyword accessors. 66 | 67 | (defmacro with-keyfn (expr) 68 | (let ((k (first expr)) 69 | ) 70 | (if (keywordp k) 71 | (if (not (keyfn? k)) 72 | (progn (format nil "adding keyword access for: ~a " k ) 73 | (eval (key-accessor k)) 74 | `,expr)) 75 | `,expr))) 76 | 77 | 78 | ;;dumb testing 79 | ;; (defparameter ht (make-hash-table)) 80 | 81 | ;; (with-keyfn (:a ht)) 82 | ;; (with-keyfn (:b ht)) 83 | 84 | ;; (setf (:a ht) :bilbo) 85 | ;; (setf (:b ht) :baggins) 86 | 87 | ;; (with-keyfn (:a ht)) 88 | ;; (with-keyfn (:b ht)) 89 | 90 | 91 | -------------------------------------------------------------------------------- /lexical.lisp: -------------------------------------------------------------------------------- 1 | ;;Defining lexically scoped, unified variables and 2 | ;;functions with keyword access. 3 | (defpackage :clclojure.lexical 4 | (:use :common-lisp :clclojure.keywordfunc 5 | :common-utils) 6 | (:export :unified-let*)) 7 | (in-package :clclojure.lexical) 8 | 9 | ;;if the arg can be construed as a function, 10 | ;;the lexical symbol should be unified.. 11 | 12 | ;; (defmacro unify-binding (var) 13 | ;; `(cond ((functionp ,var) 14 | ;; (setf (symbol-function (quote ,var)) 15 | ;; ,var)) 16 | ;; ((keywordp ,var) 17 | ;; (if (not (keyfn? ,var)) 18 | ;; (progn (pprint (format nil "adding keyword access for: ~a " k )) 19 | ;; (eval (key-accessor ,var))))))) 20 | 21 | ;;we need to use let and flet instead of this... 22 | 23 | ;; (defmacro unify-binding (var) 24 | ;; `(cond ((functionp ,var) 25 | ;; (setf (symbol-function (quote ,var)) 26 | ;; ,var)) 27 | ;; ((keywordp ,var) 28 | ;; (if (not (keyfn? ,var)) 29 | ;; (progn (pprint (format nil "adding keyword access for: ~a " ,var )) 30 | ;; ;;(eval (key-accessor ,var)) 31 | ;; (setf (symbol-function (quote ,var)) 32 | ;; (->keyaccess ,var)) 33 | ;; ))))) 34 | 35 | ;;a couple of notes on evaluation and symbol/function namespaces, 36 | ;;including lexical scope.... 37 | ;;we have a few cases to cover... 38 | ;;if we want to cover every possible case and get a lisp1, 39 | ;;in the lexical case, we are relegated to using a combination 40 | ;;of let and flet on all the symbols 41 | ;; (let* ((g (->keyaccess :a)) 42 | ;; (lookup (->keyaccess :b))) 43 | ;; (labels ((g (arg) (funcall (keyaccess-func g) arg)) 44 | ;; (lookup (arg) (funcall (keyaccess-func lookup) arg))) 45 | ;; ;;(mapcar f (list keyfns keyfns)) 46 | ;; (pprint (list :obj lookup :fn (g keyfns))))) 47 | 48 | ;;this is an example of how we can play with lexical binds... 49 | ;;In the extreme case, we may not know what any types are, 50 | ;;which means they're functions or objects.... 51 | ;; (defun some-fn (z) 52 | ;; (let* ((g (lambda (x) (+ x 5))) ;;an actual function object... 53 | ;; (lookup (->keyaccess :b)) 54 | ;; (z (if (keywordp z) 55 | ;; (->keyaccess z) 56 | ;; z))) ;;keyword access function object... 57 | ;; (labels (;;general implementation of fn 58 | ;; (g (&rest args) (apply g args)) 59 | ;; ;;specific implementation for kw lookup.. 60 | ;; (lookup (arg) (funcall (keyaccess-func lookup) arg)) 61 | ;; (z (&rest args) (apply z args)) 62 | ;; ) 63 | ;; (pprint (list :obj g :fn (g 2) :keyaccess lookup 64 | ;; :z z :z-lookup (z keyfns) 65 | ;; (mapcar (lambda (x) (list :type x (type-of x))) 66 | ;; (list g lookup z))))))) 67 | 68 | ;;the only things that we know... are keywords, or fn forms bindings 69 | ;;are already in pairs... 70 | 71 | ;;Scrape the bindings to let*, and if we find keywords, 72 | ;;create an alist that associates the keyword to an 73 | ;;expression that defines a labels lexical function 74 | ;;for the keyword accessor. We compute/construct 75 | ;;a keyaccessor at compile time, and though it's 76 | ;;funcallable, we lookup its associated function 77 | ;;for use (and efficiency). We then provide 78 | ;;a simple function wrapper that invokes the keyword 79 | ;;fn (bear in mind, this is setfable). 80 | (EVAL-WHEN (:compile-toplevel :load-toplevel :execute) 81 | (defun keyword-accessors (bindings) 82 | (let ((arg (gensym "lookup")) 83 | (xs (common-utils:filter (lambda (lr) (keywordp (second lr))) bindings))) 84 | (when-not (null xs) 85 | (mapcar (lambda (lr) 86 | (pprint lr) 87 | (destructuring-bind (l r) lr 88 | (let ((f (keyaccess-func (->keyaccess r)))) 89 | (list r `(,l (,arg) (funcall (->keyaccess ,r) ,arg)))))) 90 | xs)))) 91 | 92 | ;;we use a generic apply here... collect all the args into a list and 93 | ;;apply. In clojure, there's some cost to that. Dunno what the 94 | ;;overhead is in CL. Also, if we "know" anything about the function, 95 | ;;we may be able to do some analysis and compile a more efficient 96 | ;;binding form (i.e. known number of args in the lambda. or simple 97 | ;;funcall... 98 | 99 | ;;There's some question about how much we know about the parameters at 100 | ;;runtime (specifically for let bindings). For certain classes of 101 | ;;lexical environments, we may be a-okay doing significant analysis of 102 | ;;what's involved in the let (case in point: if it's a lambda or a 103 | ;;known function we have meta on, we can derive types / args). Thats 104 | ;;a future optimization... 105 | 106 | ;;Note: if we don't refer to the lexical vars (NOT fns) for the 107 | ;;keywords, we end up with a slew of style warnings, since they don't 108 | ;;appear to be used (they are used for the lexical keyaccessors 109 | ;;though). To prevent this, we define a dummy function (never 110 | ;;invoked) that builds a list composed from the symbol-values. For 111 | ;;now, it's convenient. I may revisit this to see if we can detect if 112 | ;;the symbols aren't validly used... 113 | 114 | ;;we get compiler complaints with this if we don't... 115 | 116 | (defun functionize-bindings (bindings) 117 | (let* ((kwalist (keyword-accessors bindings)) 118 | (vars (mapcar (lambda (lr) (first (second lr))) kwalist)) 119 | (dummy (gensym "dummyfn"))) 120 | (cons `(,dummy () (list :this-prevents-warnings-nothing-else 121 | ,@vars)) 122 | (mapcar (lambda (lr) 123 | (destructuring-bind (l r) lr 124 | (if (keywordp r) 125 | (second (assoc r kwalist)) 126 | `(,l (,'&rest ,'args) (apply ,l ,'args))))) 127 | bindings))))) 128 | 129 | ;;so at the lexical level, we need to analyze the bindings. 130 | ;;determine if an item is a function (or an applicable object like 131 | ;;a keyword), and create matching labels for them... 132 | 133 | ;;this acts like let*, except it allows bindings that may be functions 134 | ;;or things that can act like functions -> keywords. Everything else 135 | ;;should be covered by a funcallable object... We unify the 136 | ;;symbol-value and symbol-function namespaces in the lexical context, 137 | ;;detecting the need to generate keyword accessors. 138 | (defmacro unified-let* (bindings &rest body) 139 | `(let* (,@bindings) 140 | (labels (,@ (functionize-bindings bindings) 141 | ) 142 | ,@body))) 143 | 144 | ;;a simple test function to tie everything together. 145 | (defun test-my-scope () 146 | (unified-let* ((hello :hello) ;;we create (or lookup cached) keyaccess funcallable objects 147 | (world :world) ;;when we have literal keywords bound to symbols. 148 | (k 2) 149 | (inc (lambda (x) (+ x 1))) 150 | (add (lambda (x y) (+ x y))) 151 | (tbl (unified-let* ((tbl (make-hash-table))) 152 | (setf (gethash :hello tbl) "World") 153 | (setf (gethash :world tbl) "Hello") 154 | (setf (gethash :k tbl) k) 155 | tbl))) 156 | (list (hello tbl) 157 | (world tbl) 158 | (add (inc 39) k) 159 | ;;(:k tbl) ;;doesn't work without some extra macro magic... 160 | (funcall (->keyaccess :k) tbl) ;;it will look like this behind the scenes. 161 | ))) 162 | 163 | ;;LEXICAL> (test-my-scope) 164 | ;;("World" "Hello" 42 2) ;;works! 165 | -------------------------------------------------------------------------------- /literals.lisp: -------------------------------------------------------------------------------- 1 | (defpackage clclojure.literals 2 | (:use :common-lisp 3 | :clclojure.eval 4 | :clclojure.pvector 5 | :clclojure.cowmap)) 6 | (in-package :clclojure.literals) 7 | ;;Data Literal Eval Semantics 8 | 9 | (EVAL-WHEN (:compile-toplevel :load-toplevel :execute) 10 | (clclojure.eval:enable-custom-eval) 11 | ;;(eval [x y z]) => (vector (eval x) (eval y) (eval z)) 12 | ;;this is somewhat inefficient since we're not exploiting 13 | ;;chunks, but good enough for proof of concept. We do 14 | ;;have chunks, fyi. 15 | (defmethod clclojure.eval::literal? ((obj pvec)) t) 16 | (defmethod custom-eval ((obj pvec) &optional env) 17 | (vector-map (lambda (x) (clclojure.eval:custom-eval-in-lexenv x env)) obj)) 18 | 19 | (defmethod let-expr ((obj pvec)) 20 | ;; `(clclojure.eval:literal 21 | ;; (clclojure.pvector:persistent-vector ,@(clclojure.pvector:vector-to-list obj))) 22 | (list 'clclojure.reader::literal 23 | (list* 'clclojure.reader::data-literal 24 | (list 'function 'persistent-vector) 25 | `((list ,@(vector-to-list obj))))) 26 | ) 27 | 28 | ;; (defmethod let-expr ((obj pvec)) 29 | ;; obj) 30 | 31 | (defmethod clclojure.eval::literal? ((obj subvector)) t) 32 | (defmethod custom-eval ((obj subvector) &optional env) 33 | (vector-map (lambda (x) (clclojure.eval:custom-eval-in-lexenv x env)) obj)) 34 | 35 | (defmethod let-expr ((obj subvector)) 36 | ;; `(clclojure.eval:literal 37 | ;; (clclojure.pvector:persistent-vector ,@(clclojure.pvector:vector-to-list obj))) 38 | (list 'clclojure.reader::literal 39 | (list* 'clclojure.reader::data-literal 40 | (list 'function 'persistent-vector) 41 | `((list ,@(vector-to-list obj))))) 42 | ) 43 | 44 | (defmethod clclojure.eval::literal? ((obj cowmap)) t) 45 | ;;(map {x y j k} => (persistent-map 46 | ;;(clclojure.eval:custom-eval-in-lexenv x) 47 | ;;(clclojure.eval:custom-eval-in-lexenv y) 48 | ;;(clclojure.eval:custom-eval-in-lexenv j) 49 | ;;(clclojure.eval:custom-eval-in-lexenv k)) 50 | 51 | (defmethod custom-eval ((obj cowmap) &optional env) 52 | (reduce (lambda (acc kv) 53 | (destructuring-bind (k v) kv 54 | (map-assoc acc (clclojure.eval:custom-eval-in-lexenv k env) 55 | (clclojure.eval:custom-eval-in-lexenv v env)))) 56 | (map-seq obj) :initial-value (empty-map))) 57 | 58 | (defmethod let-expr ((obj cowmap)) 59 | ;; `(clclojure.eval:literal 60 | ;; (clclojure.cowmap:persistent-map 61 | ;; ,@(reduce (lambda (acc kv) 62 | ;; (cons (first kv) (cons (second kv) acc))) 63 | ;; (clclojure.cowmap:map-seq obj) :initial-value '()))) 64 | (list 'clclojure.reader::literal 65 | (list* 'clclojure.reader::data-literal 66 | (list 'function 'persistent-map) 67 | `((list ,@(reduce (lambda (acc kv) 68 | (cons (first kv) (cons (second kv) acc))) 69 | (clclojure.cowmap:map-seq obj) :initial-value '())))))) 70 | 71 | 72 | ) 73 | -------------------------------------------------------------------------------- /pmap.lisp: -------------------------------------------------------------------------------- 1 | ;This is an implementation of Clojure's 2 | ;persistent map for Common Lisp. 3 | (defpackage :clclojure.pmap 4 | (:use :common-lisp) 5 | (:export :persistent-map 6 | :empty-map? 7 | :pmap-count 8 | :pmap-map 9 | :pmap-reduce) 10 | (:shadow :assoc 11 | :find)) 12 | ; :pmap-chunks 13 | ; :pmap-element-type 14 | ; :pmap-assoc 15 | ; :pmap-nth)) 16 | (in-package clojure.pmap) 17 | 18 | ;Original from Stack Overflow, with some slight modifications. 19 | (defun |brace-reader| (stream char) 20 | "A reader macro that allows us to define persistent maps 21 | inline, just like Clojure." 22 | (declare (ignore char)) 23 | `(persistent-map ,@(read-delimited-list #\] stream t))) 24 | (set-macro-character #\{ #'|brace-reader|) 25 | (set-syntax-from-char #\} #\)) 26 | 27 | 28 | ;;Currently deferred... 29 | ;;For now, we'll just use a COW map implementation 30 | ;;i.e. wrap a hashtable and copy its contents... 31 | 32 | 33 | (define-condition not-implemented (error) 34 | ((text :initarg :text :reader text))) 35 | 36 | ;utility functions 37 | 38 | ;Persistent maps require a lot of array copying, and 39 | ;according to the clojure implementation, bit-twiddling. 40 | 41 | ;porting from Spiewak's excellent blog post, 42 | ;which is a port from Clojure's implementation. 43 | (defconstant +branches+ 32) ;use a 32-way trie.... 44 | ;a bytespec is like a window.. 45 | ;it's a user-defined set of continugous bits in an integer 46 | ;use (byte width position) to define the window... 47 | (defconstant +bit-width+ 5) 48 | (defconstant +mask+ (byte +bit-width+ 0)) ;denotes [00000] with "weights" [2^4 2^3 2^2 2^1 2^0] 49 | 50 | (defun >>> (i n) 51 | "Shift integer i by n bits to the right." 52 | (ash i (* -1 n))) 53 | 54 | (defun <<< (i n) 55 | "Shift integer i by n bits to the left." 56 | (ash i n)) 57 | 58 | (defun last-five-bits (n) 59 | "Helper to mask everything but the 5 least-significant bits." 60 | (mask-field +mask+ n)) 61 | 62 | (defun mask (hash shift) 63 | "Helper, used by maps. Maps a hash into a local index at 64 | given level in the trie." 65 | (last-five-bits (>>> hash shift))) 66 | 67 | (defun bit-pos (hash shift) 68 | "Helper to compute the bit-position of n from a mask. This provides 69 | a mapping to the nth bit" 70 | (<<< 1 (mask hash shift))) 71 | 72 | (defun index (n) 73 | "Given an index into a hash, which represents a sparse mapping of values 74 | from [0 31] to n children, we can find out which child the index represents 75 | by using a logical count of the 1 bits in n." 76 | (logcount (1- n))) 77 | 78 | (define-condition index-out-of-bounds (error) 79 | ((text :initarg :text :reader text))) 80 | 81 | (defun copy-vector (array n &key 82 | (element-type (array-element-type array)) 83 | (fill-pointer (and (array-has-fill-pointer-p array) 84 | (fill-pointer array))) 85 | (adjustable (adjustable-array-p array))) 86 | "Returns an undisplaced copy of ARRAY, with same fill-pointer and 87 | adjustability (if any) as the original, unless overridden by the keyword 88 | arguments. " 89 | (let* ((dimensions (incf (first (array-dimensions array)) n)) 90 | (new-array (make-array dimensions 91 | :element-type element-type 92 | :adjustable adjustable 93 | :fill-pointer fill-pointer))) 94 | (dotimes (i (array-total-size array)) 95 | (setf (row-major-aref new-array i) 96 | (row-major-aref array i))) 97 | new-array)) 98 | 99 | ;Persistent Map definition: 100 | 101 | ;A persistent hashmap is a small structure that points to a root node. 102 | ;It also contains information about the underlying trie, such as null 103 | ;keys, the count of elements, etc. 104 | (defstruct pmap (count 0) (root nil) (has-null nil) (null-value nil)) 105 | (defun ->pmap (count root has-null null-value) 106 | (make-instance pmap :count count 107 | :root root 108 | :has-null has-null 109 | :null-value null-value)) 110 | (defconstant +empty-map+ (->pmap)) 111 | (defun empty-map () +empty-map+) 112 | 113 | ;The INode interface is crucial. We dispatch based on the node types... 114 | ;We'll implement the interface as a set of generic functions. 115 | 116 | (defgeneric assoc (nd shift hash key val &optional addedLeaf)) 117 | (defgeneric without (nd shift hash key)) 118 | (defgeneric find (shift hash key)) 119 | ;(defgeneric find(shift hash key notFound)) 120 | (defgeneric nodeSeq (nd)) 121 | ; assoc(AtomicReference edit, int shift, int hash, Object key, Object val, Box addedLeaf); 122 | ;INode without(AtomicReference edit, int shift, int hash, Object key, Box removedLeaf); 123 | (defgeneric kvreduce (f init)) 124 | ;(defgeneric fold (combinef reducef fjtask fjfork fjjoin)) 125 | 126 | ;;note -> clojure's implementation uses an object array... 127 | ;;so that the distinction between nodes and data is blurred. 128 | ;;a node is just a thread-safe wrapper around an object array. 129 | ;;in CL, this is just an array without an initial type arg. 130 | (defun make-data (&key (branches +branches+) (element-type t) (initial-element nil)) 131 | "Standard constructor for a node in our hash trie." 132 | (if (and (null initial-element) 133 | (not (eq element-type t))) 134 | (make-array branches :element-type element-type) 135 | (make-array branches :element-type element-type :initial-element initial-element))) 136 | 137 | (defun make-node () (make-data)) 138 | (defun make-indexed-node () 139 | (make-data :branches +indexed-branches+)) 140 | 141 | ;define implementations for different node types: 142 | 143 | ;-Type identifier for empty nodes, i.e. empty maps. 144 | ;empty-node 145 | ;(defstruct empty-node 146 | 147 | ;-Type identifier for nodes with a single value. 148 | ;-This is optimized away in the clojure java implementation... 149 | ;leaf-node 150 | 151 | ;-Type identifier for nodes with 16 key/vals (full or array nodes). 152 | (defstruct array-node count (nodes (make-data))) 153 | (defun ->array-node (count nodes) 154 | (make-array-node :count count :nodes nodes)) 155 | 156 | ;-Type identifier for nodes that project a 32-bit index, the 157 | ;-bitmap, onto an array with less than 32 elements. 158 | ;bitmapindexed-node 159 | (defconstant +indexed-branches+ 16) ;indexes contained 8 keyval pairs. 160 | (defstruct indexed-node (bitmap 0) (nodes (make-data :branches +indexed-branches+)) ) 161 | (defun ->indexed-node (bitmap nodes) 162 | (make-indexed-node :bitmap bitmap :nodes nodes)) 163 | (defconstant +empty-indexed-node+ (make-indexed-node)) 164 | (defun empty-indexed-node () +empty-indexed-node+) 165 | 166 | (declaim (inline key-idx val-idx key-at-idx val-at-idx)) 167 | (defun key-idx (idx) 168 | "Return the offset key of an index" 169 | (* 2 idx)) 170 | (defun val-idx (idx) 171 | "Return the offset value of an index" 172 | (1+ (* 2 idx))) 173 | 174 | 175 | (defun equiv (x y) 176 | "Generic equality predicate." 177 | (error 'not-implemented)) 178 | 179 | (defun key-at-idx (idx nodes) 180 | "Fetches the offset key from an array 181 | packed like a propertylist, key/val/key/val/..." 182 | (aref nodes (* 2 idx))) 183 | 184 | (defun val-at-idx (idx nodes) 185 | "Fetches the offset value from an array 186 | packed like a propertylist, key/val/key/val/..." 187 | (aref nodes (1+ (* 2 idx)))) 188 | 189 | (defun pairs (xs) 190 | "Aux function that converts a list of xs into 191 | a list of pairs." 192 | (do ((acc (list)) 193 | (remaining xs (rest (rest remaining)))) 194 | ((null remaining) (nreverse acc)) 195 | (let ((x (first remaining)) 196 | (y (second remaining))) 197 | (when (and x y) 198 | (push (list x y) acc))))) 199 | 200 | (defun assoc-array (arr idx k v) 201 | (progn (setf (aref arr (key-idx idx)) k) 202 | (setf (aref arr (val-idx idx)) v))) 203 | 204 | (defun hash (o) 205 | "Generic hash function." 206 | (error 'not-implemented)) 207 | 208 | (defun remove-pair (array idx) 209 | "Auxillary function to drop pairs from an array 210 | where the pairs are packed akin to a plist, ex. 211 | key/val/key/val....returns a new, smaller array 212 | with the pair removed." 213 | (error 'not-implemented) 214 | (cond ((> idx (- (1- (array-total-size array)) 2)) 215 | (error 'index-out-of-bounds)) 216 | ((and (= (array-total-size array) 2) (= idx 0)) 217 | nil) 218 | (t 219 | (let* ((dimensions (decf (first (array-dimensions array)) 2)) 220 | (new-array (make-array dimensions 221 | :element-type (array-element-type array) 222 | :fill-pointer (and (array-has-fill-pointer-p array) 223 | (fill-pointer array)) 224 | :adjustable (adjustable-array-p array)))) 225 | (loop for i from 0 to (1- idx) 226 | do (assoc-array new-array i (key-at-idx i array) (val-at-idx i array))) 227 | (loop for i from (1+ idx) to (- (array-total-size new-array) 2) 228 | do (assoc-array new-array (1- i) (key-at-idx i array) (val-at-idx i array))) 229 | new-array)))) 230 | 231 | (defun insert-pair (array idx k v) 232 | "Auxillary function to drop pairs from an array 233 | where the pairs are packed akin to a plist, ex. 234 | key/val/key/val....returns a new, smaller array 235 | with the pair removed." 236 | (error 'not-implemented) 237 | (cond ((> idx (1- (- (array-total-size array) 2))) 238 | (error 'index-out-of-bounds)) 239 | (t 240 | (let* ((dimensions (incf (first (array-dimensions array)) 2)) 241 | (new-array (make-array dimensions 242 | :element-type (array-element-type array) 243 | :fill-pointer (and (array-has-fill-pointer-p array) 244 | (fill-pointer array)) 245 | :adjustable (adjustable-array-p array)))) 246 | (loop for i from 0 to (1- idx) 247 | do (assoc-array new-array i (key-at-idx i array) (val-at-idx i array))) 248 | (assoc-array new-array idx k v) 249 | (when (< idx (1- (/ (array-total-size array) 2))) 250 | (loop for i from idx to (1- (/ (array-total-size new-array) 2)) 251 | do (assoc-array new-array (1+ i) (key-at-idx i array) (val-at-idx i array)))) 252 | new-array)))) 253 | ;; INode createNode(int shift, Object key1, Object val1, int key2hash, Object key2, Object val2) { 254 | ;; int key1hash = hash(key1); 255 | ;; if(key1hash == key2hash) 256 | ;; return new HashCollisionNode(null, key1hash, 2, new Object[] {key1, val1, key2, val2}); 257 | ;; Box _ = new Box(null); 258 | ;; AtomicReference edit = new AtomicReference(); 259 | ;; return BitmapIndexedNode.EMPTY 260 | ;; .assoc(edit, shift, key1hash, key1, val1, _) 261 | ;; .assoc(edit, shift, key2hash, key2, val2, _) 262 | ; 263 | (defun create-node (shift key1 val1 key2hash key2 val2) 264 | "Generic function to create nodes....I need a better 265 | explanation. Also, the box var may not be necessary. 266 | I have to see how it's used..." 267 | (let ((key1hash (hash key1))) 268 | (if (= key1hash key2hash) 269 | ;record the hash collision with a new collision node, these will chain. 270 | (->collision-node key1hash 2 (vector key1 val1 key2 val2)) 271 | (let ((box (list))) ;else assoc both values into an empty indexed node. 272 | (assoc (assoc (empty-indexed-node) shift key1hash key1 val1 box) 273 | shift key2hash key2 val2 box))))) 274 | 275 | (defun clone-and-set (arr &rest kvps) 276 | "Aux function that clones an array and 277 | sets the element at idx = to v, where 278 | idx and v are drawn from the list kvps." 279 | (let ((acc (copy-vector arr 0))) 280 | (loop for (idx v) in (pairs kvps) 281 | do (setf (aref acc idx) v) 282 | finally (return acc)))) 283 | 284 | (declaim (inline bit-set?)) 285 | (defun bit-set? (bitmap i) 286 | "Determines if the ith bit is set in bitmap." 287 | (not (zerop (logand (>>> bitmap i) 1)))) 288 | 289 | (defun indexed-array->full-array (nodes bitmap shift hash key val addedleaf) 290 | "Projects an indexed array, indexed by a 32-bit map, 16 (unknown) 291 | bits of which indicate the presence of a key in an an underlying 292 | 32-element assoc array, onto an full array. The full array is 293 | a direct mapping of a 32-bit key, projected onto a 32 element 294 | array of nodes, by masking all but the last 5 bits. This is 295 | basically an optimization, so that we use indexed nodes while 296 | the node is sparse, when the keys are <= 16, then shift to a 297 | node with no intermediate bit mapping." 298 | (let ((newnodes (make-data)) ;create the 32 element array for the arraynode. 299 | (jdx (mask hash shift)) ;set the index for the element we're adding. 300 | (j 0)) 301 | (progn (setf (aref newnodes jdx) ;initialze the newly added node. 302 | (assoc (empty-indexed-node) 303 | (+ 5 shift) hash key val addedleaf)) 304 | (loop for i from 0 to 32 ;traverse the bitmap, cloning... 305 | do (when (bit-set? bitmap i) ;bit i is stored at j 306 | (if (null (aref nodes j)) 307 | (setf (aref newnodes i) (aref nodes (1+ j))) 308 | (assoc (empty-indexed-node) 309 | (+ 5 shift) 310 | (hash (aref nodes j)) 311 | (aref nodes j) 312 | (aref nodes (1+ j)) 313 | addedleaf)) 314 | (incf j 2))) 315 | newnodes))) 316 | 317 | 318 | (defun indexed-node->array-node (nd shift hash key val addedleaf) 319 | "Projects an indexed node, indexed by a 32-bit map, 16 (unknown) 320 | bits of which indicate the presence of a key in an an underlying 321 | 32-element assoc array, onto an array node. The array node is 322 | a direct mapping of a 32-bit key, projected onto a 32 element 323 | array of nodes, by masking all but the last 5 bits. This is 324 | basically an optimization, so that we use indexed nodes while 325 | the node is sparse, when the keys are <= 16, then shift to a 326 | node with no intermediate bit mapping." 327 | (with-slots (bitmap nodes) nd 328 | (->array-node (1+ (logcount bitmap)) 329 | (indexed-array->full-array nodes bitmap shift 330 | hash key val addedleaf)))) 331 | 332 | ;Partially implemented. 333 | ;; (defmethod assoc ((nd indexed-node) shift hash key val addedLeaf) 334 | ;; (with-slots (bitmap nodes) nd 335 | ;; (let ((b (bit-pos hash shift)) 336 | ;; (idx (index b)) 337 | ;; (exists? (not (zerop (logand bitmap b))))) 338 | ;; (if exists? 339 | ;; (let ((k (key-at-idx idx nodes)) 340 | ;; (v (val-at-idx idx nodes))) 341 | ;; (cond ((null k) 342 | ;; (let ((newnode (assoc v (+ 5 shift) hash key val addedleaf))) 343 | ;; (if (eq val-at-idx newnode) 344 | ;; nd ;no node to add to null key. 345 | ;; ;actually have val associated with null, causes changed. 346 | ;; (->indexed-node bitmap (clone-and-set nodes (val-idx idx) newnode))))) 347 | ;; ((equiv key k) ;key exists. 348 | ;; (if (eq v val) 349 | ;; nd ;no change 350 | ;; ;value changed 351 | ;; (->indexed-node bitmap (clone-and-set nodes (val-idx idx) val)))) 352 | ;; (t 353 | ;; (->indexed-node bitmap (clone-and-set nodes (key-idx idx) nil 354 | ;; (val-idx idx) (create-node (+ 5 shift) k v hash key val))))) 355 | ;; ) 356 | ;; (if (>= (logcount bitmap) +indexed-branches+) 357 | ;; ;create an array node, or full node, if the number of on-bits is excessive. 358 | ;; (indexed-node->array-node nd shift hash key val addedleaf) 359 | ;; (let ((newarray (copy-vector nodes 2))) 360 | ;; (progn ( 361 | 362 | ;; )))))) 363 | 364 | 365 | ;-Type identifier for nodes that have a direct correspondence 366 | ;-between a 5 bit integer hash and an entry in the 32 element 367 | ;-node array. 368 | ;full-node 369 | 370 | 371 | ;-Type identifier for nodes that collide. Essentially, a 32 372 | ;-element array of nodes that have the same hash. I have an 373 | ;-idea of how this works using the 5 bit hashing scheme. 374 | ;collision-node 375 | (defstruct collision-node hash count nodes) 376 | (defun ->collision-node (hash count nodes) 377 | (make-instance collision-node 378 | :hash hash 379 | :count count 380 | :nodes nodes)) 381 | 382 | (defconstant +empty-pvec+ (make-pvec)) 383 | (defun empty-vec () +empty-pvec+) 384 | (defun empty-vec? (v) (eq v +empty-pvec+)) 385 | 386 | (defgeneric vector-count (v) 387 | (:documentation 388 | "Fetches the count of items in the persistent vector.")) 389 | 390 | (defmethod vector-count ((v pvec)) 391 | (pvec-counter v)) 392 | 393 | (defun tail-end (n &optional (b +branches+)) 394 | "Given a count of items, n, where is the tail located in an integer 395 | hash? Note, this assumes a 5 bit encoding for levels in an 32-way 396 | trie. I might generalize this later..." 397 | (if (< n b) 398 | 0 399 | (<<< (>>> (1- n) +bit-width+) +bit-width+))) 400 | 401 | (defun tail-off (v) 402 | "Defines the integer index at which the tail starts." 403 | (tail-end (pvec-counter v) +branches+)) 404 | 405 | (defun count-tail (v) (length (pvec-tail v))) 406 | 407 | (defun find-node (rootnode shift idx) 408 | "Given a rootnode with child nodes, a bit-shift amount, and an index, 409 | traverses the rootnode's children for the node defined by idx." 410 | (if (<= shift 0) 411 | rootnode ;found our guy 412 | (find-node (aref rootnode (last-five-bits (>>> idx shift))) 413 | (- shift +bit-width+) idx))) 414 | 415 | (defun copy-path (root shift0 idx &optional (leaf-function #'identity)) 416 | "Copies the nodes from root to idx, returning a new root. If a leaf function 417 | is provided, it will be applied to the final node. If the path does not exist, 418 | intermediate structures WILL be created." 419 | (labels ((walk (rootnode shift) 420 | (if (zerop shift) 421 | (funcall leaf-function rootnode) 422 | (let ((childidx (last-five-bits (>>> idx shift))) 423 | (newnode (if (null rootnode) 424 | (make-node) 425 | (copy-vector rootnode 0)))) 426 | (progn (setf (aref newnode childidx) 427 | (walk (if (null rootnode) 428 | (make-node) 429 | (aref rootnode childidx)) 430 | (- shift +bit-width+))) 431 | newnode))))) 432 | (walk root shift0))) 433 | 434 | (defun insert-path (rootnode shift idx x) 435 | "Copies the path to the node at idx, replacing the value of the final node 436 | on the path, the address at idx, with value x." 437 | (copy-path rootnode shift idx 438 | #'(lambda (node) 439 | (progn (setf (aref node (last-five-bits idx)) x) 440 | node)))) 441 | 442 | (defgeneric get-node (v idx) 443 | (:documentation 444 | "Fetches the node (an object array) at index idx, from 445 | persistent vector v, where idx is 0-based. Currently assumes 446 | 5-bit encoding of integer keys for each level, thus 32 elements 447 | per level.")) 448 | 449 | (defmethod get-node ((v pvec) idx) 450 | (if (and (<= idx (pvec-counter v)) (>= idx 0)) 451 | (if (>= idx (tail-end (pvec-counter v) +branches+)) 452 | (pvec-tail v) 453 | (find-node (pvec-root v) (pvec-shift v) idx)) 454 | (error 'index-out-of-bounds))) 455 | 456 | (defgeneric nth-vec (v idx) 457 | (:documentation "Returns the nth element in a persistent vector.")) 458 | (defmethod nth-vec ((v pvec) idx) 459 | (aref (get-node v idx) (last-five-bits idx))) 460 | 461 | ;copy-vector should probably use displaced arrays. 462 | (defun conj-tail (v x) 463 | "Conjoins item x onto pvector v's tail node, returning a new pvector that 464 | uses the new tail, along with an incremented count." 465 | (let ((newtail (if (null (pvec-tail v)) 466 | (vector x) 467 | (let ((growntail (copy-vector (pvec-tail v) 1))) 468 | (progn (setf (aref growntail (1- (length growntail))) x) 469 | growntail))))) 470 | (make-pvec :root (pvec-root v) 471 | :tail newtail 472 | :shift (pvec-shift v) 473 | :counter (1+ (pvec-counter v))))) 474 | 475 | (defun new-path (shift node) 476 | "Given a node and an amount of initial 'shift', recursively builds 477 | a nested tree of nodes, currently 32-wide arrays, linked by the first element, 478 | with node at the logical 'bottom' of the tree, where shift = 0. This allows us 479 | to inject a node, with the required path structure, into the trie, if the path did 480 | not exist before. Typically used for inserting the tail into the pvector." 481 | (if (zerop shift) 482 | node 483 | (let ((newnode (make-node))) 484 | (progn (setf (aref newnode 0) 485 | (new-path (- shift +bit-width+) node)) 486 | newnode)))) 487 | -------------------------------------------------------------------------------- /reader.lisp: -------------------------------------------------------------------------------- 1 | ;;A package for defining read table extensions 2 | ;;for clojure data structures. 3 | 4 | ;;Pending.................. 5 | (defpackage :clclojure.reader 6 | (:shadowing-import-from :sequences :first :second :cons :apply :map :filter :rest :reduce :flatten) 7 | (:use :common-lisp :common-utils :named-readtables :clclojure.pvector :clclojure.cowmap 8 | :sequences) 9 | (:export :*literals* :*reader-context* :quoted-children :quote-sym :literal?)) 10 | (in-package :clclojure.reader) 11 | 12 | (EVAL-WHEN (:compile-toplevel :load-toplevel :execute) 13 | 14 | ;;Problem right now is that, when we read using delimited-list, 15 | ;;we end up losing out on the reader literal for pvecs and the like... 16 | ;;When we have quoted 17 | 18 | ;;we can use a completely custom reader...perhaps that's easiet.. 19 | ;;Have to make this available to the compiler at compile time! 20 | ;;Maybe move this into a clojure-readers.lisp or something. 21 | 22 | ;;alist of literals... 23 | (defparameter *literals* '(list) ; '(list cons) 24 | ) 25 | (defparameter *reader-context* :read) 26 | ;;default quote...o 27 | ;; (comment 28 | ;; (set-macro-character #\' 29 | ;; #'(lambda (stream char) 30 | ;; (declare (ignore char)) 31 | ;; `(quote ,(read stream t nil t))))) 32 | (defun quote-sym (sym) (list 'quote sym)) ;`(quote ,sym) 33 | ;; (defmacro quoted-children (c) 34 | ;; `(,(first c) ,@(mapcar #'quote-sym (rest c)))) 35 | 36 | (defun dotted-pair? (xs) 37 | (and (listp xs) 38 | (not (listp (cdr xs))))) 39 | 40 | (defun literal? (s) (or (and (listp s) (find (first s) *literals*)) 41 | (and (symbolp s) (find s *literals*)))) 42 | 43 | (defun literal (obj) obj) 44 | 45 | (defmacro quoted-children (c) 46 | (if (symbolp c) 47 | `(quote ,c) 48 | `(,(first c) 49 | ,@ (sequences::seq->list 50 | (map (lambda (s) 51 | (cond ((literal? s) ;;we need to recursively call quoted-children.. 52 | `(quoted-children ,s)) 53 | ((dotted-pair? s) 54 | `(quote ,s)) 55 | ((listp s) 56 | `(quoted-children ,(cons (quote list) s))) 57 | (t (funcall #'quote-sym s)))) (rest c)))))) 58 | 59 | ;;Enforces quoting semantics for literal data structures.. 60 | ;;We may not need this anymore since we hacked eval. 61 | (defmacro clj-quote (expr) 62 | 63 | (cond ((literal? expr) `(quoted-children ,expr)) 64 | ((dotted-pair? expr) `(quote ,expr)) 65 | ((listp expr) 66 | `(quoted-children ,(cons (quote list) expr))) 67 | (t 68 | (quote-sym expr)))) 69 | 70 | (defun as-char (x) 71 | (cond ((characterp x) x) 72 | ((and (stringp x) 73 | (= 1 (length x))) (char x 0)) 74 | ((symbolp x) (as-char (str x))) 75 | (t (error (str (list "invalid-char!" x) )))) 76 | ) 77 | 78 | ;;Gives us clj->cl reader for chars... 79 | (set-macro-character #\\ 80 | #'(lambda (stream char) 81 | (declare (ignore char)) 82 | (let ((res (read stream t nil t))) 83 | (as-char res))) 84 | ) 85 | 86 | ;;Doesn't work currently, since we can't redefine 87 | ;;print-method for chars... 88 | (defun print-clj-char (c &optional (stream t)) 89 | "Generic char printer for clojure-style syntax." 90 | (format stream "\~c" c)) 91 | 92 | (defun print-cl-char (c &optional (stream t)) 93 | "Generic char printer for common lisp syntax." 94 | (format stream "#\~c" c)) 95 | 96 | (defun quoted-read (stream char) 97 | (declare (ignore char)) 98 | (let ((res (read stream t nil t))) 99 | (if (atom res) `(quote ,res) 100 | `(clj-quote ,res)))) 101 | 102 | ;;This should be consolidated... 103 | (set-macro-character #\' 104 | #'quoted-read) 105 | 106 | 107 | ;;need to define quasiquote extensions... 108 | ;;quasiquoting has different behavior for literal datastructures.. 109 | ;;in the case of clojure, we provide fully-qualified symbols vs. 110 | ;;standard CL-symbols. We have reader support for them, 111 | ;;that is, blah/x vs x. 112 | 113 | ;;so, clojure resolves the symbol in the current ns, at read-time. 114 | 115 | ;; (defun resolved-symbol (s) 116 | ;; (let* ((this-package (package-name *package*))) 117 | ;; (multiple-value-bind (x y) 118 | ;; (find-symbol (symbol-name s)) 119 | ;; (if x 120 | ;; ;;symbol exists 121 | ;; `(,(package-name (symbol-package x)) ,(symbol-name x)) 122 | ;; `(,this-package ,(symbol-name s)) 123 | ;; )))) 124 | 125 | ;; (defun qualify (s) 126 | ;; (apply #'common-utils::symb 127 | ;; (let ((res (resolved-symbol s))) 128 | ;; (list (first res) "::" (second res))))) 129 | 130 | ;; (defun quasi-quoted-read (stream char) 131 | ;; (declare (ignore char)) 132 | ;; (let ((res (read stream t nil t))) 133 | ;; (cond ((symbolp res) 134 | ;; (let ((resolved ))) 135 | ;; `(quote ,res)) 136 | ;; (t `(clj-quote ,res))))) 137 | 138 | ;;Additionally, for dataliterals, quasiquote serves as a template 139 | ;;for building said datastructure, as if by recursively quasiquoting 140 | ;;elements in the expression. 141 | 142 | ;;Additionally, clojure 143 | 144 | ;;we can get package-qualified symbols via: 145 | ;;`(common-lisp-user::x) 146 | ;;but they print as 'x 147 | 148 | ;;s.t. `[x y] 149 | ;;namespace-qualified symbols are kind of out of bounds at the 150 | ;;moment... 151 | 152 | (defun push-reader! (literal ldelim rdelim rdr) 153 | (progn (setf *literals* (union (list literal) *literals*)) 154 | (set-macro-character ldelim rdr) 155 | (set-syntax-from-char rdelim #\)))) 156 | 157 | (defun quoting? () (> sb-impl::*backquote-depth* 0)) 158 | 159 | ;;This now returns the actual pvector of items read from 160 | ;;the stream, versus a quoted form. Should work nicely 161 | ;;with our protocol definitions now! 162 | 163 | 164 | ;;The issue we run into with our EDN forms is this: 165 | ;;(defparameter x 2) 166 | ;;(eval [x]) 167 | ;;should yield [2] 168 | 169 | ;;we don't currently. 170 | ;;So, 171 | 172 | ;;Quasiquoting custom data literals.. 173 | ;;=================================== 174 | ;;THis is way janky... 175 | ;;I'm not afraid to say I don't know how I pulled this off. 176 | ;;The key is that the quasiquoting mechanism in backq.lisp 177 | ;;has a sb-int:comma struct to denote 3 kinds of commas: 178 | ;;0 -> ,x 179 | ;;1 -> ,.x 180 | ;;2 -> ,@x 181 | 182 | ;;We ignore the dot version for now, although it's probably simple 183 | ;;enough to get working. 184 | ;;So we just manually build the expression. 185 | ;;If it's not a comma, we quasiquote it and let the macroexpander 186 | ;;figure it out. 187 | 188 | ;; (case (sb-int:comma-kind x) 189 | ;; (0 (cons expr acc)) 190 | ;; ;;I don't think we want to eval here. 191 | ;; (2 (progn (pprint expr) 192 | ;; (common-lisp:reduce (lambda (a b) (cons b a)) expr :initial-value acc) 193 | ;; ;(nreverse (list (list 'apply '(function concat) expr))) 194 | ;; )) 195 | ;; (1 (error "comma-dot not handled!"))) 196 | 197 | (defun quoted (x) 198 | (cond ((symbolp x) 199 | (scase x 200 | ((function list cons apply sequences::seq->list) x) 201 | (t (list 'quote x)))) 202 | ((listp x) (scase (first x) 203 | ((function quote clj-quote) x) 204 | (t (mapcar #'quoted x)))) 205 | (t x))) 206 | 207 | (defmacro quoted-body (x) 208 | (list 'quote (quoted x))) 209 | 210 | (defun quasify (xs) 211 | (list 'apply '(function concat) 212 | (nreverse 213 | (common-lisp:reduce 214 | (lambda (acc x) 215 | (if (sb-int:comma-p x) 216 | (cons 217 | (let ((expr (sb-int:comma-expr x))) 218 | (case (sb-int:comma-kind x) 219 | (0 (list 'list expr)) 220 | ;;I don't think we want to eval here. 221 | (2 expr) 222 | (1 (error "comma-dot not handled!")))) 223 | acc) 224 | ;; 225 | (cons (list 'list x) acc))) xs :initial-value (list 'list))))) 226 | 227 | (defmacro quasiquote (thing) 228 | (list 'sb-impl::quasiquote thing)) 229 | 230 | (defmacro data-literal (ctor &rest body) 231 | (list 'literal (list 'apply ctor (list* 'sequences::seq->list body)))) 232 | 233 | (defmacro quoted-data-literal (ctor &rest body) 234 | (list 'literal 235 | (list 'apply ctor 236 | (list* 'sequences::seq->list (eval `(quoted-body ,body)))))) 237 | 238 | (defun backquote-charmacro (stream char) 239 | (declare (ignore char)) 240 | (let* ((expr (let ((sb-impl::*backquote-depth* (1+ sb-impl::*backquote-depth*))) 241 | (read stream t nil t))) 242 | (result (list 'quasiquote expr))) 243 | (if (and (sb-impl::comma-p expr) (sb-impl::comma-splicing-p expr)) 244 | ;; use RESULT rather than EXPR in the error so it pprints nicely 245 | (sb-impl::simple-reader-error 246 | stream "~S is not a well-formed backquote expression" result) 247 | (scase (when (listp expr) (common-lisp:first expr)) 248 | (literal expr) 249 | (data-literal expr) 250 | (t result))))) 251 | 252 | ;;Original from Stack Overflow, with some slight modifications. 253 | ;;Have to make this available to the compiler at compile time! 254 | ;;Maybe move this into a clojure-readers.lisp or something. 255 | ;;We need to modify this. It implicity acts like quote for 256 | ;;symbols, since we're using read-delimited-list. 257 | (defun |bracket-reader| (stream char) 258 | "A reader macro that allows us to define persistent vectors 259 | inline, just like Clojure." 260 | (declare (ignore char)) 261 | (if (not (quoting?)) 262 | (apply #'persistent-vector (read-delimited-list #\] stream t)) 263 | (list 'literal (list* 'data-literal 264 | (list 'function 'persistent-vector) 265 | (list (quasify (read-delimited-list #\] stream t))))) 266 | )) 267 | 268 | ;;Original from Stack Overflow, with some slight modifications. 269 | (defun |brace-reader| (stream char) 270 | "A reader macro that allows us to define persistent maps 271 | inline, just like Clojure." 272 | (declare (ignore char)) 273 | (if (not (quoting?)) 274 | (apply #'persistent-map `(,@(read-delimited-list #\} stream t))) 275 | (list 'literal 276 | (list* 'data-literal 277 | (list 'function 'persistent-map) 278 | (list (quasify (read-delimited-list #\} stream t))))) 279 | )) 280 | 281 | (set-macro-character #\{ #'|brace-reader|) 282 | (set-syntax-from-char #\} #\)) 283 | 284 | (push-reader! 'clclojure.pvector:persistent-vector #\[ #\] #'|bracket-reader|)) 285 | 286 | (set-macro-character #\` 'backquote-charmacro nil) 287 | (set-macro-character #\~ 'sb-impl::comma-charmacro nil) 288 | 289 | 290 | 291 | (comment 292 | ;;WIP, moving to more elegant solution from named-readtables.... 293 | ;; (defreadtable clojure:syntax 294 | ;; (:merge :standard) 295 | ;; (:macro-char #\[ #'|bracket-reader| t) 296 | ;; (:case :preserve)) 297 | ) 298 | 299 | 300 | ;;https://gist.github.com/chaitanyagupta/9324402 301 | ;;https://common-lisp.net/project/named-readtables/ 302 | 303 | 304 | 305 | -------------------------------------------------------------------------------- /symbols.lisp: -------------------------------------------------------------------------------- 1 | ;;beginnings of custom symbol tables... 2 | ;;symbols have different behavior in 3 | ;;CL and CLJ. We need to 4 | (defpackage :clclojure.symbols 5 | (:use :common-lisp :clclojure.base) 6 | (:shadowing-import-from :clclojure.base 7 | :deftype :let)) 8 | (in-package :clclojure.symbols) 9 | 10 | (defstruct cljsymbol namespace name) 11 | (defun ->symbol (name &optional namespace) 12 | (make-cljsymbol :namespace namespace :name name)) 13 | 14 | ;;where do symbols live in cljs? 15 | ;;I think there's a local var that defines namespaces and symbols. 16 | ;;In clj jvm, there's a map... 17 | 18 | 19 | 20 | ;;good reference here: 21 | ;;http://blogish.nomistech.com/clojure/clojure-symbols-vs-lisp-symbols/ 22 | 23 | ;;this leads, naturally, to vars as well.. 24 | ;;namespaces are just mappings of symbols to vars. 25 | 26 | -------------------------------------------------------------------------------- /tests/evaltest.lisp: -------------------------------------------------------------------------------- 1 | ;;quick test to see if we get compiler support for our 2 | ;;eval hack... 3 | (ql:quickload :cl-package-locks) 4 | (load "eval.lisp") 5 | 6 | (defstruct blah (x)) 7 | 8 | (defparameter b (make-blah :x 2)) 9 | 10 | (defmethod clclojure.eval:custom-eval 11 | ((obj blah)) 12 | (list :this-is-custom (blah-x obj))) 13 | 14 | (clclojure.eval:enable-custom-eval) 15 | (defparameter custom (eval b)) 16 | ;;(:THIS-IS-CUSTOM 2) 17 | 18 | (clclojure.eval:disable-custom-eval) 19 | (defparameter normal (eval b)) 20 | ;;#S(BLAH :X 2) 21 | 22 | -------------------------------------------------------------------------------- /tests/recurtest.lisp: -------------------------------------------------------------------------------- 1 | (defpackage common-utils.recurtest 2 | (:use :common-lisp :common-utils)) 3 | (in-package :common-utils.recurtest) 4 | 5 | (comment 6 | ;;we can call simmary-tails on all these and get nil, 7 | ;;or some combination of (t, nil), (t, some-list-of illegal callsites) 8 | (defparameter normal-call 9 | `(if (= 2 3) 10 | :equal 11 | (progn (print :otherwise) 12 | :inequal))) 13 | 14 | (defparameter good-tail 15 | '(if (= 2 3) 16 | (recur 2) 17 | (recur 3))) 18 | 19 | (defparameter bad-tail 20 | '(progn 21 | (recur 2) 22 | 3)) 23 | 24 | (defparameter gnarly-bad-tail 25 | '(lambda (x) 26 | (with-recur (acc x) 27 | (let ((blah 5) 28 | (blee 3)) 29 | (if (<= acc blah) 30 | (recur (1+ x)) 31 | (progn (when (< 2 3) 32 | (recur 44)) 33 | 2)))))) 34 | 35 | (defparameter gnarly-good-tail 36 | '(lambda (x) 37 | (with-recur (acc x) 38 | (let ((blah 5) 39 | (blee 3)) 40 | (if (<= acc blah) 41 | (recur (1+ x)) 42 | (progn (when (< 2 3) 43 | (print 44)) 44 | 2)))))) 45 | ) 46 | 47 | 48 | ;(with-recur (x 2 y 3) (+ x y)) 49 | (with-recur (x 0) 50 | (if (< x 10) 51 | (recur (1+ x)) 52 | x)) 53 | 54 | (with-recur (x 0) 55 | (if (> x 9) 56 | x 57 | (recur (1+ x)))) 58 | 59 | (defun good-tail () 60 | (with-recur (x 2) 61 | (if (> x 5) 62 | x 63 | (if (= x 2) 64 | (recur 5) 65 | (recur (1+ x)))))) 66 | 67 | ;;not currently checked! 68 | (defun bad-tail () 69 | (with-recur () 70 | (progn 71 | (recur 2) 72 | 3))) 73 | 74 | (defun gnarly-bad-tail (x) 75 | (with-recur (acc x) 76 | (let ((blah 5) 77 | (blee 3)) 78 | (if (<= acc blah) 79 | (recur (1+ x)) 80 | (progn (when (< 2 3) 81 | (recur 44)) 82 | 2))))) 83 | 84 | (defun gnarly-good-tail (x) 85 | (with-recur (acc x) 86 | (let ((blah 5) 87 | (blee 3)) 88 | (if (<= acc blah) 89 | (recur (1+ acc)) 90 | (progn (when (< 2 3) 91 | (print 44)) 92 | 2))))) 93 | 94 | 95 | ;;base case works.... 96 | (defparameter test-fn2 97 | (named-fn test-fn (x) 98 | (if (< x 2) x 99 | (progn (print `(:calling ,x)) 100 | (test-fn (- x 2)))))) 101 | ;;recur works just fine.... 102 | (defparameter test-fn3 103 | (named-fn test-fn (x) 104 | (if (< x 2) x 105 | (progn (print `(:calling ,x)) 106 | (recur (- x 2)))))) 107 | 108 | 109 | (defparameter nftest (named-fn* test-fn 110 | ((x) (+ x 1)) 111 | ((x y) (+ x y)) 112 | ((&rest xs) (reduce #'+ xs)))) 113 | 114 | 115 | (defparameter nf (named-fn* test-fn 116 | ((coll) (when-let ((x (first coll))) 117 | (progn (pprint x) (recur (rest coll))))) 118 | ((c1 c2) (test-fn c2)))) 119 | -------------------------------------------------------------------------------- /walk.lisp: -------------------------------------------------------------------------------- 1 | ;;a simple code walking package based off clojure.walk, with 2 | ;;severe limitations. 3 | (defpackage :clclojure.walk 4 | (:use :common-lisp :common-utils) 5 | (:export :walk :prewalk :postwalk :prewalk-replace :postwalk-replace) ;:loop :defmacro 6 | ) 7 | (in-package :clclojure.walk) 8 | 9 | ;; "Traverses form, an arbitrary data structure. inner and outer are 10 | ;; functions. Applies inner to each element of form, building up a 11 | ;; data structure of the same type, then applies outer to the result. 12 | ;; Recognizes all Clojure data structures. Consumes seqs as with doall." 13 | 14 | ;; {:added "1.1"} 15 | (defun walk (inner outer form) 16 | (cond ((listp form) 17 | (funcall outer (apply #'list (mapcar (lambda (x) (funcall inner x)) form)))) 18 | (t (funcall outer form)))) 19 | 20 | ;; "Like postwalk, but does pre-order traversal." 21 | ;; {:added "1.1"} 22 | (defun prewalk (f form) 23 | (walk (lambda (x) 24 | (prewalk f x)) #'identity (funcall f form))) 25 | 26 | (defun postwalk (f form) 27 | (walk (lambda (x) 28 | (postwalk f x)) f form)) 29 | 30 | ;; "Recursively transforms form by replacing keys in smap with their 31 | ;; values. Like clojure/replace but works on any data structure. Does 32 | ;; replacement at the root of the tree first." 33 | ;; {:added "1.1"} 34 | (defun prewalk-replace (f form) 35 | (prewalk (lambda (x) (let ((res (funcall f x))) 36 | (if res res x))) form)) 37 | 38 | (defun postwalk-replace (f form) 39 | (postwalk (lambda (x) (let ((res (funcall f x))) 40 | (if res res x))) form)) 41 | 42 | --------------------------------------------------------------------------------