- 01
- 02
- 03
- 04
- 05
- 06
- 07
- 08
- 09
- 10
- 11
- 12
- 13
- 14
- 15
- 16
- 17
- 18
- 19
- 20
- 21
- 22
- 23
- 24
- 25
- 26
- 27
- 28
- 29
- 30
- 31
- 32
- 33
- 34
- 35
- 36
- 37
- 38
- 39
- 40
- 41
- 42
- 43
- 44
- 45
- 46
- 47
- 48
- 49
- 50
- 51
- 52
- 53
- 54
- 55
- 56
- 57
- 58
- 59
- 60
- 61
- 62
- 63
- 64
- 65
- 66
- 67
- 68
- 69
- 70
- 71
- 72
- 73
- 74
- 75
- 76
- 77
- 78
- 79
- 80
- 81
- 82
- 83
- 84
- 85
- 86
- 87
- 88
- 89
- 90
- 91
- 92
- 93
- 94
- 95
- 96
- 97
- 98
- 99
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;; Copyright (C) 2011, Dmitry Ignatiev <[email protected]>
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE
(in-package #:neural-flow)
;; Stolen from `trivial-garbage'
#+openmcl
(defvar *weak-pointers* (cl:make-hash-table :test 'eq :weak :value))
#+(or allegro openmcl lispworks)
(defstruct (weak-pointer (:constructor %make-weak-pointer))
#-openmcl pointer)
(declaim (inline make-weak-pointer))
(defun make-weak-pointer (object)
#+sbcl (sb-ext:make-weak-pointer object)
#+(or cmu scl) (ext:make-weak-pointer object)
#+clisp (ext:make-weak-pointer object)
#+ecl (ext:make-weak-pointer object)
#+allegro
(let ((wv (excl:weak-vector 1)))
(setf (svref wv 0) object)
(%make-weak-pointer :pointer wv))
#+openmcl
(let ((wp (%make-weak-pointer)))
(setf (gethash wp *weak-pointers*) object)
wp)
#+corman (ccl:make-weak-pointer object)
#+lispworks
(let ((array (make-array 1)))
(hcl:set-array-weak array t)
(setf (svref array 0) object)
(%make-weak-pointer :pointer array)))
(declaim (inline weak-pointer-value))
(defun weak-pointer-value (weak-pointer)
"If WEAK-POINTER is valid, returns its value. Otherwise, returns NIL."
#+sbcl (values (sb-ext:weak-pointer-value weak-pointer))
#+(or cmu scl) (values (ext:weak-pointer-value weak-pointer))
#+clisp (values (ext:weak-pointer-value weak-pointer))
#+ecl (values (ext:weak-pointer-value weak-pointer))
#+allegro (svref (weak-pointer-pointer weak-pointer) 0)
#+openmcl (values (gethash weak-pointer *weak-pointers*))
#+corman (ccl:weak-pointer-obj weak-pointer)
#+lispworks (svref (weak-pointer-pointer weak-pointer) 0))
;;Red-black tree
(declaim (inline %node %nleft %nright %nparent %nred %ndata %ncode
(setf %nleft) (setf %nright) (setf %nparent)
(setf %nred) (setf %ndata) (setf %ncode)))
(defstruct (%node (:constructor %node (data code parent red))
(:conc-name %n))
(left nil :type (or null %node))
(right nil :type (or null %node))
(parent nil :type (or null %node))
(red nil)
data
(code 0 :type (integer 0 #.most-positive-fixnum)))
(declaim (inline %tree %tree-root (setf %tree-root)))
(defstruct (%tree (:constructor %tree ())
(:copier %copy-tree))
(root nil :type (or null %node)))
(declaim (inline rotate-left))
(defun %rotate-left (tree node)
(declare (type %tree tree) (type %node node)
(optimize (speed 3) (safety 0)))
(let ((right (%nright node)))
(when (setf (%nright node) (%nleft right))
(setf (%nparent (%nleft right)) node))
(if (setf (%nparent right) (%nparent node))
(if (eq node (%nleft (%nparent node)))
(setf (%nleft (%nparent node)) right)
(setf (%nright (%nparent node)) right))
(setf (%tree-root tree) right))
Follow us!