[403bac]: src / code / primordial-extensions.lisp Maximize Restore History

Download this file

primordial-extensions.lisp    329 lines (308 with data), 13.5 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 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
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
;;;; various user-level definitions which need to be done particularly
;;;; early
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!IMPL")
;;;; target constants which need to appear as early as possible
;;; an internal tag for marking empty slots, which needs to be defined
;;; as early as possible because it appears in macroexpansions for
;;; iteration over hash tables
;;;
;;; CMU CL 18b used :EMPTY for this purpose, which was somewhat nasty
;;; since it's easily accessible to the user, so that e.g.
;;; (DEFVAR *HT* (MAKE-HASH-TABLE))
;;; (SETF (GETHASH :EMPTY *HT*) :EMPTY)
;;; (MAPHASH (LAMBDA (K V) (FORMAT T "~&~S ~S~%" K V)))
;;; gives no output -- oops!
;;;
;;; FIXME: It'd probably be good to use the unbound marker for this.
;;; However, there might be some gotchas involving assumptions by
;;; e.g. AREF that they're not going to return the unbound marker,
;;; and there's also the noted-below problem that the C-level code
;;; contains implicit assumptions about this marker.
;;;
;;; KLUDGE: Note that as of version 0.pre7 there's a dependence in the
;;; gencgc.c code on this value being a symbol. (This is only one of
;;; several nasty dependencies between that code and this, alas.)
;;; -- WHN 2001-08-17
(eval-when (:compile-toplevel :load-toplevel :execute)
(def!constant +empty-ht-slot+ '%empty-ht-slot%))
;;; We shouldn't need this mess now that EVAL-WHEN works.
;;; KLUDGE: Using a private symbol still leaves us vulnerable to users
;;; getting nonconforming behavior by messing around with
;;; DO-ALL-SYMBOLS. That seems like a fairly obscure problem, so for
;;; now we just don't worry about it. If for some reason it becomes
;;; worrisome and the magic value needs replacement:
;;; * The replacement value needs to be LOADable with EQL preserved,
;;; so that the macroexpansion for WITH-HASH-TABLE-ITERATOR will
;;; work when compiled into a file and loaded back into SBCL.
;;; (Thus, just uninterning %EMPTY-HT-SLOT% doesn't work.)
;;; * The replacement value needs to be acceptable to the
;;; low-level gencgc.lisp hash table scavenging code.
;;; * The change will break binary compatibility, since comparisons
;;; against the value used at the time of compilation are wired
;;; into FASL files.
;;; -- WHN 20000622
;;;; DO-related stuff which needs to be visible on the cross-compilation host
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun frob-do-body (varlist endlist decls-and-code bind step name block)
(let* ((r-inits nil) ; accumulator for reversed list
(r-steps nil) ; accumulator for reversed list
(label-1 (gensym))
(label-2 (gensym)))
;; Check for illegal old-style DO.
(when (or (not (listp varlist)) (atom endlist))
(error "ill-formed ~S -- possibly illegal old style DO?" name))
;; Parse VARLIST to get R-INITS and R-STEPS.
(dolist (v varlist)
(flet (;; (We avoid using CL:PUSH here so that CL:PUSH can be
;; defined in terms of CL:SETF, and CL:SETF can be
;; defined in terms of CL:DO, and CL:DO can be defined
;; in terms of the current function.)
(push-on-r-inits (x)
(setq r-inits (cons x r-inits)))
;; common error-handling
(illegal-varlist ()
(error "~S is an illegal form for a ~S varlist." v name)))
(cond ((symbolp v) (push-on-r-inits v))
((listp v)
(unless (symbolp (first v))
(error "~S step variable is not a symbol: ~S"
name
(first v)))
(let ((lv (length v)))
;; (We avoid using CL:CASE here so that CL:CASE can
;; be defined in terms of CL:SETF, and CL:SETF can
;; be defined in terms of CL:DO, and CL:DO can be
;; defined in terms of the current function.)
(cond ((= lv 1)
(push-on-r-inits (first v)))
((= lv 2)
(push-on-r-inits v))
((= lv 3)
(push-on-r-inits (list (first v) (second v)))
(setq r-steps (list* (third v) (first v) r-steps)))
(t (illegal-varlist)))))
(t (illegal-varlist)))))
;; Construct the new form.
(multiple-value-bind (code decls) (parse-body decls-and-code nil)
`(block ,block
(,bind ,(nreverse r-inits)
,@decls
(tagbody
(go ,label-2)
,label-1
,@code
(,step ,@(nreverse r-steps))
,label-2
(unless ,(first endlist) (go ,label-1))
(return-from ,block (progn ,@(rest endlist))))))))))
;;; This is like DO, except it has no implicit NIL block. Each VAR is
;;; initialized in parallel to the value of the specified INIT form.
;;; On subsequent iterations, the VARS are assigned the value of the
;;; STEP form (if any) in parallel. The TEST is evaluated before each
;;; evaluation of the body FORMS. When the TEST is true, the
;;; EXIT-FORMS are evaluated as a PROGN, with the result being the
;;; value of the DO.
(defmacro do-anonymous (varlist endlist &rest body)
(frob-do-body varlist endlist body 'let 'psetq 'do-anonymous (gensym)))
;;;; GENSYM tricks
;;; Automate an idiom often found in macros:
;;; (LET ((FOO (GENSYM "FOO"))
;;; (MAX-INDEX (GENSYM "MAX-INDEX-")))
;;; ...)
;;;
;;; "Good notation eliminates thought." -- Eric Siggia
;;;
;;; Incidentally, this is essentially the same operator which
;;; _On Lisp_ calls WITH-GENSYMS.
(defmacro with-unique-names (symbols &body body)
`(let ,(mapcar (lambda (symbol)
(let* ((symbol-name (symbol-name symbol))
(stem (if (every #'alpha-char-p symbol-name)
symbol-name
(concatenate 'string symbol-name "-"))))
`(,symbol (gensym ,stem))))
symbols)
,@body))
;;; Return a list of N gensyms. (This is a common suboperation in
;;; macros and other code-manipulating code.)
(declaim (ftype (function (index) list) make-gensym-list))
(defun make-gensym-list (n)
(loop repeat n collect (gensym)))
;;;; miscellany
;;; Lots of code wants to get to the KEYWORD package or the
;;; COMMON-LISP package without a lot of fuss, so we cache them in
;;; variables. TO DO: How much does this actually buy us? It sounds
;;; sensible, but I don't know for sure that it saves space or time..
;;; -- WHN 19990521
;;;
;;; (The initialization forms here only matter on the cross-compilation
;;; host; In the target SBCL, these variables are set in cold init.)
(declaim (type package *cl-package* *keyword-package*))
(defvar *cl-package* (find-package "COMMON-LISP"))
(defvar *keyword-package* (find-package "KEYWORD"))
;;; Concatenate together the names of some strings and symbols,
;;; producing a symbol in the current package.
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun symbolicate (&rest things)
(let ((name (case (length things)
;; why isn't this just the value in the T branch?
;; Well, this is called early in cold-init, before
;; the type system is set up; however, now that we
;; check for bad lengths, the type system is needed
;; for calls to CONCATENATE. So we need to make sure
;; that the calls are transformed away:
(1 (concatenate 'string
(the simple-base-string (string (car things)))))
(2 (concatenate 'string
(the simple-base-string (string (car things)))
(the simple-base-string (string (cadr things)))))
(3 (concatenate 'string
(the simple-base-string (string (car things)))
(the simple-base-string (string (cadr things)))
(the simple-base-string (string (caddr things)))))
(t (apply #'concatenate 'string (mapcar #'string things))))))
(values (intern name)))))
;;; like SYMBOLICATE, but producing keywords
(defun keywordicate (&rest things)
(let ((*package* *keyword-package*))
(apply #'symbolicate things)))
;;; Access *PACKAGE* in a way which lets us recover when someone has
;;; done something silly like (SETF *PACKAGE* :CL-USER). (Such an
;;; assignment is undefined behavior, so it's sort of reasonable for
;;; it to cause the system to go totally insane afterwards, but it's a
;;; fairly easy mistake to make, so let's try to recover gracefully
;;; instead.)
(defun sane-package ()
(let ((maybe-package *package*))
(cond ((and (packagep maybe-package)
;; For good measure, we also catch the problem of
;; *PACKAGE* being bound to a deleted package.
;; Technically, this is not undefined behavior in itself,
;; but it will immediately lead to undefined to behavior,
;; since almost any operation on a deleted package is
;; undefined.
(package-name maybe-package))
maybe-package)
(t
;; We're in the undefined behavior zone. First, munge the
;; system back into a defined state.
(let ((really-package (find-package :cl-user)))
(setf *package* really-package)
;; Then complain.
(error 'simple-type-error
:datum maybe-package
:expected-type '(and package (satisfies package-name))
:format-control
"~@<~S can't be a ~A: ~2I~_~S has been reset to ~S.~:>"
:format-arguments (list '*package*
(if (packagep maybe-package)
"deleted package"
(type-of maybe-package))
'*package* really-package)))))))
;;; Access *DEFAULT-PATHNAME-DEFAULTS*, issuing a warning if its value
;;; is silly. (Unlike the vaguely-analogous SANE-PACKAGE, we don't
;;; actually need to reset the variable when it's silly, since even
;;; crazy values of *DEFAULT-PATHNAME-DEFAULTS* don't leave the system
;;; in a state where it's hard to recover interactively.)
(defun sane-default-pathname-defaults ()
(let* ((dfd *default-pathname-defaults*)
(dfd-dir (pathname-directory dfd)))
;; It's generally not good to use a relative pathname for
;; *DEFAULT-PATHNAME-DEFAULTS*, since relative pathnames
;; are defined by merging into a default pathname (which is,
;; by default, *DEFAULT-PATHNAME-DEFAULTS*).
(when (and (consp dfd-dir)
(eql (first dfd-dir) :relative))
(warn
"~@<~S is a relative pathname. (But we'll try using it anyway.)~@:>"
'*default-pathname-defaults*))
dfd))
;;; Give names to elements of a numeric sequence.
(defmacro defenum ((&key (prefix "") (suffix "") (start 0) (step 1))
&rest identifiers)
(let ((results nil)
(index 0)
(start (eval start))
(step (eval step)))
(dolist (id identifiers)
(when id
(multiple-value-bind (root docs)
(if (consp id)
(values (car id) (cdr id))
(values id nil))
(push `(def!constant ,(symbolicate prefix root suffix)
,(+ start (* step index))
,@docs)
results)))
(incf index))
`(progn
,@(nreverse results))))
;;; generalization of DEFCONSTANT to values which are the same not
;;; under EQL but under e.g. EQUAL or EQUALP
;;;
;;; DEFCONSTANT-EQX is to be used instead of DEFCONSTANT for values
;;; which are appropriately compared using the function given by the
;;; EQX argument instead of EQL.
;;;
;;; Note: Be careful when using this macro, since it's easy to
;;; unintentionally pessimize your code. A good time to use this macro
;;; is when the values defined will be fed into optimization
;;; transforms and never actually appear in the generated code; this
;;; is especially common when defining BYTE expressions. Unintentional
;;; pessimization can result when the values defined by this macro are
;;; actually used in generated code: because of the way that the
;;; dump/load system works, you'll typically get one copy of consed
;;; structure for each object file which contains code referring to
;;; the value, plus perhaps one more copy bound to the SYMBOL-VALUE of
;;; the constant. If you don't want that to happen, you should
;;; probably use DEFPARAMETER instead; or if you truly desperately
;;; need to avoid runtime indirection through a symbol, you might be
;;; able to do something with LOAD-TIME-VALUE or MAKE-LOAD-FORM.
(defmacro defconstant-eqx (symbol expr eqx &optional doc)
`(def!constant ,symbol
(%defconstant-eqx-value ',symbol ,expr ,eqx)
,@(when doc (list doc))))
(defun %defconstant-eqx-value (symbol expr eqx)
(declare (type function eqx))
(flet ((bummer (explanation)
(error "~@<bad DEFCONSTANT-EQX ~S ~2I~_~S: ~2I~_~A ~S~:>"
symbol
expr
explanation
(symbol-value symbol))))
(cond ((not (boundp symbol))
expr)
((not (constantp symbol))
(bummer "already bound as a non-constant"))
((not (funcall eqx (symbol-value symbol) expr))
(bummer "already bound as a different constant value"))
(t
(symbol-value symbol)))))
;;; a helper function for various macros which expect clauses of a
;;; given length, etc.
;;;
;;; Return true if X is a proper list whose length is between MIN and
;;; MAX (inclusive).
(defun proper-list-of-length-p (x min &optional (max min))
;; FIXME: This implementation will hang on circular list
;; structure. Since this is an error-checking utility, i.e. its
;; job is to deal with screwed-up input, it'd be good style to fix
;; it so that it can deal with circular list structure.
(cond ((minusp max) nil)
((null x) (zerop min))
((consp x)
(and (plusp max)
(proper-list-of-length-p (cdr x)
(if (plusp (1- min))
(1- min)
0)
(1- max))))
(t nil)))