Add ENCODE- and DECODE-GENERAL-CAR-CDR.

diff --git a/src/runtime/list.scm b/src/runtime/list.scm
index 72fde39ada595dad261ff7dfc0ae539cde88b9d7..faf50fe1796a3f48aa9421c0771fafa67ab898ce 100644 (file)
--- a/src/runtime/list.scm
+++ b/src/runtime/list.scm
@@ -474,6 +474,31 @@ USA.
                      (error:not-weak-list items 'WEAK-DELQ!))))))
     (trim-initial-segment items)))
 \f
+;;;; General CAR CDR
+
+;;; Return a list of car and cdr symbols that the code
+;;; represents.  Leftmost operation is outermost.
+(define (decode-general-car-cdr code)
+  (guarantee-positive-fixnum code)
+  (do ((code code (fix:lsh code -1))
+       (result '() (cons (if (even? code) 'cdr 'car) result)))
+      ((= code 1) result)))
+
+;;; Return the bit string that encode the operation-list.
+;;; Operation list is encoded with leftmost outer.
+(define (encode-general-car-cdr operation-list)
+  (do ((code operation-list (cdr code))
+       (answer 1 (+ (* answer 2)
+                   (case (car code)
+                     ((CAR) 1)
+                     ((CDR) 0)
+                     (else (error "encode-general-car-cdr: Invalid operation"
+                                   (car code)))))))
+      ((not (pair? code))
+       (if (not (fixnum? answer))
+          (error "encode-general-car-cdr: code too large" answer)
+          answer))))
+\f
 ;;;; Standard Selectors
 
 (declare (integrate-operator safe-car safe-cdr))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 1be99788ad1312fd83f11f6ba6fce6d574540022..6785ef6782fdf55d2efef560ce8f9129e60350eb 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2318,6 +2318,7 @@ USA.
          cons*
          count-matching-items
          count-non-matching-items
+         decode-general-car-cdr
          del-assoc
          del-assoc!
          del-assq
@@ -2336,6 +2337,7 @@ USA.
          delv!
          dotted-list?                  ;SRFI-1
          eighth
+         encode-general-car-cdr
          error:not-alist
          error:not-circular-list
          error:not-dotted-list