return alists; refactor structure

1 files changed, 0 insertions, 383 deletions

diff --git a/srfi/default-impl.scm b/srfi/default-impl.scm
deleted file mode 100644
index ef1eb6c..0000000
--- a/srfi/default-impl.scm
+++ /dev/null
@@ -1,383 +0,0 @@
-(define default-dto
-  (let ()
-
-    ;; implementation of "default" dto, used as a filler for undefined
-    ;; functions in other dtos
-
-    ;; primitives
-    (define (not-implemented name)
-      (lambda (dto . args)
-        (raise (dictionary-error (string-append name " not implemented") dto))))
-    (define default-dictionary? (not-implemented "dictionary?"))
-    (define default-dict-pure? (not-implemented "dict-pure?"))
-    (define default-dict-size (not-implemented "dict-size"))
-    (define default-dict-find-update (not-implemented "dict-find-update"))
-
-    (define (default-dict-empty? dto dictionary)
-      (= 0 (dict-size dto dictionary)))
-
-    (define (default-dict=? dto = dict1 dict2)
-      (define (check-entries* keys)
-        (cond
-          ((null? keys) #t)
-          (else (let* ((key (car keys))
-                       (d1-value (dict-ref dto dict1 key)))
-                  (dict-ref dto dict2 key
-                            (lambda () #f)
-                            (lambda (d2-value)
-                              (if (= d1-value d2-value)
-                                  (check-entries* (cdr keys))
-                                  #f)))))))
-      (and (= (dict-size dto dict1)
-              (dict-size dto dict2))
-           (check-entries* (dict-keys dto dict1))))
-
-    (define (default-dict-contains? dto dictionary key)
-      (dict-ref dto dictionary key
-                (lambda () #f)
-                (lambda (x) #t)))
-
-    (define (default-dict-ref dto dictionary key failure success)
-      (dict-find-update dto dictionary key
-                     (lambda (insert ignore)
-                       (failure))
-                     (lambda (key value update remove)
-                       (success value))))
-
-    (define (default-dict-ref/default dto dictionary key default)
-      (dict-ref dto dictionary key
-                (lambda () default)
-                (lambda (x) x)))
-
-    ;; private
-    (define (default-dict-set* dto dictionary use-old? objs)
-      (let loop ((objs objs)
-                 (dictionary dictionary))
-        (cond
-         ((null? objs)
-          dictionary)
-         ((null? (cdr objs))
-          (error "mismatch of key / values argument list" objs))
-         (else (let* ((key (car objs))
-                      (value (cadr objs))
-                      (new-d (dict-find-update dto dictionary key
-                                         (lambda (insert ignore)
-                                           (insert value))
-                                         (lambda (key old-value update delete)
-                                           (update key (if use-old? old-value value))))))
-                 (loop (cddr objs)
-                       new-d))))))
-
-    (define (default-dict-set dto dictionary . objs)
-      (default-dict-set* dto dictionary #f objs))
-
-    (define (default-dict-adjoin dto dictionary . objs)
-      (default-dict-set* dto dictionary #t objs))
-
-    (define (default-dict-delete dto dictionary . keys)
-      (dict-delete-all dto dictionary keys))
-
-    (define (default-dict-delete-all dto dictionary keylist)
-      (let loop ((keylist keylist)
-                 (d dictionary))
-        (cond
-          ((null? keylist) d)
-          (else (let* ((key (car keylist))
-                       (new-d (dict-find-update dto d key
-                                          (lambda (_ ignore)
-                                            (ignore))
-                                          (lambda (key old-value _ delete)
-                                            (delete)))))
-                  (loop (cdr keylist)
-                        new-d))))))
-
-    (define (default-dict-replace dto dictionary key value)
-      (dict-find-update dto dictionary key
-                  (lambda (_ ignore)
-                    (ignore))
-                  (lambda (key old-value update _)
-                    (update key value))))
-
-    (define (default-dict-intern dto dictionary key failure)
-      (dict-find-update dto dictionary key
-                  (lambda (insert _)
-                    (let ((value (failure)))
-                     (values (insert value) value)))
-                  (lambda (key value update _)
-                    (values dictionary value))))
-
-    (define (default-dict-update dto dictionary key updater failure success)
-      (dict-find-update dto dictionary key
-                  (lambda (insert ignore)
-                    (insert (updater (failure))))
-                  (lambda (key value update _)
-                    (update key (updater (success value))))))
-
-    (define (default-dict-update/default dto dictionary key updater default)
-      (dict-update dto dictionary key updater
-                    (lambda () default)
-                    (lambda (x) x)))
-
-    (define (default-dict-pop dto dictionary)
-      (define (do-pop)
-        (call/cc
-         (lambda (cont)
-           (dict-for-each dto
-                          (lambda (key value)
-                            (define new-dict
-                              (dict-delete-all dto dictionary (list key)))
-                            (cont new-dict key value))
-                          dictionary))))
-      (define empty? (dict-empty? dto dictionary))
-      (if empty?
-          (error "popped empty dictionary")
-          (do-pop)))
-
-    (define default-dict-map (not-implemented "dict-map"))
-
-    (define (default-dict-filter dto pred dictionary)
-      (define keys (dict-keys dto dictionary))
-      (define keys-to-delete
-        (filter
-         (lambda (key)
-           (not (pred key (dict-ref dto dictionary key))))
-         keys))
-      (dict-delete-all dto dictionary keys-to-delete))
-
-    (define (default-dict-remove dto pred dictionary)
-      (dict-filter dto (lambda (key value)
-                          (not (pred key value)))
-                    dictionary))
-
-    (define (default-dict-count dto pred dictionary)
-      (dict-fold dto
-                 (lambda (key value acc)
-                   (if (pred key value)
-                       (+ 1 acc)
-                       acc))
-                 0
-                 dictionary))
-
-    (define (default-dict-any dto pred dictionary)
-      (call/cc
-       (lambda (cont)
-         (dict-for-each dto
-                        (lambda (key value)
-                          (define ret (pred key value))
-                          (when ret
-                            (cont ret)))
-                        dictionary)
-         #f)))
-
-    (define (default-dict-every dto pred dictionary)
-      (define last #t)
-      (call/cc
-       (lambda (cont)
-         (dict-for-each dto
-                        (lambda (key value)
-                          (define ret (pred key value))
-                          (when (not ret)
-                            (cont #f))
-                          (set! last ret))
-                        dictionary)
-         last)))
-
-    (define (default-dict-keys dto dictionary)
-      (reverse
-       (dict-fold dto
-                  (lambda (key value acc)
-                    (cons key acc))
-                  '()
-                  dictionary)))
-
-    (define (default-dict-values dto dictionary)
-      (reverse
-       (dict-fold dto
-                  (lambda (key value acc)
-                    (cons value acc))
-                  '()
-                  dictionary)))
-
-    (define (default-dict-entries dto dictionary)
-      (define pair
-        (dict-fold dto
-                   (lambda (key value acc)
-                     (cons (cons key (car acc))
-                           (cons value (cdr acc))))
-                   (cons '() '())
-                   dictionary))
-      (values (reverse (car pair))
-              (reverse (cdr pair))))
-
-    (define (default-dict-fold dto proc knil dictionary)
-      (define acc knil)
-      (dict-for-each dto
-                     (lambda (key value)
-                       (set! acc (proc key value acc)))
-                     dictionary)
-      acc)
-
-    (define (default-dict-map->list dto proc dictionary)
-      (define reverse-lst
-        (dict-fold dto
-                   (lambda (key value lst)
-                     (cons (proc key value) lst))
-                   '()
-                   dictionary))
-      (reverse reverse-lst))
-
-    (define (default-dict->alist dto dictionary)
-      (dict-map->list dto
-                      cons
-                      dictionary))
-
-    (define default-dict-comparator (not-implemented "dict-comparator"))
-
-    (define (default-dict-for-each dto proc dict start end)
-      (define (any . _) #t)
-      (define cmp (dict-comparator dto dict))
-      (define lower
-        (if start
-            (lambda (el) (>=? cmp el start))
-            any))
-      (define upper
-        (if end
-            (lambda (el) (<=? cmp el end))
-            any))
-      (define (accept el)
-        (and (upper el) (lower el)))
-      
-      (dict-map 
-        dto
-        (lambda (key value)
-          (when (accept key)
-            (proc key value))
-          value)
-        dict))
-
-    (define (default-dict->generator dto dict start end)
-      
-      (define (any . _) #t)
-      (define cmp (dict-comparator dto dict))
-      (define lower
-        (if start
-            (lambda (el) (>=? cmp el start))
-            any))
-      (define upper
-        (if end
-            (lambda (el) (<=? cmp el end))
-            any))
-      (define (accept el)
-        (and (upper el) (lower el)))
-
-      ;; proc that takes yield value and yield continuation when yield is called
-      ;; shouldn't return
-      (define yield-handler #f)
-      
-      (define (yield value)
-        (when (or (eof-object? value)
-                  (accept (car value)))
-          (call/cc (lambda (yield-cont)
-                     (yield-handler value yield-cont))) ))
-      
-      (define (generate)
-        (dict-for-each dto
-                       (lambda (key value)
-                         (yield (cons key value)))
-                       dict)
-        (yield (eof-object)))
-      
-      ;; continuation at the point of last yield
-      (define yield-cont #f)
-      
-      ;; check if eof return was seen; if yes, keep returning eof
-      ;; for further invocations
-      (define eof #f)
-      
-      (define (get-next-value exit)
-        (set! yield-handler
-          (lambda (value new-yield-cont)
-            (set! yield-cont new-yield-cont)
-            (when (eof-object? value)
-              (set! eof #t)
-              ;; unset continuation reference to allow
-              ;; gc clean everything up
-              (set! yield-cont #f))
-            (exit value)))
-        
-        (cond
-          ;; eof seen -- keep returning eof
-          (eof (eof-object))
-          ;; no yield called yet -- start the generator
-          ((not yield-cont) (generate))
-          ;; continue from last yield position
-          (else (yield-cont #t))))
-      
-      (lambda ()
-        (call/cc get-next-value)))
-
-    (define (default-dict-accumulator dto dict acc-proc)
-      (lambda (arg)
-        (if (eof-object? arg)
-            dict
-            (set! dict (acc-proc dto dict (car arg) (cdr arg))))))
-
-    (define (default-dict-set-accumulator dto dict)
-      (default-dict-accumulator dto dict dict-set))
-
-    (define (default-dict-adjoin-accumulator dto dict)
-      (default-dict-accumulator dto dict dict-adjoin))
-
-    (let ()
-      (define null-dto (make-dto-private (make-vector dict-procedures-count #f)))
-      (define default-dto
-        (make-modified-dto
-         null-dto
-         dictionary?-id default-dictionary?
-         dict-empty?-id default-dict-empty?
-         dict-contains?-id default-dict-contains?
-         dict=?-id default-dict=?
-         dict-pure?-id default-dict-pure?
-         dict-ref-id default-dict-ref
-         dict-ref/default-id default-dict-ref/default
-         dict-set-id default-dict-set
-         dict-adjoin-id default-dict-adjoin
-         dict-delete-id default-dict-delete
-         dict-delete-all-id default-dict-delete-all
-         dict-replace-id default-dict-replace
-         dict-intern-id default-dict-intern
-         dict-update-id default-dict-update
-         dict-update/default-id default-dict-update/default
-         dict-pop-id default-dict-pop
-         dict-map-id default-dict-map
-         dict-filter-id default-dict-filter
-         dict-remove-id default-dict-remove
-         dict-find-update-id default-dict-find-update
-         dict-size-id default-dict-size
-         dict-count-id default-dict-count
-         dict-any-id default-dict-any
-         dict-every-id default-dict-every
-         dict-keys-id default-dict-keys
-         dict-values-id default-dict-values
-         dict-entries-id default-dict-entries
-         dict-fold-id default-dict-fold
-         dict-map->list-id default-dict-map->list
-         dict->alist-id default-dict->alist
-         dict-comparator-id default-dict-comparator
-
-         dict-for-each-id default-dict-for-each
-
-         ;; generator procedures
-         dict->generator-id default-dict->generator
-         dict-set-accumulator-id default-dict-set-accumulator
-         dict-adjoin-accumulator-id default-dict-adjoin-accumulator))
-
-      ;; sanity check
-      (vector-for-each
-       (lambda (proc index)
-         (unless (and proc (procedure? proc))
-           (error "Missing or wrong default procedure definition" proc index)))
-       (procvec default-dto)
-       (list->vector (iota dict-procedures-count)))
-
-      default-dto)))