home *** CD-ROM | disk | FTP | other *** search
/ Dream 44 / Amiga_Dream_44.iso / RiscPc / programmation / scm4e2.arc / !Scm / slib / rdms < prev    next >
Text File  |  1994-12-17  |  20KB  |  600 lines
  1. ;;; "rdms.scm" rewrite 6 - the saga continues
  2. ; Copyright 1994 Aubrey Jaffer
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (define rdms:catalog-name '*catalog-data*)
  21. (define rdms:domains-name '*domains-data*)
  22. (define rdms:columns-name '*columns*)
  23.  
  24. (define catalog:init-cols
  25.   '((1 #t table-name        #f atom)
  26.     (2 #f column-limit        #f uint)
  27.     (3 #f coltab-name        #f atom)
  28.     (4 #f bastab-id        #f base-id)
  29.     (5 #f user-integrity-rule    #f expression)
  30.     (6 #f view-procedure    #f expression)))
  31.  
  32. (define catalog:column-limit-pos 2)
  33. (define catalog:coltab-name-pos 3)
  34. (define catalog:bastab-id-pos 4)
  35. (define catalog:integrity-rule-pos 5)
  36. (define catalog:view-proc-pos 6)
  37.  
  38. (define columns:init-cols
  39.   '((1 #t column-number        #f uint)
  40.     (2 #f primary-key?        #f boolean)
  41.     (3 #f column-name        #f symbol)
  42.     (4 #f column-integrity-rule    #f expression)
  43.     (5 #f domain-name        #f domain)))
  44.  
  45. (define columns:primary?-pos 2)
  46. (define columns:name-pos 3)
  47. (define columns:integrity-rule-pos 4)
  48. (define columns:domain-name-pos 5)
  49.  
  50. (define domains:init-cols
  51.   '((1 #t domain-name        #f atom)
  52.     (2 #f foreign-table        #f atom)
  53.     (3 #f domain-integrity-rule    #f expression)
  54.     (4 #f type-id        #f type)
  55.     (5 #f type-param        #f expression)))
  56.  
  57. (define domains:foreign-pos 2)
  58. (define domains:integrity-rule-pos 3)
  59. (define domains:type-id-pos 4)
  60. (define domains:type-param-pos 5)
  61.  
  62. (define domains:init-data
  63.   `((atom #f
  64.           (lambda (x) (or (not x) (symbol? x) (number? x)))
  65.           atom
  66.           #f)
  67.     (type #f
  68.       #f                ;type checked when openning
  69.       symbol
  70.       #f)
  71.     (base-id #f
  72.          (lambda (x) (or (symbol? x) (number? x)))
  73.          base-id
  74.          #f)
  75.     (uint #f
  76.           (lambda (x)
  77.             (and (number? x)
  78.                  (integer? x)
  79.                  (not (negative? x))))
  80.           integer
  81.           #f)
  82.     (expression #f #f expression #f)
  83.     (boolean #f boolean? boolean #f)
  84.     (symbol #f symbol? symbol #f)
  85.     (string #f string? string #f)
  86.     (domain ,rdms:domains-name #f atom #f)))
  87.  
  88. (define (rdms:warn . args) (require 'debug) (apply print args))
  89. (define rdms:error slib:error)
  90.  
  91. (define (make-relational-system base)
  92.   (define basic
  93.     (lambda (name)
  94.       (let ((meth (base name)))
  95.     (cond ((not meth) (rdms:error 'make-relational-system
  96.                       "essential method missing for:" name)))
  97.     meth)))
  98.  
  99.   (define (desc-row-type row)
  100.     (let ((domain (assq (car (cddddr row)) domains:init-data)))
  101.       (and domain (cadddr domain))))
  102.  
  103.   (let ((make-base (base 'make-base))
  104.     (open-base (basic 'open-base))
  105.     (write-base (base 'write-base))
  106.     (sync-base (base 'sync-base))
  107.     (close-base (basic 'close-base))
  108.     (base:supported-type? (basic 'supported-type?))
  109.     (base:supported-key-type? (basic 'supported-key-type?))
  110.     (base:make-table (base 'make-table))
  111.     (base:open-table (basic 'open-table))
  112.     (base:kill-table (base 'kill-table))
  113.     (present? (basic 'present?))
  114.     (base:ordered-for-each-key (basic 'ordered-for-each-key))
  115.     (base:for-each-primary-key (basic 'for-each-key))
  116.     (base:map-primary-key (basic 'map-key))
  117.     (base:catalog-id (basic 'catalog-id))
  118.     (cat:keyify-1 ((basic 'make-keyifier-1)
  119.                (desc-row-type (assv 1 catalog:init-cols)))))
  120.  
  121.     (define (init-tab lldb id descriptor rows)
  122.       (let ((han (base:open-table lldb id 1 (itypes descriptor)))
  123.         (keyify-1
  124.          ((base 'make-keyifier-1) (desc-row-type (assv 1 descriptor))))
  125.         (putter ((basic 'make-putter) 1 (itypes descriptor))))
  126.     (for-each (lambda (row) (putter han (keyify-1 (car row)) (cdr row)))
  127.           rows)))
  128.  
  129.     (define (itypes rows)
  130.       (map (lambda (row)
  131.          (let ((domrow (assq (car (cddddr row)) domains:init-data)))
  132.            (cond (domrow (cadddr domrow))
  133.              (else (rdms:error 'itypes "type not found for:"
  134.                        (car (cddddr row)))))))
  135.        rows))
  136.  
  137.     (define cat:get-row
  138.       (let ((cat:getter ((basic 'make-getter) 1 (itypes catalog:init-cols))))
  139.     (lambda (bastab key)
  140.       (cat:getter bastab (cat:keyify-1 key)))))
  141.  
  142.     (define dom:get-row
  143.       (let ((dom:getter ((basic 'make-getter) 1 (itypes domains:init-cols)))
  144.         (dom:keyify-1 ((basic 'make-keyifier-1)
  145.                (desc-row-type (assv 1 domains:init-cols)))))
  146.     (lambda (bastab key)
  147.       (dom:getter bastab (dom:keyify-1 key)))))
  148.  
  149.     (define des:get-row
  150.       (let ((des:getter ((basic 'make-getter) 1 (itypes columns:init-cols)))
  151.         (des:keyify-1 ((basic 'make-keyifier-1)
  152.                (desc-row-type (assv 1 columns:init-cols)))))
  153.     (lambda (bastab key)
  154.       (des:getter bastab (des:keyify-1 key)))))
  155.  
  156.     (define (create-database filename)
  157.       (cond ((file-exists? filename)
  158.          (rdms:warn 'create-database "file exists:" filename)))
  159.       (let* ((lldb (make-base filename 1 (itypes catalog:init-cols)))
  160.          (cattab (and lldb (base:open-table lldb base:catalog-id 1
  161.                         (itypes catalog:init-cols)))))
  162.     (cond
  163.      ((not lldb) (rdms:error 'make-base "failed.") #f)
  164.      ((not cattab) (rdms:error 'make-base "catalog missing.")
  165.                (close-base lldb)
  166.                #f)
  167.      (else
  168.       (let ((desdes-id (base:make-table lldb 1 (itypes columns:init-cols)))
  169.         (domdes-id (base:make-table lldb 1 (itypes columns:init-cols)))
  170.         (catdes-id (base:make-table lldb 1 (itypes columns:init-cols)))
  171.         (domtab-id (base:make-table lldb 1 (itypes domains:init-cols))))
  172.         (cond
  173.          ((not (and catdes-id domdes-id domtab-id desdes-id))
  174.           (rdms:error 'create-database "make-table failed.")
  175.           (close-base lldb)
  176.           #f)
  177.          (else
  178.           (init-tab lldb desdes-id columns:init-cols columns:init-cols)
  179.           (init-tab lldb domdes-id columns:init-cols domains:init-cols)
  180.           (init-tab lldb catdes-id columns:init-cols catalog:init-cols)
  181.           (init-tab lldb domtab-id domains:init-cols domains:init-data)
  182.           (init-tab
  183.            lldb base:catalog-id catalog:init-cols
  184.            `((*catalog-desc* 5 ,rdms:columns-name ,catdes-id #f #f)
  185.          (*domains-desc* 5 ,rdms:columns-name ,domdes-id #f #f)
  186.          (,rdms:catalog-name 6 *catalog-desc* ,base:catalog-id #f #f)
  187.          (,rdms:domains-name 5 *domains-desc* ,domtab-id #f #f)
  188.          (,rdms:columns-name 5 ,rdms:columns-name ,desdes-id #f #f)))
  189.           (init-database
  190.            filename #t lldb cattab
  191.            (base:open-table lldb domtab-id 1 (itypes domains:init-cols))
  192.            #f #f))))))))
  193.  
  194.     (define (base:catalog->domains lldb base:catalog)
  195.       (let ((cat:row (cat:get-row base:catalog rdms:domains-name)))
  196.     (and cat:row
  197.          (base:open-table lldb
  198.                   (list-ref cat:row (+ -2 catalog:bastab-id-pos))
  199.                   1 (itypes domains:init-cols)))))
  200.  
  201.     (define (open-database filename writable)
  202.       (let* ((lldb (open-base filename writable))
  203.          (base:catalog
  204.           (and lldb (base:open-table lldb base:catalog-id
  205.                      1 (itypes catalog:init-cols))))
  206.          (base:domains
  207.           (and base:catalog (base:catalog->domains lldb base:catalog))))
  208.     (cond
  209.      ((not lldb) #f)
  210.      ((not base:domains) (close-base lldb) #f)
  211.      (else (init-database
  212.         filename writable lldb base:catalog base:domains #f #f)))))
  213.  
  214.     (define (init-database rdms:filename writable lldb
  215.                base:catalog base:domains rdms:catalog rdms:domains)
  216.  
  217.       (define (write-database filename)
  218.     (write-base lldb filename)
  219.     (set! rdms:filename filename))
  220.  
  221.       (define (close-database)
  222.     (close-base lldb)
  223.     (set! rdms:filename #f)
  224.     (set! base:catalog #f)
  225.     (set! base:domains #f)
  226.     (set! rdms:catalog #f)
  227.     (set! rdms:domains #f))
  228.  
  229.       (define row-ref (lambda (row pos) (list-ref row (+ -2 pos))))
  230.       (define row-eval (lambda (row pos)
  231.              (let ((ans (list-ref row (+ -2 pos))))
  232.                (and ans (slib:eval ans)))))
  233.  
  234.       (define (open-table table-name writable)
  235.     (define cat:row (cat:get-row base:catalog table-name))
  236.     (let ((column-limit (row-ref cat:row catalog:column-limit-pos))
  237.           (desc-table
  238.            (base:open-table
  239.         lldb
  240.         (row-ref (cat:get-row
  241.               base:catalog
  242.               (row-ref cat:row catalog:coltab-name-pos))
  243.              catalog:bastab-id-pos)
  244.         1 (itypes columns:init-cols)))
  245.           (base-table #f)
  246.           (base:get #f)
  247.           (primary-limit 1)
  248.           (column-name-alist '())
  249.           (column-foreign-list '())
  250.           (column-domain-list '())
  251.           (column-type-list '())
  252.           (export-alist '())
  253.           (cirs '())
  254.           (dirs '())
  255.           (list->key #f)
  256.           (key->list #f))
  257.  
  258.       (if (not desc-table)
  259.           (rdms:error "descriptor table doesn't exist for:" table-name))
  260.       (do ((ci column-limit (+ -1 ci)))
  261.           ((zero? ci))
  262.         (let* ((des:row (des:get-row desc-table ci))
  263.            (column-name (row-ref des:row columns:name-pos))
  264.            (column-domain (row-ref des:row columns:domain-name-pos)))
  265.           (set! cirs
  266.             (cons (row-eval des:row columns:integrity-rule-pos) cirs))
  267.           (set! column-name-alist
  268.             (cons (cons column-name ci) column-name-alist))
  269.           (cond
  270.            (column-domain
  271.         (let ((dom:row (dom:get-row base:domains column-domain)))
  272.           (set! dirs
  273.             (cons (row-eval dom:row domains:integrity-rule-pos)
  274.                   dirs))
  275.           (set! column-type-list
  276.             (cons (row-ref dom:row domains:type-id-pos)
  277.                   column-type-list))
  278.           (set! column-domain-list
  279.             (cons column-domain column-domain-list))
  280.           (set! column-foreign-list
  281.             (cons 
  282.              (let ((foreign-name
  283.                 (row-ref dom:row domains:foreign-pos)))
  284.                (cond
  285.                 ((or (not foreign-name)
  286.                  (eq? foreign-name table-name)) #f)
  287.                 (else
  288.                  (let* ((tab (open-table foreign-name #f))
  289.                     (p? (and tab (tab 'get 1))))
  290.                    (cond
  291.                 ((not tab)
  292.                  (rdms:error "foreign key table missing for:"
  293.                          foreign-name))
  294.                 ((not (= (tab 'primary-limit) 1))
  295.                  (rdms:error "foreign key table wrong type:"
  296.                          foreign-name))
  297.                 (else p?))))))
  298.              column-foreign-list))))
  299.            (else
  300.         (rdms:error "missing domain for column:" ci column-name)))
  301.           (cond
  302.            ((row-ref des:row columns:primary?-pos)
  303.         (set! primary-limit (max primary-limit ci))
  304.         (cond
  305.          ((base:supported-key-type? (car column-type-list)))
  306.          (else (rdms:error "key type not supported by base tables:"
  307.                    (car column-type-list)))))
  308.            ((base:supported-type? (car column-type-list)))
  309.            (else (rdms:error "type not supported by base tables:"
  310.                  (car column-type-list))))))
  311.       (set! base-table
  312.         (base:open-table lldb (row-ref cat:row catalog:bastab-id-pos)
  313.                  primary-limit column-type-list))
  314.       (set! base:get ((basic 'make-getter) primary-limit column-type-list))
  315.       (set! list->key
  316.         ((basic 'make-list-keyifier) primary-limit column-type-list))
  317.       (set! key->list
  318.         ((basic 'make-key->list) primary-limit column-type-list))
  319.       (let ((export-method
  320.          (lambda (name proc)
  321.            (set! export-alist
  322.              (cons (cons name proc) export-alist))))
  323.         (generalize-to-table
  324.          (lambda (operation)
  325.            (lambda ()
  326.              (base:for-each-primary-key base-table operation))))
  327.         (accumulate-over-table
  328.          (lambda (operation)
  329.            (lambda () (base:map-primary-key base-table operation))))
  330.         (ckey:retrieve        ;ckey gets whole row (assumes exists)
  331.          (if (= primary-limit column-limit) key->list
  332.              (lambda (ckey) (append (key->list ckey)
  333.                         (base:get base-table ckey))))))
  334.         (export-method
  335.          'row:retrieve
  336.          (if (= primary-limit column-limit)
  337.          (lambda keys
  338.            (let ((ckey (list->key keys)))
  339.              (and (present? base-table ckey) keys)))
  340.          (lambda keys
  341.            (let ((vals (base:get base-table (list->key keys))))
  342.              (and vals (append keys vals))))))
  343.         (export-method 'row:retrieve*
  344.                (accumulate-over-table
  345.                 (if (= primary-limit column-limit) key->list
  346.                 ckey:retrieve)))
  347.         (export-method
  348.          'for-each-row
  349.          (let ((r (if (= primary-limit column-limit) key->list
  350.               ckey:retrieve)))
  351.            (lambda (proc) (base:ordered-for-each-key
  352.                  base-table (lambda (ckey) (proc (r ckey)))))))
  353.         (cond
  354.          (writable
  355.           (letrec
  356.           ((combine-primary-keys
  357.             (cond
  358.              ((and (= primary-limit column-limit)
  359.                (> primary-limit 0))
  360.               list->key)
  361.              ((eq? list->key car) list->key)
  362.              (else
  363.               (case primary-limit
  364.             ((1) (let ((keyify-1 ((base 'make-keyifier-1)
  365.                           (car column-type-list))))
  366.                    (lambda (row) (keyify-1 (car row)))))
  367.             ((2) (lambda (row)
  368.                    (list->key (list (car row) (cadr row)))))
  369.             ((3) (lambda (row)
  370.                    (list->key (list (car row) (cadr row)
  371.                         (caddr row)))))
  372.             ((4) (lambda (row)
  373.                    (list->key
  374.                 (list (car row) (cadr row)
  375.                       (caddr row) (cadddr row)))))
  376.             (else (rdms:error 'combine-primary-keys
  377.                       "bad number of primary keys"
  378.                       primary-limit))))))
  379.            (uir (row-eval cat:row catalog:integrity-rule-pos))
  380.            (check-rules
  381.             (lambda (row)
  382.               (if (= column-limit (length row)) #t
  383.               (rdms:error "bad row length:" row))
  384.               (for-each
  385.                (lambda (cir dir value column-name column-domain foreign)
  386.              (cond
  387.               ((and dir (not (dir value)))
  388.                (rdms:error "violated domain integrity rule:"
  389.                        table-name column-name
  390.                        column-domain value))
  391.               ((and cir (not (cir value)))
  392.                (rdms:error "violated column integrity rule:"
  393.                        table-name column-name value))
  394.               ((and foreign (not (foreign value)))
  395.                (rdms:error "foreign key missing:"
  396.                        table-name column-name value))))
  397.                cirs dirs row
  398.                column-name-alist column-domain-list column-foreign-list)
  399.               (cond ((and uir (not (uir row)))
  400.                  (rdms:error "violated user integrity rule:"
  401.                      row)))))
  402.            (putter
  403.             ((basic 'make-putter) primary-limit column-type-list))
  404.            (row:insert
  405.             (lambda (row)
  406.               (check-rules row)
  407.               (let ((ckey (combine-primary-keys row)))
  408.             (if (present? base-table ckey)
  409.                 (rdms:error 'row:insert "row present:" row))
  410.             (putter base-table ckey
  411.                 (list-tail row primary-limit)))))
  412.            (row:update
  413.             (lambda (row)
  414.               (check-rules row)
  415.               (putter base-table (combine-primary-keys row)
  416.                   (list-tail row primary-limit)))))
  417.  
  418.         (export-method 'row:insert row:insert)
  419.         (export-method 'row:insert*
  420.                    (lambda (rows) (for-each row:insert rows)))
  421.         (export-method 'row:update row:update)
  422.         (export-method 'row:update*
  423.                    (lambda (rows) (for-each row:update rows))))
  424.  
  425.           (letrec ((base:delete (basic 'delete))
  426.                (ckey:remove (lambda (ckey)
  427.                       (let ((r (ckey:retrieve ckey)))
  428.                     (and r (base:delete base-table ckey))
  429.                     r))))
  430.         (export-method 'row:remove
  431.                    (lambda keys
  432.                  (let ((ckey (list->key keys)))
  433.                    (and (present? base-table ckey)
  434.                     (ckey:remove ckey)))))
  435.         (export-method 'row:delete
  436.                    (lambda keys
  437.                  (base:delete base-table (list->key keys))))
  438.         (export-method 'row:remove*
  439.                    (accumulate-over-table ckey:remove))
  440.         (export-method 'row:delete*
  441.                    (generalize-to-table
  442.                 (lambda (ckey) (base:delete base-table ckey))))
  443.         (export-method 'close-table
  444.                    (lambda () (set! base-table #f)
  445.                        (set! desc-table #f)
  446.                        (set! export-alist #f))))))
  447.  
  448.         (export-method 'column-names (map car column-name-alist))
  449.         (export-method 'column-foreigns column-foreign-list)
  450.         (export-method 'column-domains column-domain-list)
  451.         (export-method 'column-types column-type-list)
  452.         (export-method 'primary-limit primary-limit)
  453.  
  454.         (let ((translate-column
  455.            (lambda (column)
  456.              ;;(print 'translate-column column column-name-alist)
  457.              (let ((colp (assq column column-name-alist)))
  458.                (cond (colp (cdr colp))
  459.                  ((and (number? column)
  460.                    (integer? column)
  461.                    (<= 1 column column-limit))
  462.                   column)
  463.                  (else (rdms:error "column not in table:"
  464.                            column table-name)))))))
  465.           (lambda args
  466.         (cond
  467.          ((null? args) #f)
  468.          ((null? (cdr args))
  469.           (let ((pp (assq (car args) export-alist)))
  470.             (and pp (cdr pp))))
  471.          ((not (null? (cddr args)))
  472.           (rdms:error "too many arguments to methods:" args))
  473.          (else
  474.           (let ((ci (translate-column (cadr args))))
  475.             (cond
  476.              ((<= ci primary-limit) ;primary-key?
  477.               (let ((key-extractor
  478.                  ((base 'make-key-extractor)
  479.                   primary-limit column-type-list ci)))
  480.             (case (car args)
  481.               ((get) (lambda keys
  482.                    (and (present? base-table (list->key keys))
  483.                     (list-ref keys (+ -1 ci)))))
  484.               ((get*) (lambda ()
  485.                     (base:map-primary-key
  486.                      base-table
  487.                      (lambda (ckey) (key-extractor ckey)))))
  488.               (else #f))))
  489.              (else
  490.               (let ((index (- ci (+ 1 primary-limit))))
  491.             (case (car args)
  492.               ((get) (lambda keys
  493.                    (let ((row (base:get base-table
  494.                             (list->key keys))))
  495.                      (and row (list-ref row index)))))
  496.               ((get*) (lambda ()
  497.                     (base:map-primary-key
  498.                      base-table
  499.                      (lambda (ckey)
  500.                        (list-ref (base:get base-table ckey)
  501.                          index)))))
  502.               (else #f)))))))))))))
  503.  
  504.       (define (create-table table-name . desc)
  505.     (if (not rdms:catalog)
  506.         (set! rdms:catalog (open-table rdms:catalog-name #t)) #f)
  507.     (cond
  508.      ((table-exists? table-name)
  509.       (rdms:error "table already exists:" table-name) #f)
  510.      ((null? desc)
  511.       (let ((colt-id (base:make-table lldb 1 (itypes columns:init-cols))))
  512.         ((rdms:catalog 'row:insert)
  513.          (list table-name
  514.            (length columns:init-cols)
  515.            ((rdms:catalog 'get 'coltab-name)
  516.             rdms:columns-name)
  517.            colt-id
  518.            #f
  519.            #f)))
  520.       (open-table table-name #t))
  521.      ((null? (cdr desc))
  522.       (set! desc (car desc))
  523.       (let ((colt-id ((rdms:catalog 'get 'bastab-id) desc)))
  524.         (cond
  525.          (colt-id
  526.           (let ((coltable (open-table desc #f))
  527.             (types '())
  528.             (prilimit 0)
  529.             (colimit 0)
  530.             (colerr #f))
  531.         (for-each (lambda (n p d)
  532.                 (if (number? n) (set! colimit (max colimit n))
  533.                 (set! colerr #t))
  534.                 (if p (set! prilimit (+ 1 prilimit)) #f)
  535.                 (set! types (cons
  536.                      (dom:get-row base:domains d) types)))
  537.               ((coltable 'get* 'column-number))
  538.               ((coltable 'get* 'primary-key?))
  539.               ((coltable 'get* 'domain-name)))
  540.         (cond (colerr (rdms:error "some column lacks a number.") #f)
  541.               ((or (< prilimit 1)
  542.                (and (> prilimit 4)
  543.                 (not (= prilimit colimit))))
  544.                (rdms:error "unreasonable number of primary keys:"
  545.                    prilimit))
  546.               (else
  547.                ((rdms:catalog 'row:insert)
  548.             (list table-name colimit desc
  549.                   (base:make-table lldb prilimit types) #f #f))
  550.                (open-table table-name #t)))))
  551.          (else
  552.           (rdms:error "table descriptor not found for:" desc) #f))))
  553.      (else (rdms:error 'create-table "too many args:"
  554.                (cons table-name desc))
  555.            #f)))
  556.  
  557.       (define (table-exists? table-name)
  558.     (present? base:catalog (cat:keyify-1 table-name)))
  559.  
  560.       (define (delete-table table-name)
  561.     (if (not rdms:catalog)
  562.         (set! rdms:catalog (open-table rdms:catalog-name #t)) #f)
  563.     (let ((table (open-table table-name #t))
  564.           (row ((rdms:catalog 'row:remove) table-name)))
  565.       (and row (base:kill-table
  566.             lldb
  567.             (list-ref row (+ -1 catalog:bastab-id-pos))
  568.             (table 'primary-limit)
  569.             (table 'column-type-list))
  570.            row)))
  571.  
  572.       (define (delete-domain domain-name)
  573.     (if (not rdms:domains)
  574.         (set! rdms:domains (open-table rdms:domains-name #t)) #f)
  575.     ((rdms:domains 'row:remove) domain-name))
  576.  
  577.       (define (add-domain domain-row)
  578.     (if (not rdms:domains)
  579.         (set! rdms:domains (open-table rdms:domains-name #t)) #f)
  580.     ((rdms:domains 'row:insert) domain-row))
  581.  
  582.       (lambda (operation-name)
  583.     (case operation-name
  584.       ((close-database) close-database)
  585.       ((write-database) write-database)
  586.       ((open-table) open-table)
  587.       ((delete-table) delete-table)
  588.       ((create-table) create-table)
  589.       ((table-exists?) table-exists?)
  590.       ((add-domain) add-domain)
  591.       ((delete-domain) delete-domain)
  592.       (else #f)))
  593.       )
  594.     (lambda (operation-name)
  595.       (case operation-name
  596.     ((create-database) create-database)
  597.     ((open-database) open-database)
  598.     (else #f)))
  599.     ))
  600.