From 997d6a6854e519a2f7d408e2c37f420af871f8dc Mon Sep 17 00:00:00 2001 From: Joe Marshall Date: Tue, 30 Mar 2010 16:32:49 -0700 Subject: [PATCH] Add ENCODE- and DECODE-GENERAL-CAR-CDR. --- src/runtime/list.scm | 25 +++++++++++++++++++++++++ src/runtime/runtime.pkg | 2 ++ 2 files changed, 27 insertions(+) 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 -- 2.25.1