From: Joe Marshall <jmarshall@alum.mit.edu>
Date: Tue, 30 Mar 2010 23:32:49 +0000 (-0700)
Subject: Add ENCODE- and DECODE-GENERAL-CAR-CDR.
X-Git-Tag: 20100708-Gtk~71^2~3
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=997d6a6854e519a2f7d408e2c37f420af871f8dc;p=mit-scheme.git

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

diff --git a/src/runtime/list.scm b/src/runtime/list.scm
index 72fde39ad..faf50fe17 100644
--- 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)))
 
+;;;; 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))))
+
 ;;;; Standard Selectors
 
 (declare (integrate-operator safe-car safe-cdr))
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 1be99788a..6785ef678 100644
--- 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