diff options
Diffstat (limited to 'dbsyn.scm')
| -rw-r--r-- | dbsyn.scm | 68 |
1 files changed, 57 insertions, 11 deletions
@@ -1,5 +1,7 @@ -;;;; "dbsyn.scm" -- Syntactic extensions for RDMS (within-database) -;;; Copyright (C) 2002 Ivan Shmakov <ivan@theory.dcn-asu.ru> +;;; "dbsyn.scm" -- Syntactic extensions for RDMS -*- scheme -*- +;; Features: within-database + +;;; Copyright (C) 2002, 2003 Ivan Shmakov <ivan@theory.dcn-asu.ru> ;; ;; Permission to copy this software, to modify it, to redistribute it, ;; to distribute modified versions, and to use it for any purpose is @@ -31,24 +33,68 @@ ;; ... and get TAGS table with all of my database commands and tables. -(require 'relational-database) +;;; Code: (require 'database-commands) (require 'databases) +(require 'relational-database) + ;@ (define-syntax within-database - (syntax-rules (define-table define-command) - + (syntax-rules (define-table define-command define-macro) + ; ((within-database database) database) - + ; define-table ((within-database database - (define-table (name primary columns) row ...) - rest ...) + (define-table (name primary columns) row ...) + rest ...) (begin (define-tables database '(name primary columns (row ...))) (within-database database rest ...))) - + ; define-command ((within-database database - (define-command template arg-1 arg-2 ...) - rest ...) + (define-command template arg-1 arg-2 ...) + rest ...) (begin (define-*commands* database '(template arg-1 arg-2 ...)) + (within-database database rest ...))) + ; + ((within-database database + (command arg-1 ...) + rest ...) + (begin (cond ((let ((p (database '*macro*))) + (and p (slib:eval (p 'command)))) + => (lambda (proc) + (slib:eval + (apply proc database '(arg-1 ...))))) + (else + ((database 'command) arg-1 ...))) (within-database database rest ...))))) + +(define (define-*macros* rdb . specs) + (define defmac + (((rdb 'open-table) '*macros* #t) 'row:update)) + (for-each (lambda (spec) + (let* ((procname (caar spec)) + (args (cdar spec)) + (body-1 (cdr spec)) + (comment (and (string? (car body-1)) + (car body-1))) + (body (if comment (cdr body-1) body-1))) + (defmac (list procname + `(lambda ,args . ,body) + (or comment ""))))) + specs)) + +;@ +(define (add-macro-support rdb) + (define-tables rdb + '(*macros* + ((name symbol)) + ((procedure expression) + (documentation string)) + ((define-macro (lambda (db . args) + (define-*macros* db args) + #t) "")))) + (define-*commands* rdb + '((*macro* rdb) + (((rdb 'open-table) '*macros* #f) 'get 'procedure))) + rdb) |