home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / slib / rdms.scm < prev    next >
Encoding:
Text File  |  2004-01-06  |  20.5 KB  |  626 lines
  1. ;;; "rdms.scm" rewrite 6 - the saga continues
  2. ; Copyright 1994, 1995, 1997 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.           number
  81.           #f)
  82.     (number #f number? number #f)
  83.     (expression #f #f expression #f)
  84.     (boolean #f boolean? boolean #f)
  85.     (symbol #f symbol? symbol #f)
  86.     (string #f string? string #f)
  87.     (domain ,rdms:domains-name #f atom #f)))
  88.  
  89. (define rdms:warn slib:warn)
  90. (define rdms:error slib:error)
  91.  
  92. (define (make-relational-system base)
  93.   (define basic
  94.     (lambda (name)
  95.       (let ((meth (base name)))
  96.     (cond ((not meth) (rdms:error 'make-relational-system
  97.                       "essential method missing for:" name)))
  98.     meth)))
  99.  
  100.   (define (desc-row-type row)
  101.     (let ((domain (assq (car (cddddr row)) domains:init-data)))
  102.       (and domain (cadddr domain))))
  103.  
  104.   (let ((make-base (base 'make-base))
  105.     (open-base (basic 'open-base))
  106.     (write-base (base 'write-base))
  107.     (sync-base (base 'sync-base))
  108.     (close-base (basic 'close-base))
  109.     (base:supported-type? (basic 'supported-type?))
  110.     (base:supported-key-type? (basic 'supported-key-type?))
  111.     (base:make-table (base 'make-table))
  112.     (base:open-table (basic 'open-table))
  113.     (base:kill-table (base 'kill-table))
  114.     (present? (basic 'present?))
  115.     (base:ordered-for-each-key (basic 'ordered-for-each-key))
  116.     (base:for-each-primary-key (basic 'for-each-key))
  117.     (base:map-primary-key (basic 'map-key))
  118.     (base:catalog-id (basic 'catalog-id))
  119.     (cat:keyify-1 ((basic 'make-keyifier-1)
  120.                (desc-row-type (assv 1 catalog:init-cols))))
  121.     (itypes
  122.      (lambda (rows)
  123.        (map (lambda (row)
  124.           (let ((domrow (assq (car (cddddr row)) domains:init-data)))
  125.             (cond (domrow (cadddr domrow))
  126.               (else (rdms:error 'itypes "type not found for:"
  127.                         (car (cddddr row)))))))
  128.         rows))))
  129.  
  130.     (define (init-tab lldb id descriptor rows)
  131.       (let ((han (base:open-table lldb id 1 (itypes descriptor)))
  132.         (keyify-1
  133.          ((base 'make-keyifier-1) (desc-row-type (assv 1 descriptor))))
  134.         (putter ((basic 'make-putter) 1 (itypes descriptor))))
  135.     (for-each (lambda (row) (putter han (keyify-1 (car row)) (cdr row)))
  136.           rows)))
  137.  
  138.     (define cat:get-row
  139.       (let ((cat:getter ((basic 'make-getter) 1 (itypes catalog:init-cols))))
  140.     (lambda (bastab key)
  141.       (cat:getter bastab (cat:keyify-1 key)))))
  142.  
  143.     (define dom:get-row
  144.       (let ((dom:getter ((basic 'make-getter) 1 (itypes domains:init-cols)))
  145.         (dom:keyify-1 ((basic 'make-keyifier-1)
  146.                (desc-row-type (assv 1 domains:init-cols)))))
  147.     (lambda (bastab key)
  148.       (dom:getter bastab (dom:keyify-1 key)))))
  149.  
  150.     (define des:get-row
  151.       (let ((des:getter ((basic 'make-getter) 1 (itypes columns:init-cols)))
  152.         (des:keyify-1 ((basic 'make-keyifier-1)
  153.                (desc-row-type (assv 1 columns:init-cols)))))
  154.     (lambda (bastab key)
  155.       (des:getter bastab (des:keyify-1 key)))))
  156.  
  157.     (define (create-database filename)
  158.       ;;(cond ((and filename (file-exists? filename))
  159.          ;;(rdms:warn 'create-database "file exists:" filename)))
  160.       (let* ((lldb (make-base filename 1 (itypes catalog:init-cols)))
  161.          (cattab (and lldb (base:open-table lldb base:catalog-id 1
  162.                         (itypes catalog:init-cols)))))
  163.     (cond
  164.      ((not lldb) (rdms:error 'make-base "failed.") #f)
  165.      ((not cattab) (rdms:error 'make-base "catalog missing.")
  166.                (close-base lldb)
  167.                #f)
  168.      (else
  169.       (let ((desdes-id (base:make-table lldb 1 (itypes columns:init-cols)))
  170.         (domdes-id (base:make-table lldb 1 (itypes columns:init-cols)))
  171.         (catdes-id (base:make-table lldb 1 (itypes columns:init-cols)))
  172.         (domtab-id (base:make-table lldb 1 (itypes domains:init-cols)))
  173.         )
  174.         (cond
  175.          ((not (and catdes-id domdes-id domtab-id desdes-id))
  176.           (rdms:error 'create-database "make-table failed.")
  177.           (close-base lldb)
  178.           #f)
  179.          (else
  180.           (init-tab lldb desdes-id columns:init-cols columns:init-cols)
  181.           (init-tab lldb domdes-id columns:init-cols domains:init-cols)
  182.           (init-tab lldb catdes-id columns:init-cols catalog:init-cols)
  183.           (init-tab lldb domtab-id domains:init-cols domains:init-data)
  184.           (init-tab
  185.            lldb base:catalog-id catalog:init-cols
  186.            `((*catalog-desc* 5 ,rdms:columns-name ,catdes-id #f #f)
  187.          (*domains-desc* 5 ,rdms:columns-name ,domdes-id #f #f)
  188.          (,rdms:catalog-name 6 *catalog-desc* ,base:catalog-id #f #f)
  189.          (,rdms:domains-name 5 *domains-desc* ,domtab-id #f #f)
  190.          (,rdms:columns-name 5 ,rdms:columns-name ,desdes-id #f #f)))
  191.           (init-database
  192.            filename #t lldb cattab
  193.            (base:open-table lldb domtab-id 1 (itypes domains:init-cols))
  194.            #f))))))))
  195.  
  196.     (define (base:catalog->domains lldb base:catalog)
  197.       (let ((cat:row (cat:get-row base:catalog rdms:domains-name)))
  198.     (and cat:row
  199.          (base:open-table lldb
  200.                   (list-ref cat:row (+ -2 catalog:bastab-id-pos))
  201.                   1 (itypes domains:init-cols)))))
  202.  
  203.     (define (open-database filename mutable)
  204.       (let* ((lldb (open-base filename mutable))
  205.          (base:catalog
  206.           (and lldb (base:open-table lldb base:catalog-id
  207.                      1 (itypes catalog:init-cols))))
  208.          (base:domains
  209.           (and base:catalog (base:catalog->domains lldb base:catalog))))
  210.     (cond
  211.      ((not lldb) #f)
  212.      ((not base:domains) (close-base lldb) #f)
  213.      (else (init-database
  214.         filename mutable lldb base:catalog base:domains #f)))))
  215.  
  216.     (define (init-database rdms:filename mutable lldb
  217.                base:catalog base:domains rdms:catalog)
  218.  
  219.       (define (write-database filename)
  220.     (let ((ans (write-base lldb filename)))
  221.       (and ans (set! rdms:filename filename))
  222.       ans))
  223.  
  224.       (define (close-database)
  225.     (close-base lldb)
  226.     (set! rdms:filename #f)
  227.     (set! base:catalog #f)
  228.     (set! base:domains #f)
  229.     (set! rdms:catalog #f))
  230.  
  231.       (define row-ref (lambda (row pos) (list-ref row (+ -2 pos))))
  232.       (define row-eval (lambda (row pos)
  233.              (let ((ans (list-ref row (+ -2 pos))))
  234.                (and ans (slib:eval ans)))))
  235.  
  236.       (define (open-table table-name writable)
  237.     (define cat:row (cat:get-row base:catalog table-name))
  238.     (cond ((not cat:row)
  239.            (rdms:error "can't open-table:" table-name))
  240.           ((and writable (not mutable))
  241.            (rdms:error "can't open-table for writing:" table-name)))
  242.     (let ((column-limit (row-ref cat:row catalog:column-limit-pos))
  243.           (desc-table
  244.            (base:open-table
  245.         lldb
  246.         (row-ref (cat:get-row
  247.               base:catalog
  248.               (row-ref cat:row catalog:coltab-name-pos))
  249.              catalog:bastab-id-pos)
  250.         1 (itypes columns:init-cols)))
  251.           (base-table #f)
  252.           (base:get #f)
  253.           (primary-limit 1)
  254.           (column-name-alist '())
  255.           (column-foreign-list '())
  256.           (column-foreign-check-list '())
  257.           (column-domain-list '())
  258.           (column-type-list '())
  259.           (export-alist '())
  260.           (cirs '())
  261.           (dirs '())
  262.           (list->key #f)
  263.           (key->list #f))
  264.  
  265.       (if (not desc-table)
  266.           (rdms:error "descriptor table doesn't exist for:" table-name))
  267.       (do ((ci column-limit (+ -1 ci)))
  268.           ((zero? ci))
  269.         (let* ((des:row (des:get-row desc-table ci))
  270.            (column-name (row-ref des:row columns:name-pos))
  271.            (column-domain (row-ref des:row columns:domain-name-pos)))
  272.           (set! cirs
  273.             (cons (row-eval des:row columns:integrity-rule-pos) cirs))
  274.           (set! column-name-alist
  275.             (cons (cons column-name ci) column-name-alist))
  276.           (cond
  277.            (column-domain
  278.         (let ((dom:row (dom:get-row base:domains column-domain)))
  279.           (set! dirs
  280.             (cons (row-eval dom:row domains:integrity-rule-pos)
  281.                   dirs))
  282.           (set! column-type-list
  283.             (cons (row-ref dom:row domains:type-id-pos)
  284.                   column-type-list))
  285.           (set! column-domain-list
  286.             (cons column-domain column-domain-list))
  287.           (set! column-foreign-list
  288.             (cons (let ((foreign-name
  289.                      (row-ref dom:row domains:foreign-pos)))
  290.                 (and (not (eq? foreign-name table-name))
  291.                      foreign-name))
  292.                   column-foreign-list))
  293.           (set! column-foreign-check-list
  294.             (cons
  295.              (let ((foreign-name (car column-foreign-list)))
  296.                (and foreign-name
  297.                 (let* ((tab (open-table foreign-name #f))
  298.                        (p? (and tab (tab 'get 1))))
  299.                   (cond
  300.                    ((not tab)
  301.                     (rdms:error "foreign key table missing for:"
  302.                         foreign-name))
  303.                    ((not (= (tab 'primary-limit) 1))
  304.                     (rdms:error "foreign key table wrong type:"
  305.                         foreign-name))
  306.                    (else p?)))))
  307.              column-foreign-check-list))))
  308.            (else
  309.         (rdms:error "missing domain for column:" ci column-name)))
  310.           (cond
  311.            ((row-ref des:row columns:primary?-pos)
  312.         (set! primary-limit (max primary-limit ci))
  313.         (cond
  314.          ((base:supported-key-type? (car column-type-list)))
  315.          (else (rdms:error "key type not supported by base tables:"
  316.                    (car column-type-list)))))
  317.            ((base:supported-type? (car column-type-list)))
  318.            (else (rdms:error "type not supported by base tables:"
  319.                  (car column-type-list))))))
  320.       (set! base-table
  321.         (base:open-table lldb (row-ref cat:row catalog:bastab-id-pos)
  322.                  primary-limit column-type-list))
  323.       (set! base:get ((basic 'make-getter) primary-limit column-type-list))
  324.       (set! list->key
  325.         ((basic 'make-list-keyifier) primary-limit column-type-list))
  326.       (set! key->list
  327.         ((basic 'make-key->list) primary-limit column-type-list))
  328.       (letrec ((export-method
  329.             (lambda (name proc)
  330.               (set! export-alist
  331.                 (cons (cons name proc) export-alist))))
  332.            (ckey:retrieve    ;ckey gets whole row (assumes exists)
  333.             (if (= primary-limit column-limit) key->list
  334.             (lambda (ckey) (append (key->list ckey)
  335.                            (base:get base-table ckey)))))
  336.            (accumulate-over-table
  337.             (lambda (operation)
  338.               (lambda mkeys (base:map-primary-key
  339.                      base-table operation
  340.                      primary-limit column-type-list
  341.                      (norm-mkeys mkeys)))))
  342.            (norm-mkeys
  343.             (lambda (mkeys)
  344.               (define mlim (length mkeys))
  345.               (cond ((> mlim primary-limit)
  346.                  (rdms:error "too many keys:" mkeys))
  347.                 ((= mlim primary-limit) mkeys)
  348.                 (else
  349.                  (append mkeys
  350.                      (do ((k (- primary-limit mlim) (+ -1 k))
  351.                       (result '() (cons #f result)))
  352.                      ((<= k 0) result))))))))
  353.         (export-method
  354.          'row:retrieve
  355.          (if (= primary-limit column-limit)
  356.          (lambda keys
  357.            (let ((ckey (list->key keys)))
  358.              (and (present? base-table ckey) keys)))
  359.          (lambda keys
  360.            (let ((vals (base:get base-table (list->key keys))))
  361.              (and vals (append keys vals))))))
  362.         (export-method 'row:retrieve*
  363.                (accumulate-over-table
  364.                 (if (= primary-limit column-limit) key->list
  365.                 ckey:retrieve)))
  366.         (export-method
  367.          'for-each-row
  368.          (let ((r (if (= primary-limit column-limit) key->list
  369.               ckey:retrieve)))
  370.            (lambda (proc . mkeys)
  371.          (base:ordered-for-each-key
  372.           base-table (lambda (ckey) (proc (r ckey)))
  373.           primary-limit column-type-list
  374.           (norm-mkeys mkeys)))))
  375.         (cond
  376.          ((and mutable writable)
  377.           (letrec
  378.           ((combine-primary-keys
  379.             (cond
  380.              ((and (= primary-limit column-limit)
  381.                (> primary-limit 0))
  382.               list->key)
  383.              ((eq? list->key car) list->key)
  384.              (else
  385.               (case primary-limit
  386.             ((1) (let ((keyify-1 ((base 'make-keyifier-1)
  387.                           (car column-type-list))))
  388.                    (lambda (row) (keyify-1 (car row)))))
  389.             ((2) (lambda (row)
  390.                    (list->key (list (car row) (cadr row)))))
  391.             ((3) (lambda (row)
  392.                    (list->key (list (car row) (cadr row)
  393.                         (caddr row)))))
  394.             ((4) (lambda (row)
  395.                    (list->key
  396.                 (list (car row) (cadr row)
  397.                       (caddr row) (cadddr row)))))
  398.             (else (rdms:error 'combine-primary-keys
  399.                       "bad number of primary keys"
  400.                       primary-limit))))))
  401.            (uir (row-eval cat:row catalog:integrity-rule-pos))
  402.            (check-rules
  403.             (lambda (row)
  404.               (if (= column-limit (length row)) #t
  405.               (rdms:error "bad row length:" row))
  406.               (for-each
  407.                (lambda (cir dir value column-name column-domain
  408.                     foreign)
  409.              (cond
  410.               ((and dir (not (dir value)))
  411.                (rdms:error "violated domain integrity rule:"
  412.                        table-name column-name
  413.                        column-domain value))
  414.               ((and cir (not (cir value)))
  415.                (rdms:error "violated column integrity rule:"
  416.                        table-name column-name value))
  417.               ((and foreign (not (foreign value)))
  418.                (rdms:error "foreign key missing:"
  419.                        table-name column-name value))))
  420.                cirs dirs row column-name-alist column-domain-list
  421.                column-foreign-check-list)
  422.               (cond ((and uir (not (uir row)))
  423.                  (rdms:error "violated user integrity rule:"
  424.                      row)))))
  425.            (putter
  426.             ((basic 'make-putter) primary-limit column-type-list))
  427.            (row:insert
  428.             (lambda (row)
  429.               (check-rules row)
  430.               (let ((ckey (combine-primary-keys row)))
  431.             (if (present? base-table ckey)
  432.                 (rdms:error 'row:insert "row present:" row))
  433.             (putter base-table ckey
  434.                 (list-tail row primary-limit)))))
  435.            (row:update
  436.             (lambda (row)
  437.               (check-rules row)
  438.               (putter base-table (combine-primary-keys row)
  439.                   (list-tail row primary-limit)))))
  440.  
  441.         (export-method 'row:insert row:insert)
  442.         (export-method 'row:insert*
  443.                    (lambda (rows) (for-each row:insert rows)))
  444.         (export-method 'row:update row:update)
  445.         (export-method 'row:update*
  446.                    (lambda (rows) (for-each row:update rows))))
  447.  
  448.           (letrec ((base:delete (basic 'delete))
  449.                (base:delete* (basic 'delete*))
  450.                (ckey:remove (lambda (ckey)
  451.                       (let ((r (ckey:retrieve ckey)))
  452.                     (and r (base:delete base-table ckey))
  453.                     r))))
  454.         (export-method 'row:remove
  455.                    (lambda keys
  456.                  (let ((ckey (list->key keys)))
  457.                    (and (present? base-table ckey)
  458.                     (ckey:remove ckey)))))
  459.         (export-method 'row:delete
  460.                    (lambda keys
  461.                  (base:delete base-table (list->key keys))))
  462.         (export-method 'row:remove*
  463.                    (accumulate-over-table ckey:remove))
  464.         (export-method 'row:delete*
  465.                    (lambda mkeys
  466.                  (base:delete* base-table
  467.                            primary-limit column-type-list
  468.                            (norm-mkeys mkeys))))
  469.         (export-method 'close-table
  470.                    (lambda () (set! base-table #f)
  471.                        (set! desc-table #f)
  472.                        (set! export-alist #f))))))
  473.  
  474.         (export-method 'column-names (map car column-name-alist))
  475.         (export-method 'column-foreigns column-foreign-list)
  476.         (export-method 'column-domains column-domain-list)
  477.         (export-method 'column-types column-type-list)
  478.         (export-method 'primary-limit primary-limit)
  479.  
  480.         (let ((translate-column
  481.            (lambda (column)
  482.              ;;(print 'translate-column column column-name-alist)
  483.              (let ((colp (assq column column-name-alist)))
  484.                (cond (colp (cdr colp))
  485.                  ((and (number? column)
  486.                    (integer? column)
  487.                    (<= 1 column column-limit))
  488.                   column)
  489.                  (else (rdms:error "column not in table:"
  490.                            column table-name)))))))
  491.           (lambda args
  492.         (cond
  493.          ((null? args)
  494.           #f)
  495.          ((null? (cdr args))
  496.           (let ((pp (assq (car args) export-alist)))
  497.             (and pp (cdr pp))))
  498.          ((not (null? (cddr args)))
  499.           (rdms:error "too many arguments to methods:" args))
  500.          (else
  501.           (let ((ci (translate-column (cadr args))))
  502.             (cond
  503.              ((<= ci primary-limit) ;primary-key?
  504.               (case (car args)
  505.             ((get) (lambda gkeys
  506.                  (and (present? base-table (list->key gkeys))
  507.                       (list-ref gkeys (+ -1 ci)))))
  508.             ((get*) (let ((key-extractor
  509.                        ((base 'make-key-extractor)
  510.                     primary-limit column-type-list ci)))
  511.                   (lambda mkeys
  512.                     (base:map-primary-key
  513.                      base-table
  514.                      (lambda (ckey) (key-extractor ckey))
  515.                      primary-limit column-type-list
  516.                      (norm-mkeys mkeys)))))
  517.             (else #f)))
  518.              (else
  519.               (let ((index (- ci (+ 1 primary-limit))))
  520.             (case (car args)
  521.               ((get) (lambda keys
  522.                    (let ((row (base:get base-table
  523.                             (list->key keys))))
  524.                      (and row (list-ref row index)))))
  525.               ((get*) (lambda mkeys
  526.                     (base:map-primary-key
  527.                      base-table
  528.                      (lambda (ckey)
  529.                        (list-ref (base:get base-table ckey)
  530.                          index))
  531.                      primary-limit column-type-list
  532.                      (norm-mkeys mkeys))))
  533.               (else #f)))))))))))))
  534.  
  535.       (define create-table
  536.     (and
  537.      mutable
  538.      (lambda (table-name . desc)
  539.        (if (not rdms:catalog)
  540.            (set! rdms:catalog (open-table rdms:catalog-name #t)) #f)
  541.        (cond
  542.         ((table-exists? table-name)
  543.          (rdms:error "table already exists:" table-name) #f)
  544.         ((null? desc)
  545.          (let ((colt-id
  546.             (base:make-table lldb 1 (itypes columns:init-cols))))
  547.            ((rdms:catalog 'row:insert)
  548.         (list table-name
  549.               (length columns:init-cols)
  550.               ((rdms:catalog 'get 'coltab-name)
  551.                rdms:columns-name)
  552.               colt-id
  553.               #f
  554.               #f)))
  555.          (open-table table-name #t))
  556.         ((null? (cdr desc))
  557.          (set! desc (car desc))
  558.          (let ((colt-id ((rdms:catalog 'get 'bastab-id) desc)))
  559.            (cond
  560.         (colt-id
  561.          (let ((coltable (open-table desc #f))
  562.                (types '())
  563.                (prilimit 0)
  564.                (colimit 0)
  565.                (colerr #f))
  566.            (for-each (lambda (n p d)
  567.                    (if (number? n) (set! colimit (max colimit n))
  568.                    (set! colerr #t))
  569.                    (if p (set! prilimit (+ 1 prilimit)) #f)
  570.                    (set! types
  571.                      (cons (dom:get-row base:domains d)
  572.                        types)))
  573.                  ((coltable 'get* 'column-number))
  574.                  ((coltable 'get* 'primary-key?))
  575.                  ((coltable 'get* 'domain-name)))
  576.            (cond (colerr (rdms:error "some column lacks a number.") #f)
  577.              ((or (< prilimit 1)
  578.                   (and (> prilimit 4)
  579.                    (not (= prilimit colimit))))
  580.               (rdms:error "unreasonable number of primary keys:"
  581.                       prilimit))
  582.              (else
  583.               ((rdms:catalog 'row:insert)
  584.                (list table-name colimit desc
  585.                  (base:make-table lldb prilimit types) #f #f))
  586.               (open-table table-name #t)))))
  587.         (else
  588.          (rdms:error "table descriptor not found for:" desc) #f))))
  589.         (else (rdms:error 'create-table "too many args:"
  590.                   (cons table-name desc))
  591.           #f)))))
  592.  
  593.       (define (table-exists? table-name)
  594.     (present? base:catalog (cat:keyify-1 table-name)))
  595.  
  596.       (define delete-table
  597.     (and mutable
  598.          (lambda (table-name)
  599.            ;;(if (not rdms:catalog)
  600.            ;;(set! rdms:catalog (open-table rdms:catalog-name #t)) #f)
  601.            (let* ((table (open-table table-name #t))
  602.               (row ((rdms:catalog 'row:remove) table-name)))
  603.          (and row (base:kill-table
  604.                lldb
  605.                (list-ref row (+ -1 catalog:bastab-id-pos))
  606.                (table 'primary-limit)
  607.                (table 'column-type-list))
  608.               row)))))
  609.  
  610.       (lambda (operation-name)
  611.     (case operation-name
  612.       ((close-database) close-database)
  613.       ((write-database) write-database)
  614.       ((open-table) open-table)
  615.       ((delete-table) delete-table)
  616.       ((create-table) create-table)
  617.       ((table-exists?) table-exists?)
  618.       (else #f)))
  619.       )
  620.     (lambda (operation-name)
  621.       (case operation-name
  622.     ((create-database) create-database)
  623.     ((open-database) open-database)
  624.     (else #f)))
  625.     ))
  626.