worlds/haxima-1.002/tbl.scm

   1 ;; (*tbl* (k1 v1) (k2 v2) ...)
   2
   3 (define (tbl-mk)
   4   (list '*tbl*))
   5
   6 ;; the val for key (#f if none)
   7 (define (tbl-get tbl key)
   8   (let ((kvpair (assoc key (cdr tbl))))
   9     (if kvpair
  10         (cadr kvpair)
  11         nil)))
  12
  13 ;; add key/val or replace the current val of key
  14 (define (tbl-set! tbl key val)
  15   (let ((kvpair (assoc key (cdr tbl))))
  16     (if kvpair
  17         (set-cdr! kvpair (list val))
  18         (set-cdr! tbl
  19                   (cons (cons key (list val))
  20                         (cdr tbl))))))
  21
  22 ;; append val to the value of key;
  23 ;; if key is not there make a new list with just val
  24 ;; if current value is not a list, converts it to a list first
  25 (define (tbl-append! tbl key val)
  26   (let ((entry (assoc key (cdr tbl))))
  27      (cond ((or (not entry)
  28                 (not (pair? (cdr entry))))
  29                 (tbl-set! tbl key (list val)))
  30         ((not (pair? (cadr entry)))
  31                 (set-cdr! entry (list (cons val (cdr entry)))))
  32         (#t
  33                 (set-cdr! entry (list (cons val (cadr entry))))))))
  34
  35 ;; run a procedure on each value in the table
  36 (define (tbl-for-each-val fx tbl)
  37   (for-each (lambda (entry)
  38               (println "tbl-for-each-val:entry=" entry)
  39               (println "cdr=" (cdr entry))
  40               (apply fx (cdr entry)))
  41             (cdr tbl)))
  42
  43 ;; remove the entry that matches key
  44 (define (tbl-rm! tbl key)
  45   (if (pair? (cdr tbl))
  46       (if (equal? key (caadr tbl))
  47           (set-cdr! tbl (cddr tbl))
  48           (tbl-rm! (cdr tbl) key))))
  49
  50 ;; set table values from name/value list
  51 (define (tbl-set-all! tbl entrydata)
  52         (if (not (null? entrydata))
  53                 (begin
  54                         (tbl-set! tbl (car entrydata) (car (cdr entrydata)))
  55                         (tbl-set-all! tbl (cddr entrydata))
  56                 )
  57         ))
  58
  59 (define (tbl-build . entrydata)
  60         (let ((tbl (tbl-mk)))
  61                 (tbl-set-all! tbl entrydata)
  62                 tbl
  63         ))
  64
  65 (define (is-tbl? tbl)
  66   (and (pair? tbl)
  67        (equal? (car tbl) '*tbl*)
  68        )
  69   )
  70
  71