From 5145dd3aa0c02c9fc496d1432fc4410674206e1d Mon Sep 17 00:00:00 2001
From: Bryan Newbold <bnewbold@robocracy.org>
Date: Mon, 20 Feb 2017 00:05:31 -0800
Subject: Import Upstream version 3a2

---
 dbsyn.scm | 68 ++++++++++++++++++++++++++++++++++++++++++++++++++++-----------
 1 file changed, 57 insertions(+), 11 deletions(-)

(limited to 'dbsyn.scm')

diff --git a/dbsyn.scm b/dbsyn.scm
index 1bc1319..f807642 100644
--- a/dbsyn.scm
+++ b/dbsyn.scm
@@ -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)
-- 
cgit v1.2.3