Newer
Older
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
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;
;;; Free Software under MIT-Style license. See file LICENSE. ;;;
;;; ;;;
;;; Copyright (c) 2005-2008 ITA Software, Inc. All rights reserved. ;;;
;;; ;;;
;;; Original author: Scott McKay, Francois-Rene Rideau ;;;
;;; ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Note: these should all be moved to their own library.
#+xcvb (module (:depends-on ("pkgdcl")))
(in-package :quux-time)
;; We used to have a DEFINE-CONSTANT that tried to do the right thing with respect to
;; multiple evaluations of DEFCONSTANT (which always happens when you COMPILE-FILE
;; then LOAD a file where it is used). But there was no way to define DEFINE-CONSTANT
;; such that it would always STYLE-WARN when we're redefining a constant into
;; something different yet remain silent when we run a same form that isn't
;; EQL-constant in a (LOAD ...) right after having (COMPILE-FILE ...)'ed it in the
;; same image. And that's because DEFINE-CONSTANT was fighting the symptom. The real
;; problem is that DEFINE-CONSTANT provided no way to define what it means for a
;; constant to be constant. And so I declared DEFINE-CONSTANT deceased, and we should
;; now use DEFCONSTANT-EQX as taken from SBCL internals, and its variants hereby
;; defined. They have the advantage of being explicit as to what equality predicate
;; is to be preserved by the "constantness" of the constant. Good practice.
;; --fare
;;
;; Use DEFCONSTANT for numbers and keywords (DEFCONSTANT-EQL is semantically the same, but safer).
;; Use DEFCONSTANT-EQUAL for lists and strings.
;; Use DEFCONSTANT-EQUALP for arrays and structures.
;; Use DEFCONSTANT-UNEQUAL for special tags such as '(#:eof).
;;
;; "One man's constant is another man's variable." -- Alan Perlis
;;
(defmacro defconstant-eql (symbol expr &optional doc)
`(defconstant-eqx ,symbol ,expr #'eql ,@(when doc (list doc))))
(defmacro defconstant-equal (symbol expr &optional doc)
`(defconstant-eqx ,symbol ,expr #'equal ,@(when doc (list doc))))
(defmacro defconstant-equalp (symbol expr &optional doc)
`(defconstant-eqx ,symbol ,expr #'equalp ,@(when doc (list doc))))
(defmacro defconstant-unequal (symbol expr &optional doc)
`(defconstant-eqx ,symbol ,expr (constantly t) ,@(when doc (list doc))))
(defmacro defconstant-eqx (symbol expr eqx &optional doc)
`(defconstant ,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)
(cerror "Attempt to change value anyway"
"~@<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")
expr)
((not (funcall eqx (symbol-value symbol) expr))
(bummer "already bound as a different constant value")
expr)
(t
(symbol-value symbol)))))
#+asdf-dependency-grovel
(progn
(asdf-dependency-grovel:define-symbol-alias defconstant-eqx defconstant)
(asdf-dependency-grovel:define-symbol-alias defconstant-eql defconstant)
(asdf-dependency-grovel:define-symbol-alias defconstant-equal defconstant)
(asdf-dependency-grovel:define-symbol-alias defconstant-equalp defconstant)
(asdf-dependency-grovel:define-symbol-alias defconstant-unequal defconstant))
(defmacro defun-inline (name arglist &body body)
`(progn
(declaim (inline ,name))
(defun ,name ,arglist ,@body)))
;;; Faster integer primitives
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant $fixnum-max-bit-index #.(1- (integer-length most-positive-fixnum))
"The maximum amount that a fixnum can be shifted.")
) ;eval-when
(defmacro i+ (&rest fixnums)
"A version of the + function that can only be used on fixnums."
`(the fixnum (+ ,@(loop for n in fixnums collect `(the fixnum ,n)))))
(defmacro i- (number &rest fixnums)
"A version of the - function that can only be used on fixnums."
`(the fixnum (- (the fixnum ,number) ,@(loop for n in fixnums collect `(the fixnum ,n)))))
(defmacro i* (&rest fixnums)
"A version of the * function that can only be used on fixnums."
`(the fixnum (* ,@(loop for n in fixnums collect `(the fixnum ,n)))))
(defmacro i/ (x y)
"A version of the / function that can only be used on fixnums."
`(the fixnum (floor (the fixnum ,x) (the fixnum ,y))))
(defmacro i= (&rest fixnums)
"A version of the = function that can only be used on fixnums."
`(= ,@(loop for n in fixnums collect `(the fixnum ,n))))
(defmacro i/= (&rest fixnums)
"A version of the /= function that can only be used on fixnums."
`(/= ,@(loop for n in fixnums collect `(the fixnum ,n))))
(defmacro i< (&rest fixnums)
"A version of the < function that can only be used on fixnums."
`(< ,@(loop for n in fixnums collect `(the fixnum ,n))))
(defmacro i<= (&rest fixnums)
"A version of the <= function that can only be used on fixnums."
`(<= ,@(loop for n in fixnums collect `(the fixnum ,n))))
(defmacro i> (&rest fixnums)
"A version of the > function that can only be used on fixnums."
`(> ,@(loop for n in fixnums collect `(the fixnum ,n))))
(defmacro i>= (&rest fixnums)
"A version of the >= function that can only be used on fixnums."
`(>= ,@(loop for n in fixnums collect `(the fixnum ,n))))
(defmacro imax (number &rest fixnums)
"A version of the max function that can only be used on fixnums."
`(the fixnum (max (the fixnum ,number) ,@(loop for n in fixnums collect `(the fixnum ,n)))))
(defmacro imin (number &rest fixnums)
"A version of the min function that can only be used on fixnums."
`(the fixnum (min (the fixnum ,number) ,@(loop for n in fixnums collect `(the fixnum ,n)))))
(defmacro imod (x y)
"A version of the mod function that can only be used on fixnums."
`(the fixnum (mod (the fixnum ,x) (the fixnum ,y))))
(defmacro irem (x y)
"A version of the rem function that can only be used on fixnums."
`(the fixnum (rem (the fixnum ,x) (the fixnum ,y))))
(defmacro ifloor (x y)
"A version of the floor function that can only be used on fixnums."
`(the fixnum (floor (the fixnum ,x) (the fixnum ,y))))
(defmacro ifloor+ (x y)
"A version of the floor+ function that can only be used on fixnums."
`(the fixnum (truncate (the fixnum ,x) (the fixnum ,y))))
(defmacro itruncate (x y)
"A version of the truncate function that can only be used on fixnums."
`(the fixnum (truncate (the fixnum ,x) (the fixnum ,y))))
(defmacro iceiling (x y)
"A version of the ceiling function that can only be used on fixnums."
`(the fixnum (ceiling (the fixnum ,x) (the fixnum ,y))))
(defmacro iceiling+ (x y)
"A version of the ceiling+ function that can only be used on fixnums."
`(the fixnum (ceiling (the (integer 0 ,most-positive-fixnum) ,x)
(the (integer 0 ,most-positive-fixnum) ,y))))
(defmacro i1+ (x)
"A version of the 1+ function that can only be used on fixnums."
`(the fixnum (1+ (the fixnum ,x))))
(defmacro i1- (x)
"A version of the 1- function that can only be used on fixnums."
`(the fixnum (1- (the fixnum ,x))))
(defmacro izerop (x)
"A version of the zerop function that can only be used on fixnums."
`(zerop (the fixnum ,x)))
(defmacro iplusp (x)
"A version of the plusp function that can only be used on fixnums."
`(plusp (the fixnum ,x)))
(defmacro iminusp (x)
"A version of the minusp function that can only be used on fixnums."
`(minusp (the fixnum ,x)))
(defmacro iash (value count)
"A version of the ash function that can only be used on fixnums."
`(the fixnum (ash (the fixnum ,value) (the fixnum ,count))))
(defmacro ilogior (&rest fixnums)
"A version of the logior function that can only be used on fixnums."
(if (cdr fixnums)
`(the fixnum (logior (the fixnum ,(car fixnums))
,(if (cddr fixnums)
`(ilogior ,@(cdr fixnums))
`(the fixnum ,(cadr fixnums)))))
`(the fixnum ,(car fixnums))))
(defmacro ilogand (&rest fixnums)
"A version of the logand function that can only be used on fixnums."
(if (cdr fixnums)
`(the fixnum (logand (the fixnum ,(car fixnums))
,(if (cddr fixnums)
`(ilogand ,@(cdr fixnums))
`(the fixnum ,(cadr fixnums)))))
`(the fixnum ,(car fixnums))))
(defmacro ilogxor (&rest fixnums)
"A version of the logxor function that can only be used on fixnums."
(if (cdr fixnums)
`(the fixnum (logxor (the fixnum ,(car fixnums))
,(if (cddr fixnums)
`(ilogxor ,@(cdr fixnums))
`(the fixnum ,(cadr fixnums)))))
`(the fixnum ,(car fixnums))))
(defmacro ilogeqv (&rest fixnums)
"A version of the logeqv function that can only be used on fixnums."
(if (cdr fixnums)
`(the fixnum (logeqv (the fixnum ,(car fixnums))
,(if (cddr fixnums)
`(ilogeqv ,@(cdr fixnums))
`(the fixnum ,(cadr fixnums)))))
`(the fixnum ,(car fixnums))))
(defmacro ilogandc2 (x y)
"A version of the logandc2 function that can only be used on fixnums."
`(the fixnum (logandc2 (the fixnum ,x) (the fixnum ,y))))
(defmacro ilognot (x)
"A version of the lognot function that can only be used on fixnums."
`(the fixnum (lognot (the fixnum ,x))))
(defmacro ilogtest (x y)
"A version of the logtest function that can only be used on fixnums."
`(logtest (the fixnum ,x) (the fixnum ,y)))
(defmacro ilogbitp (index integer)
"A version of the logbitp function that can only be used on fixnums."
`(logbitp (the fixnum ,index) (the fixnum ,integer)))
(defmacro ilogcount (number)
"A version of the logcount function that can only be used on fixnums."
`(the fixnum (logcount (the fixnum ,number))))
(defun-inline ilogbit-set (integer index)
"Given a fixnum and an index, return the fixnum with the index'ed bit set to one."
(ilogior (the fixnum integer) (iash 1 (the (integer 0 #.$fixnum-max-bit-index) index))))
(defun-inline ilogbit-unset (integer index)
"Given a fixnum and an index, return the fixnum with the index'ed bit set to zero."
(ilogandc2 (the fixnum integer) (iash 1 (the (integer 0 #.$fixnum-max-bit-index) index))))
(defun-inline ilogsubsetp (n1 n2)
"Given two fixnums, return true if the bits set in n1 are a subset
of the bits set in n2."
(i= n1 (ilogand n1 n2)))
(defmacro ildb (bytespec value)
"A version of the ldb function that can only be used on fixnums."
`(ldb ,bytespec (the fixnum ,value)))
(defmacro idpb (newvalue bytespec value)
"A version of the dpb function that can only be used on fixnums."
`(dpb (the fixnum ,newvalue) ,bytespec (the fixnum ,value)))
(define-modify-macro iincf (&optional (delta 1)) i+
"Set place to + of place and argument, for fixnums only.")
(define-modify-macro idecf (&optional (delta 1)) i-
"Set place to - of place and argument, for fixnums only.")
(define-modify-macro minf (x &rest xs) min
"Set place to min of place and argument.")
(define-modify-macro maxf (x &rest xs) max
"Set place to max of place and argument.")
(define-modify-macro iminf (x &rest xs) imin
"Set place to min of place and argument, for fixnums only.")
(define-modify-macro imaxf (x &rest xs) imax
"Set place to max of place and argument, for fixnums only.")
(defmacro check-types (&rest clauses)
"Each clause looks like (type form1 form2 ..).
For each clause, assert that all the forms are of that type.
Example: (check-types (integer x y) (string z) ...)."
`(progn
,@(loop :for (type . vars) :in clauses :nconc
(loop :for var :in vars :collect
`(check-type ,var ,type)))))
;;; Bring values a little bit further forward in the language.
;; These are completely compatible with let and let*, and provide
;; for value lists.
(defmacro multiple-value-let (decls &body body)
"MULTIPLE-VALUE-LET ({(Varlist [Multiple-Value]) | (Var [Value]) | Var}*) Declaration* Form*
During evaluation of the Forms, Bind the Vars to the result of evaluating the
Value forms. If a list of variables is given, they are bound to each of the
VALUES returned by the expression, in order. The variables are bound in
parallel after all of the Values are evaluated."
(labels ((m-v-l-helper-1 (vars vals body)
(if (null vars)
body
(m-v-l-helper-1 (rest vars) (rest vals)
(if (listp (first vars))
`((multiple-value-bind ,(first vars) (values ,@(first vals))
,@body))
`((let ((,(first vars) ,(first vals)))
,@body))))))
(m-v-l-helper (decls body vars vals)
(if (null decls)
;; m-v-l-helper-1 returns a body, but we know it's a single multiple-value-bind
;; because we filtered out the null decls in the main body of multiple-value-let
(first (m-v-l-helper-1 vars vals body))
(let ((var-list (car decls))
val-expr
(rest-decls (cdr decls)))
(unless (symbolp var-list)
(assert (= (length var-list) 2) ()
"Bad initialization form: ~S" var-list)
(setq val-expr (cdr var-list)
var-list (car var-list)))
(cond
;; Simple let case
((symbolp var-list)
(let ((renamed-var (gensym (symbol-name var-list))))
`(let ((,renamed-var ,@val-expr))
,(m-v-l-helper rest-decls body (cons var-list vars) (cons renamed-var vals)))))
;; Multiple-value case
((every #'symbolp var-list)
(let ((renamed-vars (map 'list
#'(lambda (s) (gensym (symbol-name s)))
var-list)))
`(multiple-value-bind ,renamed-vars ,@val-expr
,(m-v-l-helper rest-decls body (cons var-list vars) (cons renamed-vars vals)))))
(t (error "badly formed variable list for multiple-value-let")))))))
(cond ((null decls)
;; Get correct declaration context for body
`(let () ,@body))
((and (consp decls) (consp (car decls)) (listp (caar decls)) (null (rest decls)))
;; If there's just a single set of bindings, just make a multiple-value-bind
(destructuring-bind ((var-list val-expr)) decls
`(multiple-value-bind ,var-list ,val-expr ,@body)))
((null (rest decls))
;; If there's just one, and it isn't a multiple-value thing, pass it on to
;; let, it knows what to do.
`(let ,decls ,@body))
(t
(m-v-l-helper decls body nil nil)))))
(defmacro multiple-value-let* ((decl &rest decls) &body body)
"MULTIPLE-VALUE-LET* ({(Varlist [Multiple-Value]) | (Var [Value]) | Var}*) Declaration* Form*
During evaluation of the Forms, Bind the Vars to the result of evaluating the
Value forms. If a list of variables is given, they are bound to each of the
VALUES returned by the expression, in order. The variables are bound in
series, so any declaration may refer to any earlier one."
;; Conceptually you might want to define this in terms
;; of 'multiple-value-let', but this is more efficient
(append (cond
((and (consp decl) (listp (car decl)))
(assert (= (length decl) 2) ()
"Bad initialization form: ~S" decl)
`(multiple-value-bind ,@decl))
(t `(let (,decl))))
(if decls
`((multiple-value-let* ,decls ,@body))
body)))
(defun-inline ascii-digit-p (ch)
"If the character is an ASCII digit, return the value of the digit."
;; Should replace 'digit-char-p' everywhere in QRes to make it work
;; compatibly independently of the CL implementation.
;; return the digit value if it's a digit, to be compatible with digit-char-p (base is always 10)
(let ((d (- (char-code ch) (char-code #\0)))) ;--- assumes ASCII
(if (<= 0 d 9) d nil)))
(defun-inline upper-case-ascii-letter-p (ch)
"Return true if the character is an ASCII uppercase character."
(char<= #\A ch #\Z))
(defun-inline lower-case-ascii-letter-p (ch)
"Return true if the character is an ASCII lowercase character."
(char<= #\a ch #\z)) ;--- assumes ASCII
(defun ascii-letter-p (ch)
"Return true if the character is an ASCII alphabetic character."
;; Should replace 'alpha-char-p' everywhere in QRes to make it work
;; compatibly independently of the CL implementation.
(or (upper-case-ascii-letter-p ch)
(lower-case-ascii-letter-p ch)))
(defmethod ends-with ((string string) (suffix string) &key (end (length string)))
(and (i>= end (length suffix))
(string-equal string suffix :start1 (i- end (length suffix)) :end1 end)
suffix))
(defmethod ends-with ((string string) (suffix character) &key (end (length string)))
(and (>= (length string) end 1)
(char-equal (char string (1- end)) suffix)
(string suffix)))
(defmethod ends-with ((string string) (suffixes list) &key (end (length string)))
(loop for suffix in suffixes
as result = (ends-with string suffix :end end)
when result
return result))
;; Creates gensyms for use in a macro expansion.
;;--- This is a less brittle version of the CLiki 'with-unique-names' proposal
(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro with-gensyms ((&rest bindings) &body body)
"BINDINGS is a list of clauses. The canonical clause looks like
(VARIABLE PREFIX) where VARIABLE is a Lisp variable, and PREFIX
is a string (or anything acceptable to the STRING) function.
Each VARIABLE is bound to a gensym, made with the PREFIX, and
the body is run inside those bindings. A clause of the form
(VARIABLE) or VARIABLE is treated as (VARIABLE VARIABLE).
This is available at compile-time, so macro bodies can use it."
`(let ,(mapcar #'(lambda (binding)
(multiple-value-bind (var prefix)
(if (consp binding)
(values (first binding) (or (second binding) (first binding)))
(values binding binding))
`(,var (gensym ,(string prefix)))))
bindings)
,@body))
) ;eval-when
;; Allows and ignores trailing whitespace (for database values, etc)
;; Keys are as for 'parse-integer' (start, end, radix -- but not junk-allowed)
(defun string-to-integer (object &rest keys)
(declare (dynamic-extent keys))
(etypecase object
(integer object)
(string
(flet ((parse-it (string)
(apply #'parse-integer string :junk-allowed t keys)))
(declare (dynamic-extent #'parse-it))
(apply #'parse-right-trimming-whitespace #'parse-it 'integer object keys)))))
(defun parse-right-trimming-whitespace (parser type string
&rest keys &key end &allow-other-keys)
(declare (ignore keys))
(multiple-value-bind (value index)
(funcall parser string)
(if (and (typep value type)
(let ((end (or end (length string))))
(or (i= index end)
(loop for i fixnum from index below end
as char = (char string i)
always (or (eql char #\space)
(eql char #\tab)
(eql char #\linefeed)
(eql char #\return))))))
value)))
;;; Fast, cons-free fixnum output
(defvar *unpadded-integer-strings*
(let ((vector (make-array 10000)))
(loop for i fixnum from 0 below 10000
do (setf (svref vector i) (format nil "~D" i)))
vector)
"A 1000-element vector of the printed representation of each integer
without any padding.")
(defvar *zero-padded-integer-strings-2*
(apply #'vector (loop for i fixnum from 0 below 100
collecting (format nil "~2,'0D" i)))
"A 100-element vector of the printed representation of each integer
zero-padded to two characters.")
(defvar *zero-padded-integer-strings-4*
(let ((vector (make-array 10000)))
(loop for i fixnum from 0 below 10000
do (setf (svref vector i) (format nil "~4,'0D" i)))
vector)
"A 10000-element vector of the printed representation of each integer
zero-padded to two characters.")
(defun write-integer (integer stream &key width (padding #\space))
"Write the integer to the stream. If it's a fixnum and width
is provided, pad it to that width with the padding character."
(if (typep integer 'fixnum)
(if width
(write-padded-fixnum integer stream width padding)
(or (write-unpadded-fixnum integer stream)
(write integer :stream stream)))
(write integer :stream stream)))
(defun write-unpadded-fixnum (fixnum stream)
"Write the fixnum to the stream. This is more efficient
than using the regular Lisp printer."
(let ((n-written 0))
(when (i< fixnum 0)
(when (i= fixnum most-negative-fixnum)
(let ((s #.(format nil "~D" most-negative-fixnum)))
(write-string s stream)
(return-from write-unpadded-fixnum (length s))))
(write-char #\- stream)
(iincf n-written)
(setf fixnum (i- fixnum)))
(cond ((i< fixnum 10000)
(let ((s (svref *unpadded-integer-strings* fixnum)))
(write-string s stream)
(iincf n-written (length s))))
((i< fixnum 100000000)
(let ((s (svref *unpadded-integer-strings* (ifloor fixnum 10000))))
(write-string s stream) (iincf n-written (length s)))
(let ((s (svref *zero-padded-integer-strings-4* (imod fixnum 10000))))
(write-string s stream) (iincf n-written (length s))))
#.(if (typep 100000000000 'fixnum)
;; Only for 64-bit lisps
'((i< fixnum 100000000000)
(let ((s (svref *unpadded-integer-strings* (ifloor fixnum 100000000))))
(write-string s stream) (iincf n-written (length s)))
(let ((s (svref *zero-padded-integer-strings-4* (imod (ifloor fixnum 10000) 10000))))
(write-string s stream) (iincf n-written (length s)))
(let ((s (svref *zero-padded-integer-strings-4* (imod fixnum 10000))))
(write-string s stream) (iincf n-written (length s))))
'(nil nil))
;; Give up if it's this big ...
(t
(return-from write-unpadded-fixnum nil)))
n-written))
(defun write-padded-fixnum (fixnum stream width pad-char)
"Write the fixnum to the stream, with the given width and padding."
(cond ((or (null width) (i< width 0))
(return-from write-padded-fixnum (write-unpadded-fixnum fixnum stream)))
((i= width 0) 0)
((i< fixnum 0)
(write-padded-fixnum-internal fixnum (i- fixnum) width stream pad-char))
((i= fixnum 0)
(dotimes (i (i1- width))
(write-char pad-char stream))
(write-char #\0 stream)
(imax width 1))
((and (i= width 2) (eql pad-char #\0))
(write-string (svref *zero-padded-integer-strings-2*
(if (i< fixnum 100) fixnum (imod fixnum 100)))
stream)
2)
((and (i= width 4) (eql pad-char #\0))
(write-string (svref *zero-padded-integer-strings-4*
(if (i< fixnum 10000) fixnum (imod fixnum 10000)))
stream)
4)
(t
(write-padded-fixnum-internal fixnum fixnum width stream pad-char))))
(defun write-padded-fixnum-internal (fixnum absolute-value width stream pad-char)
(cond ((i= width 0) 0)
((i> absolute-value 0)
(let ((n (write-padded-fixnum-internal fixnum (floor absolute-value 10)
(1- width) stream pad-char)))
(write-char (code-char (i+ (char-code #\0) (mod absolute-value 10))) stream)
(i1+ n)))
(t
(dotimes (i (i1- width))
(write-char pad-char stream))
(write-char (if (i< fixnum 0) #\- pad-char) stream)
(imax width 1))))
(defun pad-string-to-width (str width pad-char)
"Pad the string on the left until it is as long as width.
If it is already longer than that, signal an exception."
(cond
((i> (length str) width) (error "Longer than limit already"))
((i= (length str) width) str)
(t
;; apparently strings are immutable, so I couldn't do anything fancy with setf (aref
(with-output-to-string (stream)
(loop repeat (i- width (length str)) doing
(write-char pad-char stream))
(write-string str stream)))))
(defun write-integer-to-string (integer &key width (padding #\space))
"Convenience function for int to string conversion.
Is actually a lot cheaper than prin1-to-string (1/3 the time and consing)"
(with-output-to-string (stream)
(write-integer integer stream :width width :padding padding)))
(defun integer-number-of-digits (i)
"Return the number of digits in the printed representation
of I, which must be a non-negative integer."
(cond ((< i 10) 1)
((< i 100) 2)
((< i 1000) 3)
((< i 10000) 4)
(t
(do ((j i (floor j 10))
(x 0 (1+ x)))
((< j 10000)
(+ x 4))))))