1.0.11.34: better SUBSEQ on lists
[sbcl.git] / src / code / late-extensions.lisp
1 ;;;; various extensions (including SB-INT "internal extensions")
2 ;;;; available both in the cross-compilation host Lisp and in the
3 ;;;; target SBCL, but which can't be defined on the target until until
4 ;;;; some significant amount of machinery (e.g. error-handling) is
5 ;;;; defined
6
7 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; more information.
9 ;;;;
10 ;;;; This software is derived from the CMU CL system, which was
11 ;;;; written at Carnegie Mellon University and released into the
12 ;;;; public domain. The software is in the public domain and is
13 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
14 ;;;; files for more information.
15
16 (in-package "SB!IMPL")
17
18 ;;; Is X a list for which LENGTH is meaningful, i.e. a list which is
19 ;;; not improper and which is not circular?
20 (defun list-with-length-p (x)
21   (values (ignore-errors (list-length x))))
22
23 ;;; not used in 0.7.8, but possibly useful for defensive programming
24 ;;; in e.g. (COERCE ... 'VECTOR)
25 ;;;(defun list-length-or-die (x)
26 ;;;  (or (list-length x)
27 ;;;      ;; not clear how to do this best:
28 ;;;      ;;   * Should this be a TYPE-ERROR? Colloquially that'd make
29 ;;;      ;;     lots of sense, but since I'm not sure how to express
30 ;;;      ;;     "noncircular list" as a Lisp type expression, coding
31 ;;;      ;;     it seems awkward.
32 ;;;      ;;   * Should the ERROR object include the offending value?
33 ;;;      ;;     Ordinarily that's helpful, but if the user doesn't have
34 ;;;      ;;     his printer set up to deal with cyclicity, we might not
35 ;;;      ;;     be doing him a favor by printing the object here.
36 ;;;      ;; -- WHN 2002-10-19
37 ;;;      (error "can't calculate length of cyclic list")))
38
39 ;;; This is used in constructing arg lists for debugger printing,
40 ;;; and when needing to print unbound slots in PCL.
41 (defstruct (unprintable-object
42             (:constructor make-unprintable-object (string))
43             (:print-object (lambda (x s)
44                              (print-unreadable-object (x s)
45                                (write-string (unprintable-object-string x) s))))
46             (:copier nil))
47   string)
48
49 ;;; Used internally, but it would be nice to provide something
50 ;;; like this for users as well.
51
52 #!+sb-thread
53 (defmacro define-structure-slot-addressor (name &key structure slot)
54   (let* ((dd (find-defstruct-description structure t))
55          (slotd (when dd (find slot (dd-slots dd) :key #'dsd-name)))
56          (index (when slotd (dsd-index slotd))))
57     (unless index
58       (error "Slot ~S not found in ~S." slot structure))
59     `(progn
60        (declaim (inline ,name))
61        (defun ,name (instance)
62          (declare (type ,structure instance) (optimize speed))
63          (sb!ext:truly-the
64           sb!vm:word
65           (+ (sb!kernel:get-lisp-obj-address instance)
66              (- (* ,(+ sb!vm:instance-slots-offset index) sb!vm:n-word-bytes)
67                 sb!vm:instance-pointer-lowtag)))))))
68
69 (defmacro compare-and-swap (place old new)
70   "Atomically stores NEW in PLACE if OLD matches the current value of PLACE.
71 Two values are considered to match if they are EQ. Returns the previous value
72 of PLACE: if the returned value if EQ to OLD, the swap was carried out.
73
74 PLACE must be an accessor form whose CAR is one of the following:
75
76  CAR, CDR, FIRST, REST, SYMBOL-PLIST, SYMBOL-VALUE, SVREF
77
78 or the name of a DEFSTRUCT created accessor for a slot whose declared type is
79 either FIXNUM or T. Results are unspecified if the slot has a declared type
80 other then FIXNUM or T.
81
82 EXPERIMENTAL: Interface subject to change."
83   (flet ((invalid-place ()
84            (error "Invalid first argument to COMPARE-AND-SWAP: ~S" place)))
85     (unless (consp place)
86       (invalid-place))
87   ;; FIXME: Not the nicest way to do this...
88   (destructuring-bind (op &rest args) place
89     (case op
90       ((car first)
91        `(%compare-and-swap-car (the cons ,@args) ,old ,new))
92       ((cdr rest)
93        `(%compare-and-swap-cdr (the cons ,@args) ,old ,new))
94       (symbol-plist
95        `(%compare-and-swap-symbol-plist (the symbol ,@args) ,old ,new))
96       (symbol-value
97        `(%compare-and-swap-symbol-value (the symbol ,@args) ,old ,new))
98       (svref
99        (let ((vector (car args))
100              (index (cadr args)))
101          (unless (and vector index (not (cddr args)))
102            (invalid-place))
103          (with-unique-names (v)
104            `(let ((,v ,vector))
105               (declare (simple-vector ,v))
106               (%compare-and-swap-svref ,v (%check-bound ,v (length ,v) ,index) ,old ,new)))))
107       (t
108        (let ((dd (info :function :structure-accessor op)))
109          (if dd
110              (let* ((structure (dd-name dd))
111                     (slotd (find op (dd-slots dd) :key #'dsd-accessor-name))
112                     (index (dsd-index slotd))
113                     (type (dsd-type slotd)))
114                (unless (eq t (dsd-raw-type slotd))
115                  (error "Cannot use COMPARE-AND-SWAP with structure accessor for a typed slot: ~S"
116                         place))
117                (when (dsd-read-only slotd)
118                  (error "Cannot use COMPARE-AND-SWAP with structure accessor for a read-only slot: ~S"
119                         place))
120                `(truly-the (values ,type &optional)
121                            (%compare-and-swap-instance-ref (the ,structure ,@args)
122                                                            ,index
123                                                            (the ,type ,old) (the ,type ,new))))
124              (error "Invalid first argument to COMPARE-AND-SWAP: ~S" place))))))))
125
126 (macrolet ((def (name lambda-list ref &optional set)
127              `(defun ,name (,@lambda-list old new)
128                 #!+compare-and-swap-vops
129                 (,name ,@lambda-list old new)
130                 #!-compare-and-swap-vops
131                 (let ((current (,ref ,@lambda-list)))
132                   (when (eq current old)
133                     ,(if set
134                          `(,set ,@lambda-list new)
135                          `(setf (,ref ,@lambda-list) new)))
136                   current))))
137   (def %compare-and-swap-car (cons) car)
138   (def %compare-and-swap-cdr (cons) cdr)
139   (def %compare-and-swap-instance-ref (instance index) %instance-ref %instance-set)
140   (def %compare-and-swap-symbol-plist (symbol) symbol-plist)
141   (def %compare-and-swap-symbol-value (symbol) symbol-value)
142   (def %compare-and-swap-svref (vector index) svref))