Change slot-option merging code so that INITIAL-VALUE and INITIALIZER
authorChris Hanson <org/chris-hanson/cph>
Tue, 17 Jun 1997 08:10:41 +0000 (08:10 +0000)
committerChris Hanson <org/chris-hanson/cph>
Tue, 17 Jun 1997 08:10:41 +0000 (08:10 +0000)
shadow each other properly.

v7/src/sos/slot.scm

index 7048b62e1a1b84ffd652f5a3ac2479e3b20f00a5..759946764e5da3e4f06ba414f71482040267355b 100644 (file)
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: slot.scm,v 1.1 1997/06/04 06:09:18 cph Exp $
+;;; $Id: slot.scm,v 1.2 1997/06/17 08:10:41 cph Exp $
 ;;;
 ;;; Copyright (c) 1995-96 Massachusetts Institute of Technology
 ;;;
        (null? l1))))
 
 (define (compute-slot-descriptor class slots index)
-  (call-with-values
-      (lambda ()
-       (parse-slot-argument (merge-slot-arguments slots)))
-    (lambda (name properties)
-      (make-slot-descriptor name class index properties))))
+  (let ((slot (merge-slot-arguments slots)))
+    (make-slot-descriptor (car slot) class index (cdr slot))))
 
 (define (merge-slot-arguments slots)
-  (if (null? (cdr slots))
-      (car slots)
-      (let ((slots (reverse slots)))
-       (let ((result (list-copy (car slots))))
-         (for-each (lambda (slot)
-                     (merge-slot-arguments! slot result))
-                   (cdr slots))
-         result))))
-
-(define (merge-slot-arguments! x y)
-  (do ((x (cdr x) (cddr x)))
-      ((null? x))
-    (let ((key (car x))
-         (value (cadr x)))
-      (let loop ((z (cdr y)))
-       (cond ((null? z) (set-cdr! y (cons* key value (cdr y))))
-             ((eq? key (car z)) (set-car! (cdr z) value))
-             (else (loop (cddr z))))))))
-
-(define (parse-slot-argument argument)
-  (let loop ((plist (cdr argument)) (properties '()))
+  (let ((slots
+        (reverse!
+         (map (lambda (slot)
+                (cons (car slot)
+                      (plist->alist (cdr slot))))
+              slots))))
+    (let ((result (car slots)))
+      (for-each
+       (lambda (slot)
+        (for-each
+         (lambda (x)
+           (let ((names
+                  (or (list-search-positive interacting-options
+                        (lambda (names)
+                          (memq (car x) names)))
+                      (list names))))
+             (let ((entry
+                    (let loop ((names interaction))
+                      (and (not (null? names))
+                           (or (assq (car names) (cdr result))
+                               (loop (cdr names)))))))
+               (if entry
+                   (begin
+                     (set-car! entry (car x))
+                     (set-cdr! entry (cdr x)))
+                   (set-cdr! result (cons x (cdr result)))))))
+         (cdr slot)))
+       (cdr slots))
+      result)))
+
+(define interacting-options
+  '((INITIAL-VALUE INITIALIZER)))
+
+(define (plist->alist plist)
+  (let loop ((plist plist) (alist '()))
     (if (null? plist)
-       (values (car argument) properties)
+       alist
        (loop (cddr plist)
-             (cons (cons (car plist) (cadr plist)) properties)))))
\ No newline at end of file
+             (cons (cons (car plist) (cadr plist)) alist)))))
\ No newline at end of file