Coverage report: /home/ellis/comp/core/std/list.lisp

KindCoveredAll%
expression51828 6.2
branch7156 4.5
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; std/list.lisp --- List utils
2
 
3
 ;;; Code:
4
 (in-package :std/list)
5
 
6
 (defun ensure-car (thing)
7
   "If THING is a CONS, its CAR is returned. Otherwise THING is returned."
8
   (if (consp thing)
9
       (car thing)
10
       thing))
11
 
12
 (defun ensure-cons (cons)
13
   "If CONS is a cons, it is returned. Otherwise returns a fresh cons with CONS
14
   in the car, and NIL in the cdr."
15
   (if (consp cons)
16
       cons
17
       (cons cons nil)))
18
 
19
 (define-modify-macro appendf (&rest lists) append
20
   "Modify-macro for APPEND. Appends LISTS to the place designated by the first
21
 argument.")
22
 
23
 (define-modify-macro nconcf (&rest lists) nconc
24
   "Modify-macro for NCONC. Concatenates LISTS to place designated by the first
25
 argument.")
26
 
27
 (define-modify-macro unionf (list &rest args) union
28
   "Modify-macro for UNION. Saves the union of LIST and the contents of the
29
 place designated by the first argument to the designated place.")
30
 
31
 (define-modify-macro nunionf (list &rest args) nunion
32
   "Modify-macro for NUNION. Saves the union of LIST and the contents of the
33
 place designated by the first argument to the designated place. May modify
34
 either argument.")
35
 
36
 (define-modify-macro reversef () reverse
37
   "Modify-macro for REVERSE. Copies and reverses the list stored in the given
38
 place and saves back the result into the place.")
39
 
40
 (define-modify-macro nreversef () nreverse
41
   "Modify-macro for NREVERSE. Reverses the list stored in the given place by
42
 destructively modifying it and saves back the result into the place.")
43
 
44
 (declaim (inline remove/swapped-arguments))
45
 (defun remove/swapped-arguments (sequence item &rest keyword-arguments)
46
   (apply #'remove item sequence keyword-arguments))
47
 
48
 (define-modify-macro removef (item &rest keyword-arguments)
49
   remove/swapped-arguments
50
   "Modify-macro for REMOVE. Sets place designated by the first argument to
51
 the result of calling REMOVE with ITEM, place, and the KEYWORD-ARGUMENTS.")
52
 
53
 (declaim (inline delete/swapped-arguments))
54
 (defun delete/swapped-arguments (sequence item &rest keyword-arguments)
55
   (apply #'delete item sequence keyword-arguments))
56
 
57
 (define-modify-macro deletef (item &rest keyword-arguments)
58
   delete/swapped-arguments
59
   "Modify-macro for DELETE. Sets place designated by the first argument to
60
 the result of calling DELETE with ITEM, place, and the KEYWORD-ARGUMENTS.")
61
 
62
 (defun let-binding-transform (bs)
63
   (if bs
64
       (cons
65
        (cond ((symbolp (car bs))
66
               (list (car bs)))
67
              ((consp (car bs))
68
               (car bs))
69
              (t
70
               (error "Bad let bindings")))
71
        (let-binding-transform (cdr bs)))))
72
 
73
 (defun circular-list (&rest elements)
74
   "Creates a circular list of ELEMENTS."
75
   (let ((cycle (copy-list elements)))
76
     (nconc cycle cycle)))
77
 
78
 (defun circular-list-p (object)
79
   "Returns true if OBJECT is a circular list, NIL otherwise."
80
   (and (listp object)
81
        (do ((fast object (cddr fast))
82
             (slow (cons (car object) (cdr object)) (cdr slow)))
83
            (nil)
84
          (unless (and (consp fast) (listp (cdr fast)))
85
            (return nil))
86
          (when (eq fast slow)
87
            (return t)))))
88
 
89
 (defun circular-tree-p (object)
90
   "Returns true if OBJECT is a circular tree, NIL otherwise."
91
   (labels ((circularp (object seen)
92
              (and (consp object)
93
                   (do ((fast (cons (car object) (cdr object)) (cddr fast))
94
                        (slow object (cdr slow)))
95
                       (nil)
96
                     (when (or (eq fast slow) (member slow seen))
97
                       (return-from circular-tree-p t))
98
                     (when (or (not (consp fast)) (not (consp (cdr slow))))
99
                       (return
100
                         (do ((tail object (cdr tail)))
101
                             ((not (consp tail))
102
                              nil)
103
                           (let ((elt (car tail)))
104
                             (circularp elt (cons object seen))))))))))
105
     (circularp object nil)))
106
 
107
 ;;; On Lisp
108
 (declaim (inline group))
109
 (defun group (source n)
110
   "Return a list of lists by grouping SOURCE into N-element batches."
111
   (declare (fixnum n))
112
   (when (zerop n) (error "zero length"))
113
   (labels ((rec (source acc)
114
              (let ((rest (nthcdr n source)))
115
                (if (consp rest)
116
                    (rec rest (cons
117
                               (subseq source 0 n)
118
                               acc))
119
                    (nreverse
120
                     (cons source acc))))))
121
     (if source (rec source nil) nil)))
122
 
123
 (eval-when (:compile-toplevel :load-toplevel :execute)
124
   (defun flatten (x)
125
     "Flatten list X, removing nil elements."
126
     (let (list)
127
       (labels ((rec (tree)
128
                  (when tree
129
                    (if (consp tree)
130
                        (progn 
131
                          (rec (car tree))
132
                          (rec (cdr tree)))
133
                        (push tree list)))))
134
         (rec x)
135
         (nreverse list))))
136
 
137
   (defun flatten* (x)
138
     (labels ((rec (x acc)
139
                (cond ((null x) acc)
140
                      ((typep x 'sb-impl::comma) (rec (sb-impl::comma-expr x) acc))
141
                      ((atom x) (cons x acc))
142
                      (t (rec
143
                          (car x)
144
                          (rec (cdr x) acc))))))
145
       (rec x nil))))
146
 
147
 (eval-when (:compile-toplevel :load-toplevel :execute)
148
   (defun zip-list (&rest args)
149
     "Return a list of lists containing every member of ARGS at the same position."
150
     (apply 'map 'list 'list args)))
151
 
152
 (defun zip-tree (&rest args)
153
   (if (and (some #'atom args) (some #'consp args)) nil
154
       (if (every #'atom args) args
155
           (apply #'mapcar #'zip-tree args))))
156
 
157
 (defun zipsym (lst)
158
   "Zips a unique gensym with each element of LST.
159
 
160
 Example:
161
 (zipsym '(a b c)) ;; ((#:G1064 A) (#:G1065 B) (#:G1066 C))"  
162
   (map 'list #'(lambda (x) (list (gensym) x)) lst))
163
 
164
 (defun list-dimensions (lst)
165
   (if (atom lst) nil
166
       (cons (length lst) (list-dimensions (car lst)))))
167
 
168
 (defun recursive-append (&rest lsts)
169
   "Append lists in a nested manner.
170
 
171
 Example:
172
 
173
 (recursive-append
174
   '(let ((x 1)))
175
   '(+ x 2))
176
 
177
 ;; (LET ((X 1)) (+ X 2))"
178
   (reduce #'(lambda (x y)
179
               (if (null x)
180
                   (if (typep (car y) 'symbol) y (car y))
181
                   (append x (and y (if (typep (car y) 'symbol) `(,y) y)))))
182
           lsts :from-end t))
183
 
184
 (defmacro ziprm (r m &rest args)
185
   "Reduce-Map on ARGS.
186
 
187
 Example:
188
 
189
 (macroexpand-1
190
   `(ziprm (and =) (a b c) (1 2 3)))
191
 ;; (AND (= A 1) (= B 2) (= C 3))"
192
   `(,r ,@(apply #'mapcar #'(lambda (&rest atoms) (cons m atoms)) (mapcar #'ensure-list args))))
193
 
194
 (defun circular-list-error (list)
195
   (error 'type-error
196
          :datum list
197
          :expected-type '(and list (not circular-list))))
198
 
199
 (declaim (inline safe-endp))
200
 (defun safe-endp (x)
201
   (declare (optimize safety))
202
   (endp x))
203
 
204
 (macrolet ((def (name lambda-list doc step declare ret1 ret2)                      
205
              (assert (member 'list lambda-list))                                   
206
              `(defun ,name ,lambda-list                                            
207
                 ,doc                                                               
208
                 (unless (listp list)                                               
209
                   (error 'type-error :datum list :expected-type 'list))            
210
                 (do ((last list fast)                                              
211
                      (fast list (cddr fast))                                       
212
                      (slow (cons (car list) (cdr list)) (cdr slow))                
213
                      ,@(when step (list step)))                                    
214
                     (nil)                                                          
215
                   (declare (dynamic-extent slow) ,@(when declare (list declare))   
216
                            (ignorable last))                                       
217
                   (when (safe-endp fast)                                           
218
                     (return ,ret1))                                                
219
                   (when (safe-endp (cdr fast))                                     
220
                     (return ,ret2))                                                
221
                   (when (eq fast slow)                                             
222
                     (circular-list-error list))))))                                
223
   (def proper-list-length (list)                                                   
224
     "Returns length of LIST, signalling an error if it is not a proper list."      
225
     (n 1 (+ n 2))                                                                  
226
     ;; KLUDGE: Most implementations don't actually support lists with bignum       
227
     ;; elements -- and this is WAY faster on most implementations then declaring   
228
     ;; N to be an UNSIGNED-BYTE.                                                   
229
     (fixnum n)                                                                     
230
     (1- n)                                                                         
231
     n)                                                                             
232
                                                                                    
233
   (def lastcar (list)                                                              
234
       "Returns the last element of LIST. Signals a type-error if LIST is not a     
235
 proper list."                                                                      
236
     nil                                                                            
237
     nil                                                                            
238
     (cadr last)                                                                    
239
     (car fast))                                                                    
240
                                                                                    
241
   (def (setf lastcar) (object list)                                                
242
       "Sets the last element of LIST. Signals a type-error if LIST is not a proper 
243
 list."                                                                             
244
     nil                                                                            
245
     nil                                                                            
246
     (setf (cadr last) object)                                                      
247
     (setf (car fast) object)))                                                     
248
 
249
 (defun mappend (fn &rest lists)
250
   (loop for ret in (apply #'mapcar fn lists)
251
         append ret))
252
 
253
 (defun cart (list &rest more-lists)
254
   "Returns the cartesian product of LIST and MORE-LISTS.
255
 
256
 The length of the result is equal to the product of the lengths of all input
257
 lists. A zero-length list anywhere in the input will always return NIL.
258
 
259
 The length of each element of the result is equal to the length of the
260
 shortest input list.
261
 
262
 Example:
263
 
264
 (cart (list 1 2) (list 3 4 5)) ;; ((1 3) (2 3) (1 4) (2 4) (1 5) (2 5))
265
 (cart (list 1 2 3) (list 4 5)) ;; ((1 4) (2 4) (3 4) (1 5) (2 5) (3 5))
266
 (cart (list 1 2 3) nil (list 4 5)) ;; nil
267
 "
268
   (if more-lists
269
       (mapcan #'(lambda (y) (mapcar #'(lambda (x) (cons x y)) list)) (apply #'cart more-lists))
270
       (mapcar #'list list)))
271
 
272
 (defun mapcart (function list &rest more-lists)
273
   "(MAPCAR (LAMBDA (X) (APPLY FUNCTION X)) (APPLY CART LIST MORE-LISTS))
274
 
275
 Remember that CART always returns elements with a length equal to the smallest
276
 input list. FUNCTION will need to accept at least as many args as the element
277
 size.
278
 
279
 Example:
280
 (mapcart '+ '(1 2 3) '(4 5)) ;; (5 6 7 6 7 8)"
281
   (mapcar (lambda (args) (apply function args)) (apply #'cart list more-lists)))
282
 
283
 (defmacro cart-case ((&rest vars) &body cases)
284
   (let ((decl (zipsym vars)))
285
     `(let (,@decl)
286
        (cond ,@(mapcar #'(lambda (clause) `((ziprm (and eql) ,(mapcar #'car decl) ,(first clause)) ,@(cdr clause))) cases)))))
287
 
288
 (defmacro cart-ecase ((&rest vars) &body cases)
289
   (let ((decl (zipsym vars)))
290
     `(let (,@decl)
291
        (cond ,@(mapcar #'(lambda (clause) `((ziprm (and eql) ,(mapcar #'car decl) ,(first clause)) ,@(cdr clause))) cases)
292
              (t (error "cart-ecase: Case failure."))))))
293
 
294
 (defmacro cart-typecase (vars &body cases)
295
   (let* ((decl (zipsym vars)))
296
     `(let (,@decl)
297
        (cond ,@(mapcar #'(lambda (clause) `((ziprm (and typep) ,(mapcar #'car decl) ,(mapcar #'(lambda (x) `(quote ,x)) (first clause))) ,@(cdr clause))) cases)))))
298
 
299
 (defmacro cart-etypecase (vars &body cases)
300
   (let* ((decl (zipsym vars)))
301
     `(let (,@decl)
302
        (cond ,@(mapcar #'(lambda (clause) `((ziprm (and typep) ,(mapcar #'car decl) ,(mapcar #'(lambda (x) `(quote ,x)) (first clause))) ,@(cdr clause))) cases)
303
              (t (error "cart-etypecase: Case failure."))))))
304
 
305
 (declaim (inline pairs))
306
 (defun pairs (list)
307
   "Return a new list containing each pair of elements in LIST."
308
   (loop for (a . b) on list by #'cddr collect (if b (list a (first b)) (list a))))
309
 
310
 (defun maptree-if (predicate transformer tree)
311
   "Returns a new tree by recursively calling TRANSFORMER on sub-trees which
312
 satisfy the PREDICATE.
313
 
314
 predicate : tree -> boolean
315
 transformer: tree -> (or tree atom) *control
316
 
317
 If the transformer returns a CONTROL function, then the tree returned by the
318
 transformer is replaced in-turn by the result of:
319
 
320
 (funcall CONTROL #'(lambda (x) (maptree-if PREDICATE TRANSFORMER x)) transformed-tree)
321
 
322
 otherwise it is left as it is.
323
 
324
 Example:
325
   (maptree-if #'(λ (x) (and (consp x) (eq (car x) 'ping)))
326
               #'(λ (x) `(pong ,@(cdr x)))
327
               '(progn (ping (ping (ping 1)))))
328
   ;; (PROGN (PONG (PING (PING 1))))
329
   (maptree-if #'(λ (x) (and (consp x) (eq (car x) 'ping)))
330
               #'(λ (x) (values `(pong ,@(cdr x)) #'mapcar))
331
               '(progn (ping (ping (ping 1)))))
332
   ;; (PROGN (PONG (PONG (PONG 1))))
333
   "
334
   (multiple-value-bind (t-tree control) (if (funcall predicate tree)
335
                                             (funcall transformer tree)
336
                                             (values tree #'mapcar))
337
     (if (and (consp t-tree) control)
338
         (funcall control #'(lambda (x) (maptree-if predicate transformer x)) t-tree)
339
         t-tree)))
340
 
341
 (defun maptree (keys transformer tree)
342
   (maptree-if #'(lambda (x) (and (consp x) (member (car x) keys)))
343
               transformer tree))
344
 
345
 (defmacro nconsc (var &rest args)
346
   "Macro to do setf and nconc for destructive list updates. 
347
 
348
 If VAR is null then VAR is set to (apply #'nconc ARGS), 
349
 
350
 else does (apply #'nconc (cons VAR ARGS)).
351
 
352
 Example:
353
 (let ((x nil))
354
   (nconsc x (list 1 2 3) (list 'a 'b 'c))
355
   x)
356
 ;; (1 2 3 A B C)
357
 
358
 (let ((x (list 'a 'b 'c)))
359
   (nconsc x (list 1 2 3))
360
    x)
361
 ;; (A B C 1 2 3)"
362
   (assert (and (symbolp var) (not (member var '(t nil)))))
363
   (if (null args) var
364
       `(if (null ,var)
365
            (progn
366
              (setf ,var ,(car args))
367
              (nconc ,var ,@(cdr args)))
368
            (nconc ,var ,@args))))
369
 
370
 ;; from serapeum
371
 (declaim (inline firstn))
372
 (defun firstn (n list)
373
   (loop repeat n for x in list collect x))
374
 
375
 ;;; cl-bench utils
376
 ;; From Hansen's MS thesis.
377
 (defun merge! (a b predicate)
378
   "Destructively merge two sorted lists given comparison function PREDICATE."
379
   (labels ((merge-loop (r a b)
380
              (cond ((funcall predicate (car b) (car a))
381
                     (setf (cdr r) b)
382
                     (if (null (cdr b))
383
                         (setf (cdr b) a)
384
                         (merge-loop b a (cdr b))))
385
                    (t ; (car a) <= (car b)
386
                     (setf (cdr r) a)
387
                     (if (null (cdr a))
388
                         (setf (cdr a) b)
389
                         (merge-loop a (cdr a) b))))))
390
     (cond ((null a) b)
391
           ((null b) a)
392
           ((funcall predicate (car b) (car a))
393
            (if (null (cdr b))
394
                (setf (cdr b) a)
395
                (merge-loop b a (cdr b)))
396
            b)
397
           (t                           ; (car a) <= (car b)
398
            (if (null (cdr a))
399
                (setf (cdr a) b)
400
                (merge-loop a (cdr a) b))
401
            a))))
402
 
403
 ;; Due to Richard O'Keefe; algorithm attributed to D.H.D. Warren.
404
 (defun sort! (seq predicate)
405
   "Stable sort which copies the input list SEQ and then sorts the new list
406
 imperatively according to PREDICATE."
407
   (labels ((astep (n)
408
              (cond ((> n 2)
409
                     (let* ((j (truncate n 2))
410
                            (a (astep j))
411
                            (k (- n j))
412
                            (b (astep k)))
413
                       (merge! a b predicate)))
414
                    ((= n 2)
415
                     (let ((x (car seq))
416
                           (y (cadr seq))
417
                           (p seq))
418
                       (setf seq (cddr seq))
419
                       (when (funcall predicate y x)
420
                         (setf (car p) y)
421
                         (setf (cadr p) x))
422
                       (setf (cddr p) nil)
423
                       p))
424
                    ((= n 1)
425
                     (let ((p seq))
426
                       (setf seq (cdr seq))
427
                       (setf (cdr p) nil)
428
                       p))
429
                    (t nil))))
430
     (astep (length seq))))
431
 
432
 ;; from alexandria
433
 (defun set-equal (list1 list2 &key (test #'eql) (key nil keyp))
434
   "Returns true if every element of LIST1 matches some element of LIST2 and
435
 every element of LIST2 matches some element of LIST1. Otherwise returns false."
436
   (let ((keylist1 (if keyp (mapcar key list1) list1))
437
         (keylist2 (if keyp (mapcar key list2) list2)))
438
     (and (dolist (elt keylist1 t)
439
            (or (member elt keylist2 :test test)
440
                (return nil)))
441
          (dolist (elt keylist2 t)
442
            (or (member elt keylist1 :test test)
443
                (return nil))))))
444
 
445
 ;;; ALIST
446
 (declaim (inline racons))
447
 (defun racons (key value ralist)
448
   (acons value key ralist))
449
 
450
 (macrolet
451
     ((define-alist-get (name get-entry get-value-from-entry add doc)
452
        `(progn
453
           (declaim (inline ,name))
454
           (defun ,name (alist key &key (test 'eql))
455
             ,doc
456
             (let ((entry (,get-entry key alist :test test)))
457
               (values (,get-value-from-entry entry) entry)))
458
           (define-setf-expander ,name (place key &key (test ''eql)
459
                                        &environment env)
460
             (multiple-value-bind
461
                   (temporary-variables initforms newvals setter getter)
462
                 (get-setf-expansion place env)
463
               (when (cdr newvals)
464
                 (error "~A cannot store multiple values in one place" ',name))
465
               (with-gensyms (new-value key-val test-val alist entry)
466
                 (values
467
                  (append temporary-variables
468
                          (list alist
469
                                key-val
470
                                test-val
471
                                entry))
472
                  (append initforms
473
                          (list getter
474
                                key
475
                                test
476
                                `(,',get-entry ,key-val ,alist :test ,test-val)))
477
                  `(,new-value)
478
                  `(cond
479
                     (,entry
480
                      (setf (,',get-value-from-entry ,entry) ,new-value))
481
                     (t
482
                      (let ,newvals
483
                        (setf ,(first newvals) (,',add ,key ,new-value ,alist))
484
                        ,setter
485
                        ,new-value)))
486
                  `(,',get-value-from-entry ,entry))))))))
487
  (define-alist-get assoc-value assoc cdr acons
488
 "ASSOC-VALUE is an alist accessor very much like ASSOC, but it can
489
 be used with SETF.")
490
  (define-alist-get rassoc-value rassoc car racons
491
 "RASSOC-VALUE is an alist accessor very much like RASSOC, but it can
492
 be used with SETF."))
493
 
494
 ;;; DLIST
495
 
496
 ;; Simple doubly-linked lists
497
 
498
 ;; ref: https://github.com/bharath1097/matlisp/blob/94b65e68f2de5208ef9641cd105e25512c36a7f5/src/utilities/dlist.lisp
499
 
500
 ;; ref: https://github.com/krzysz00/dlist
501
 (defun dcons (obj)
502
   (let ((lst (list* nil nil obj)))
503
     (setf (first lst) lst
504
           (second lst) lst)
505
     lst))
506
 
507
 (defmacro dpush (obj dll &environment env)
508
   (multiple-value-bind (dummies vals new setter getter) (get-setf-expansion dll env)
509
     (when (cdr new)
510
       (error "Can't expand this."))
511
     (with-gensyms (left right ele ncon)
512
       (let ((new (car new)))
513
         `(let* (,@(zip-list dummies vals)
514
                 (,new ,getter)
515
                 (,ncon (dcons ,obj)))
516
            (when ,new
517
              (destructuring-bind (,left ,right . ,ele) ,new
518
                (declare (ignore ,right ,ele))
519
                (setf (first ,ncon) ,left
520
                      (second ,left) ,ncon
521
                      (second ,ncon) ,new
522
                      (first ,new) ,ncon)))
523
            (setf ,new ,ncon)
524
            ,setter)))))
525
 
526
 (defmacro dpop (dll &environment env)
527
   (multiple-value-bind (dummies vals new setter getter) (get-setf-expansion dll env)
528
     (when (cdr new)
529
       (error "Can't expand this."))
530
     (with-gensyms (left right ele)
531
       (let ((new (car new)))
532
         `(let* (,@(zip-list dummies vals)
533
                 (,new ,getter))
534
            (when ,new
535
              (destructuring-bind (,left ,right . ,ele) ,new
536
                (prog1 ,ele
537
                  ;;update cons cell
538
                  (setf (first ,new) ,new
539
                        (second ,new) ,new)
540
                  ;;update place
541
                  (if (and (eql ,new ,left) (eql ,new ,right))
542
                      (setf ,new nil)
543
                      (setf (second ,left) ,right
544
                            (first ,right) ,left
545
                            ,new ,right))
546
                  ,setter))))))))
547
 
548
 (defun dlist (&rest objs)
549
   (let* ((rev (reverse objs))
550
          (ret (dcons (car rev))))
551
     (loop :for ele :in (cdr rev)
552
        :do (dpush ele ret))
553
     ret))
554
 
555
 (declaim (inline drdc dcdr dcar))
556
 (defun drdc (buf) (first buf))
557
 (defun dcdr (buf) (second buf))
558
 (defun dcar (buf) (cddr buf))
559
 
560
 (defun dappendf (&rest dlsts)
561
   (let ((dlsts (remove-if #'null dlsts)))
562
     (loop for se in (cdr dlsts)
563
        with ft = (car dlsts)
564
        do (progn
565
              (rotatef (first ft) (first se))
566
              (rotatef (second (first ft)) (second (first se))))
567
        finally (return ft))))
568
 
569
 ;;; Template utils
570
 ;; Topological sort (matlisp)
571
 (defun toposort (lst func &optional (test #'eql))
572
   (multiple-value-bind (nlst len) (loop :for ele :in lst
573
                                      :for i := 0 :then (1+ i)
574
                                      :collect (cons i ele) :into ret
575
                                      :finally (return (values ret (1+ i))))
576
     (let* ((s nil)
577
            (graph (let ((ret (make-array len)))
578
                     (loop :for (i . ele) :in nlst
579
                        :do (let ((children (mapcar #'car (remove-if-not #'(lambda (x) (and (not (funcall test (cdr x) ele)) (funcall func (cdr x) ele))) nlst)))
580
                                  (parents (mapcar #'car (remove-if-not #'(lambda (x) (and (not (funcall test (cdr x) ele)) (funcall func ele (cdr x)))) nlst))))
581
                              (when (null parents)
582
                                (push i s))
583
                              (setf (aref ret i) (list ele children parents))))
584
                     ret))
585
            (ordering nil))
586
     (let ((last-s (last s)))
587
       (do ((slst s (cdr slst)))
588
           ((null slst))
589
         (let* ((i (car slst))
590
                (children (second (aref graph i))))
591
           (mapcar #'(lambda (x)
592
                       (let ((par (third (aref graph x))))
593
                         (let ((par (remove i par)))
594
                           (setf (third (aref graph x)) par)
595
                           (when (null par)
596
                             (setf (cdr last-s) (cons x nil)
597
                                   last-s (cdr last-s))))))
598
                   children)
599
           (push i ordering))))
600
     (mapcar #'(lambda (x) (car (aref graph x))) ordering))))
601
 
602
 (defun match-lambda-lists (lsta lstb)
603
   (let ((optional? nil))
604
     (labels ((optp? (a b)
605
                (if (and (consp a) (atom b)) (optp? b a)
606
                    (progn
607
                      (if (or (member a lambda-list-keywords) (not optional?)) nil
608
                          (if (null (cddr b)) t nil)))))
609
              (lst-walker (a b)
610
                (cond
611
                  ((and (atom a) (atom b))
612
                   (if (eq a b)
613
                       (progn
614
                         (when (member a lambda-list-keywords)
615
                           (setq optional? (if (member a '(&optional &key)) t nil)))
616
                         t)
617
                       (if (or (member a lambda-list-keywords) (member b lambda-list-keywords)) nil t)))
618
                  ((or (atom a) (atom b))
619
                   (if (optp? a b) t nil))
620
                  ((and (consp a) (consp b))
621
                   (and (lst-walker (car a) (car b))
622
                        (lst-walker (cdr a) (cdr b)))))))
623
       (lst-walker lsta lstb))))
624
 ����